Tk-804.031/000755 001750 001750 00000000000 12150132176 013065 5ustar00eserteeserte000000 000000 Tk-804.031/pTk/000755 001750 001750 00000000000 12150132176 013623 5ustar00eserteeserte000000 000000 Tk-804.031/pod/000755 001750 001750 00000000000 12150132176 013647 5ustar00eserteeserte000000 000000 Tk-804.031/examples/000755 001750 001750 00000000000 12150132176 014703 5ustar00eserteeserte000000 000000 Tk-804.031/PNG/000755 001750 001750 00000000000 12150132176 013511 5ustar00eserteeserte000000 000000 Tk-804.031/t/000755 001750 001750 00000000000 12150132176 013330 5ustar00eserteeserte000000 000000 Tk-804.031/JPEG/000755 001750 001750 00000000000 12150132175 013611 5ustar00eserteeserte000000 000000 Tk-804.031/mkppm.bat000755 001750 001750 00000000731 11400162251 014677 0ustar00eserteeserte000000 000000 @perl -Sx %0 "%*" @goto endofperl #!perl -w open(PPD,"Tk.ppd") || die "Cannot open Tk.ppd:$!"; my $tar; while () { if (/ 14) { print "$l > 14 for $elm of $file\n"; } } } Tk-804.031/Menubutton/000755 001750 001750 00000000000 12150132175 015224 5ustar00eserteeserte000000 000000 Tk-804.031/README.IRIX000644 001750 001750 00000001314 11400162251 014510 0ustar00eserteeserte000000 000000 perl-5.8.1 and Tk804.025 on IRIX 6.5.20m 1) IRIX has no ranlib, it's not required. When building builtin zlib/png support make will fail trying to invoke ranlib. I (Steve Lidie) did: alias ranlib=true Perl5.004/Tk402.* on IRIX 6.2 Craig reports that there is a -lnsl in /usr/lib which MakeMaker finds but which linker does not. Craig M Votava writes: > >I built it without the -lnsl with this command: > >perl Makefile.PL LIBS="-L/usr/lib -L/usr/lib32 -lX11 -lpt -lsocket -lm" > > >I think both of this can be done in the perl5.004 irix configuration scripts >so that Tk402.000 picks them up... right? > Really needs a hints file - but I (Nick) can't remember how to do one... Tk-804.031/Tixish/000755 001750 001750 00000000000 12150132175 014334 5ustar00eserteeserte000000 000000 Tk-804.031/Xlib/000755 001750 001750 00000000000 12150132176 013763 5ustar00eserteeserte000000 000000 Tk-804.031/VERSIONS000644 001750 001750 00000001114 11400162166 014254 0ustar00eserteeserte000000 000000 This is Tk402.001 The name by the way is Tcl/Tk's 4.2 with three digits for me to mess with. I hope Sun don't get through more than 100 revisions so two sub-version digits will be enough for them. I will subsume Sun's 'patch' stuff (e.g. '3' in 4.2p2) into my digits as we have tended to be 'ahead' of them on some fixes and behind on others so we don't map exactly at that level. For my digits I will use the 'even'=stable, 'odd'='experimental' scheme that linux uses: .0xx - inherently 'alpha' .1xx - experimental 'beta' .2xx - stable .3xx - experimental .4xx - stable Tk-804.031/Event/000755 001750 001750 00000000000 12150132176 014146 5ustar00eserteeserte000000 000000 Tk-804.031/Makefile.PL000755 001750 001750 00000013016 12146672671 015061 0ustar00eserteeserte000000 000000 # -*- cperl -*- use 5.007; use open IO => ':bytes'; use Cwd; use Config; no lib '.'; BEGIN { $IsWin32 = ($^O eq 'MSWin32' || $Config{'ccflags'} =~ /-D_?WIN32_?/); $xtra = ""; open(M, "Tk.pm") or die "Can't open Tk.pm for reading VERSION: $!"; while() { if (/\$Tk::VERSION\s+=\s+'([0-9._]+)'/) { $DISTVERSION = $1; ($VERSION = $DISTVERSION) =~ s{_}{}; last; } } close M; if (!defined $VERSION) { die "Can't find \$Tk::VERSION in Tk.pm"; } $win_arch = shift @ARGV if @ARGV and $ARGV[0] =~ /^(open32|pm|x|MSWin32)$/; require('fix_4_os2.pl'), OS2_massage() if $^O eq 'os2'; # XXX cygwin should preferably use the MSWin32 windows architecture, but # this is currently broken. $win_arch = $IsWin32 ? 'MSWin32' : 'x' # $win_arch = ($IsWin32 or $^O eq 'cygwin') ? 'MSWin32' : 'x' if not defined $win_arch; # Currently 'x', 'pm', 'open32', 'MSWin32' require "./myConfig"; use lib ($Tk::MMutil::dir=getcwd); } use Tk::MMutil; if ($IsWin32) { *MY::makeaperl = \&makeWin32perl; @libs = ('-lcomctl32 -limm32'); } else { my $plibs = $Config{'libs'}; my $libs = "$xlib -lX11$xtra"; # Used to have -lpt in here as well. my @try = qw(-lsocket -lnsl -lm); push(@try,'-lc') if $^O =~ /svr4/i; my $lib; # perl needs sockets and math library too # so only include these if they made it through perl's Configure foreach $lib (@try) { $libs .= " $lib" if ($plibs =~ /$lib\b/); } @libs = ("$libs"); } my $dir = Tk::MMutil::find_subdir(); delete $dir->{'pTk'}; my $eumm_recent_enough = $ExtUtils::MakeMaker::VERSION >= 6.54; if (!$eumm_recent_enough) { *MY::dist_core = sub { <<'EOF'; dist : $(NOECHO) $(ECHO) "Sorry, use a newer EUMM!" EOF }; } Tk::MMutil::TkExtMakefile( 'VERSION' => $VERSION, 'EXE_FILES' => [qw(ptksh ptked gedi)], 'NAME' => 'Tk', 'DIR' => ['pTk',reverse(sort(keys %$dir))], 'DISTNAME' => "Tk", 'DISTVNAME'=> "Tk-$DISTVERSION", 'MYEXTLIB' => 'pTk/libpTk$(LIB_EXT)' . ($win_arch =~ /^(open32|pm)$/ ? ' pTk/dllInit$(LIB_EXT)' : ''), 'LIBS' => \@libs, 'OBJECT' => '$(O_FILES)', 'PREREQ_PM' => { 'Encode' => 0, 'Test::More' => 0, }, 'clean' => { FILES => 'pTk/tkConfig.h Tk/Config.pm' }, 'LICENSE' => 'unrestricted', ($eumm_recent_enough ? (META_ADD => { resources => { repository => 'http://github.com/eserte/perl-tk' } }) : ()), @macro ); sub MY::top_targets { my ($self) = @_; my $str = $self->MM::top_targets; $str =~ s/\bmanifypods\b/html/g; return $str; } sub MY::post_initialize { my ($self) = @_; my ($ret) = ''; my %files = (); my $dir = $self->catdir('$(INST_ARCHLIBDIR)','Tk'); my $name; foreach $name (grep /(%|\.q4|\.bck|\.old)$/,keys %{$self->{PM}}) { delete $self->{PM}->{$name}; } delete $self->{PM}->{'Tk/Config.pm'}; $self->{PM}->{'Tk/Config.pm'} = $self->catfile($dir,'Config.pm'); # $files{'typemap'} = 1; foreach $name ($self->lsdir(".")) { next if ($name =~ /^\./); next unless (-f $name); $files{$name} = 1 if ($name =~ /\.[tm]$/); $files{$name} = 1 if ($name =~ /\.def$/); } foreach $name (sort(@{$self->{H}},keys %files)) { $self->{PM}->{$name} = $self->catfile($dir,$name); } if ($IsWin32) { if ($Config{cc} =~ /^bcc/i) { $ret .= "\nRESFILES = pTk\\tk.res\n"; } else { push(@{$self->{'O_FILES'}}, ($Config{'cc'} =~ /gcc/i) ? 'pTk\\tkres$(OBJ_EXT)' : 'pTk\\tk.res'); } } if ($win_arch eq 'MSWin32' and $^O eq 'cygwin') { push(@{$self->{'O_FILES'}}, 'pTk/tkres$(OBJ_EXT)'); } $ret; } sub needs_Test { my $file = shift; local $_; unless (open(TFILE,"$file")) { warn "Cannot open $file:$!"; return 1; } my $code = 0; while () { last if ($code = /^\s*(use|require)\s+Test\b/); } close(TFILE); warn "Skipping test $file needs 'Test.pm':$_" if $code; return $code; } sub MY::test { my ($self,%attrib) = @_; my @tests = sort glob($self->catfile('t','*.t')); eval { require Test }; if ($@) { @tests = grep(!needs_Test($_),@tests); } $attrib{'TESTS'} = join(' ',@tests); # Temporarily remove sub-dirs from $self as we 'know' # there are no tests down there my $dir = delete $self->{'DIR'}; my @td; foreach my $sd (@$dir) { my @tests = sort glob($self->catfile($sd,'t','*.t')); if (@tests) { warn "Tests in $sd\n"; push(@td,$sd); } } if (@td) { $self->{DIR} = \@td; } my $str = $self->MM::test(%attrib); # Put sub-dirs back $self->{'DIR'} = $dir; return $str; } sub MY::test_via_harness { my($self, $perl, $tests) = @_; qq{\t$perl "-It" "-MTkTest" }. qq{"-e" "checked_test_harness('\$(TKDIR)/xt/skip_all.t', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n}; } sub MY::postamble { my $str = ' html : subdirs manifypods @cd pod && $(MAKE) html $(PASTHRU) config :: tkGlue.t tkGlue.m @$(NOOP) $(BASEEXT)$(OBJ_EXT) : tkGlue.h Makefile : myConfig tkGlue.t : tkGlue.h pTk/mkVFunc $(PERL) pTk/mkVFunc -t $(WINARCH) tkGlue.h tkGlue.m : tkGlue.h pTk/mkVFunc $(PERL) pTk/mkVFunc -m $(WINARCH) tkGlue.h $(MYEXTLIB) : config FORCE cd pTk && $(MAKE) DEFINE="$(DEFINE)" $(PASTHRU) perlmain.c : config Makefile pTk/tk.res : $(MYEXTLIB) basic : $(INST_DYNAMIC) pm_to_blib MANIFEST : MANIFEST.SKIP $(FIRST_MAKEFILE) $(MAKE) manifest '; $str =~ s/DEFINE=.*// if($^O eq 'cygwin'); $str; } { package MY; sub init_PM { my $self = shift; $self->SUPER::init_PM(@_); delete $self->{PM}->{"fix_4_os2.pl"}; } } Tk-804.031/TixGrid/000755 001750 001750 00000000000 12150132176 014437 5ustar00eserteeserte000000 000000 Tk-804.031/NBFrame/000755 001750 001750 00000000000 12150132176 014337 5ustar00eserteeserte000000 000000 Tk-804.031/README.ultrix000644 001750 001750 00000001532 11400162251 015266 0ustar00eserteeserte000000 000000 From owner-ptk@guest.WPI.EDU Wed Apr 10 00:03:47 1996 Return-Path: From: PVHP@LNS62.LNS.CORNELL.EDU () Date: Tue, 09 Apr 1996 19:00:12 -0500 (EST) Subject: Re: Compiling Tk-b9.01 under Ultrix 4.2 To: farhad@math.ku.dk Cc: ptk@guest.WPI.EDU Message-Id: <01I3CJJC43Q08X5ACP@LNS62.LNS.CORNELL.EDU> X-Vms-To: IN%"farhad@math.ku.dk" X-Vms-Cc: IN%"ptk@guest.WPI.EDU" Content-Type: TEXT/PLAIN; CHARSET=US-ASCII Sender: owner-ptk@guest.WPI.EDU Precedence: bulk I did use MakeMaker on ultrix to build tkperl. I changed the line in Makefile.PL that reads: 'LIBS' => ["$xlib -lX11 -lpt -lsocket -lnsl -lm"], to read: 'LIBS' => ["$xlib -lX11 -lpt -lsocket -lnsl -lm -ldnet"], as we had a newer X11 in /usr/local that needed the DECnet protocol linking. This was with Tk-b11 by the way. Peter Prymmer pvhp@lns62.lns.cornell.edu Tk-804.031/xt/000755 001750 001750 00000000000 12150132175 013517 5ustar00eserteeserte000000 000000 Tk-804.031/Scrollbar/000755 001750 001750 00000000000 12150132176 015010 5ustar00eserteeserte000000 000000 Tk-804.031/build000755 001750 001750 00000000366 11705121720 014115 0ustar00eserteeserte000000 000000 #!/usr/local/bin/perl -w use Config; my $make = $Config{'make'}; my @para; {local $ENV{'TKNOMAKEDEPEND'} = "1"; system("$^X","Makefile.PL","XFT=1")}; system($make,"clean"); system("$^X","Makefile.PL"); system($make,@ARGV); system($make,'test'); Tk-804.031/ptked000755 001750 001750 00000017432 11705121730 014130 0ustar00eserteeserte000000 000000 #!/usr/local/bin/perl -w use strict; use Socket; use IO::Socket; use Cwd; use Getopt::Long; use vars qw($VERSION $portfile); $VERSION = '4.030'; # sprintf '4.%03d', q$Revision: #29 $ =~ /\D(\d+)\s*$/; my %opt; INIT { my $home = $ENV{'HOME'} || $ENV{'HOMEDRIVE'}.$ENV{'HOMEPATH'}; $portfile = "$home/.ptkedsn"; my $port = $ENV{'PTKEDPORT'}; return if $^C; GetOptions(\%opt,qw(server! encoding=s geometry=s)); unless (defined $port) { if (open(SN,"$portfile")) { $port = ; close(SN); } } if (defined $port) { my $sock = IO::Socket::INET->new(PeerAddr => 'localhost', PeerPort => $port, Proto => 'tcp'); if ($sock) { binmode($sock); $sock->autoflush; foreach my $file (@ARGV) { unless (print $sock "$file\n") { die "Cannot print $file to socket:$!"; } print "Requested '$file'\n"; } $sock->close || die "Cannot close socket:$!"; exit(0); } else { warn "Cannot connect to server on $port:$!"; } } } use Tk; use Tk::DropSite qw(XDND Sun); use Tk::DragDrop qw(XDND Sun); use Tk::widgets qw(TextUndo Scrollbar Menu Dialog); # use Tk::ErrorDialog; { package Tk::TextUndoPtked; @Tk::TextUndoPtked::ISA = qw(Tk::TextUndo); Construct Tk::Widget 'TextUndoPtked'; sub Save { my $w = shift; $w->SUPER::Save(@_); $w->toplevel->title($w->FileName); } sub Load { my $w = shift; $w->SUPER::Load(@_); $w->toplevel->title($w->FileName); } sub MenuLabels { shift->SUPER::MenuLabels, 'Encoding' } sub Encoding { my ($w,$enc) = @_; if (@_ > 1) { $enc = $w->getEncoding($enc) unless ref($enc); $w->{ENCODING} = $enc; $enc = $enc->name; $w->{ENCODINGNAME} = $enc; $w->PerlIO_layers(":encoding($enc)"); } return $w->{ENCODING}; } sub EncodingMenuItems { my ($w) = @_; my @menu; my @encoding_defs = ( # use canonical encoding names for radiobutton value ['Unicode (UTF-8)', 'utf-8-strict'], ['Western (iso-8859-1)', 'iso-8859-1'], ['Western (Windows-1252)', 'cp1252'], ["Western with \x{20ac} (iso-8859-15)", 'iso-8859-15'], ['Central European (Windows-1250)', 'cp1250'], ); if (!grep { $_->[1] eq Tk::SystemEncoding()->name } @encoding_defs) { unshift @encoding_defs, ['System', Tk::SystemEncoding()->name]; } for my $encoding_def (@encoding_defs) { my($label, $encoding) = @$encoding_def; push @menu, [ radiobutton => $label, -command => [ $w, Encoding => $encoding ], -variable => \$w->{ENCODINGNAME}, -value => $encoding ]; } return [ @menu ]; } } my $top = MainWindow->new(); $top->geometry('+0+0'); if ($opt{'server'}) { my $sock = IO::Socket::INET->new(Listen => 5, Proto => 'tcp'); die "Cannot open listen socket:$!" unless defined $sock; binmode($sock); my $port = $sock->sockport; $ENV{'PTKEDPORT'} = $port; open(SN,">$portfile") || die "Cannot open $portfile:$!"; print SN $port; close(SN); print "Accepting connections on $port\n"; $top->fileevent($sock,'readable', sub { print "accepting $sock\n"; my $client = $sock->accept; if (defined $client) { binmode($client); print "Connection $client\n"; $top->fileevent($client,'readable',[\&EditRequest,$client]); } }); } Tk::Event::HandleSignals(); $SIG{'INT'} = sub { $top->WmDeleteWindow }; $top->iconify; $top->optionAdd('*TextUndoPtked.Background' => '#fff5e1'); $top->fontCreate('ptked',-family => 'courier', -size => ($^O eq 'MSWin32' ? 11 : -12), -weight => 'normal', -slant => 'roman'); $top->optionAdd('*TextUndoPtked.Font' => 'ptked'); if (@ARGV) { foreach my $file (@ARGV) { Create_Edit($file); } } else { Create_Edit(); } sub EditRequest { my ($client) = @_; local $_; while (<$client>) { chomp($_); print "'$_'\n", Create_Edit($_); } warn "Odd $!" unless eof($client); $top->fileevent($client,'readable',''); print "Close $client\n"; $client->close; } MainLoop; unlink("$portfile"); exit(0); sub Create_Edit { my $path = shift; my $ed = $top->Toplevel(-title => $path); $ed->geometry($opt{geometry}) if $opt{geometry}; $ed->withdraw; $top->{'Edits'}++; $ed->OnDestroy([\&RemoveEdit,$top]); my $t = $ed->Scrolled('TextUndoPtked', -wrap => 'none', -scrollbars => 'se', # both required till optional fixed! ); $t->pack(-expand => 1, -fill => 'both'); $t = $t->Subwidget('scrolled'); $t->Encoding($opt{encoding} || Tk::SystemEncoding()->name); my $menu = $t->menu; $menu->cascade(-label => '~Help', -menuitems => [ [Button => '~About...', -command => [\&About,$ed]], ]); $ed->configure(-menu => $menu); my $dd = $t->DragDrop(-event => ''); $t->bind(ref($t),'',\&Ouch); $t->bind(ref($t),'',\&Ouch); $t->bind(ref($t),'',\&Ouch); $dd->configure(-startcommand => sub { return 1 unless (eval { $t->tagNextrange(sel => '1.0','end')}); $dd->configure(-text => $t->get('sel.first','sel.last')); }); $t->DropSite(-motioncommand => sub { my ($x,$y) = @_; $t->markSet(insert => "\@$x,$y"); }, -dropcommand => [\&HandleDrop,$t], ); $ed->protocol('WM_DELETE_WINDOW',[ConfirmExit => $t]); $t->bind('',\&DoFind); $ed->idletasks; if (defined $path && -e $path) { $t->Load($path); } else { $t->FileName($path); } $ed->deiconify; $t->update; $t->focus; } sub Ouch { warn join(',','Ouch',@_); } sub RemoveEdit { my $top = shift; if (--$top->{'Edits'} == 0) { $top->destroy unless $opt{'s'}; } } sub HandleDrop {my ($t,$seln,$x,$y) = @_; # warn join(',',Drop => @_); my $string; Tk::catch { $string = $t->SelectionGet(-selection => $seln,'FILE_NAME') }; if ($@) { Tk::catch { $string = $t->SelectionGet(-selection => $seln) }; if ($@) { my @targets = $t->SelectionGet(-selection => $seln, 'TARGETS'); $t->messageBox(-text => "Targets : ".join(' ',@targets)); } else { $t->markSet(insert => "\@$x,$y"); $t->insert(insert => $string); } } else { Create_Edit($string); } } my $str; sub DoFind { my $t = shift; $str = shift if (@_); my $posn = $t->index('insert+1c'); $t->tag('remove','sel','1.0','end'); local $_; while ($t->compare($posn,'<','end')) { my ($line,$col) = split(/\./,$posn); $_ = $t->get("$line.0","$posn lineend"); pos($_) = $col; if (/\G(.*)$str/g) { $col += length($1); $posn = "$line.$col"; $t->SetCursor($posn); $t->tag('add','sel',$posn,"$line.".pos($_)); $t->focus; return; } $posn = $t->index("$posn lineend + 1c"); } } sub AskFind { my ($t) = @_; unless (exists $t->{'AskFind'}) { my $d = $t->{'AskFind'} = $t->Toplevel(-popover => 'cursor', -popanchor => 'nw'); $d->title('Find...'); $d->withdraw; $d->transient($t->toplevel); my $e = $d->Entry->pack; $e->bind('', sub { $d->withdraw; DoFind($t,$e->get); }); $d->protocol(WM_DELETE_WINDOW =>[withdraw => $d]); } $t->{'AskFind'}->Popup; $t->update; $t->{'AskFind'}->focusNext; } sub About { my $mw = shift; $mw->Dialog(-text => <<"END",-popover => $mw)->Show; $0 version $VERSION perl$]/Tk$Tk::VERSION Copyright © 1995-2004 Nick Ing-Simmons. All rights reserved. This package is free software; you can redistribute it and/or modify it under the same terms as Perl itself. END } __END__ =head1 NAME ptked - an editor in Perl/Tk =head1 SYNOPSIS S< >B [-server] [-encoding I] [-geometry I] [I] =head1 DESCRIPTION B is a simple text editor based on perl/Tk's TextUndo widget. =cut Tk-804.031/Contrib/000755 001750 001750 00000000000 12150132176 014465 5ustar00eserteeserte000000 000000 Tk-804.031/cleanup000755 001750 001750 00000000451 11400162223 014433 0ustar00eserteeserte000000 000000 #!/usr/local/bin/perl -w use File::Find; find(\&wanted,'.'); sub wanted { return unless -f $_; if ($_ eq 'core' || /(%|~|\.(bak|bck|old|undone|orig))$/) { warn "$File::Find::name\n"; chmod(0666,$_) unless -w _; unlink($_) || warn "Cannot delete $File::Find::name\n"; } } __END__ Tk-804.031/keyWords000755 001750 001750 00000002212 11400162251 014611 0ustar00eserteeserte000000 000000 #!/usr/local/bin/perl -w use File::Find; %words = (); open(KEY,"pTk/Methods.def") || die "Cannot open pTk/Methods.def:$!"; while () { if (/\(\("(.*)",NULL\)\)/) { my @words = split(/","/,$1); my $word; foreach $word (@words) { next if ($word =~ /^[A-Z]/); unless (exists $words{$word}) { $words{$word} = 1; } } } } close(KEY); $words = '('.join('|',keys %words).')'; sub match { while (/sub\s+\b(${words}[A-Za-z]+|[A-Za-z]+${words})\b/go) { unless (exists $word{$1}) { print STDERR "$1 '$2/$3'\n"; $word{$1} = [] } push(@{$word{$1}},"${File::Find::name}:$."); } return 0; } sub wanted { $File::Find::prune = 0; if (-T $_ && !/%$/) { if (/\.pm$/) { local $file = ($_); local ($_); open($file,"<$file") || die "Cannot open $file:$!"; while (<$file>) { last if &match; } close($file); } } elsif (-d $_) { $File::Find::prune = 1 if (/^(blib|Pod|HTML)$/); } } @ARGV = '.' unless (@ARGV); find(\&wanted,@ARGV); foreach (sort keys %word) { print "$_:",join(' ',@{$word{$_}}),"\n"; } Tk-804.031/config/000755 001750 001750 00000000000 12150132176 014332 5ustar00eserteeserte000000 000000 Tk-804.031/tkGlue.t000444 001750 001750 00000004470 12010401640 014476 0ustar00eserteeserte000000 000000 #ifdef _TKGLUE #ifndef Call_Tk VFUNC(int,Call_Tk,V_Call_Tk,_ANSI_ARGS_((Lang_CmdInfo *info,int argc, SV **args))) #endif /* #ifndef Call_Tk */ #ifndef EnterWidgetMethods VFUNC(void,EnterWidgetMethods,V_EnterWidgetMethods,_ANSI_ARGS_((char *package, ...))) #endif /* #ifndef EnterWidgetMethods */ #ifndef FindTkVarName VFUNC(SV *,FindTkVarName,V_FindTkVarName,_ANSI_ARGS_((CONST char *varName,int flags))) #endif /* #ifndef FindTkVarName */ #ifndef InterpHv VFUNC(HV *,InterpHv,V_InterpHv,_ANSI_ARGS_((Tcl_Interp *interp,int fatal))) #endif /* #ifndef InterpHv */ #ifndef Lang_TkCommand VFUNC(void,Lang_TkCommand,V_Lang_TkCommand,_ANSI_ARGS_((char *name, Tcl_ObjCmdProc *proc))) #endif /* #ifndef Lang_TkCommand */ #ifndef Lang_TkSubCommand VFUNC(void,Lang_TkSubCommand,V_Lang_TkSubCommand,_ANSI_ARGS_((char *name, Tcl_ObjCmdProc *proc))) #endif /* #ifndef Lang_TkSubCommand */ #ifndef MakeReference VFUNC(SV *,MakeReference,V_MakeReference,_ANSI_ARGS_((SV * sv))) #endif /* #ifndef MakeReference */ #ifndef ObjectRef VFUNC(SV *,ObjectRef,V_ObjectRef,_ANSI_ARGS_((Tcl_Interp *interp, char *path))) #endif /* #ifndef ObjectRef */ #ifndef SVtoFont VFUNC(Tk_Font,SVtoFont,V_SVtoFont,_ANSI_ARGS_((SV *win))) #endif /* #ifndef SVtoFont */ #ifndef SVtoHWND VFUNC(HWND,SVtoHWND,V_SVtoHWND,_ANSI_ARGS_((SV *win))) #endif /* #ifndef SVtoHWND */ #ifndef SVtoWindow VFUNC(Tk_Window,SVtoWindow,V_SVtoWindow,_ANSI_ARGS_((SV *win))) #endif /* #ifndef SVtoWindow */ #ifndef TkToMainWindow VFUNC(Tk_Window,TkToMainWindow,V_TkToMainWindow,_ANSI_ARGS_((Tk_Window tkwin))) #endif /* #ifndef TkToMainWindow */ #ifndef TkToWidget VFUNC(SV *,TkToWidget,V_TkToWidget,_ANSI_ARGS_((Tk_Window tkwin,Tcl_Interp **pinterp))) #endif /* #ifndef TkToWidget */ #ifndef WidgetRef VFUNC(SV *,WidgetRef,V_WidgetRef,_ANSI_ARGS_((Tcl_Interp *interp, char *path))) #endif /* #ifndef WidgetRef */ #ifndef WindowCommand VFUNC(Lang_CmdInfo *,WindowCommand,V_WindowCommand,_ANSI_ARGS_((SV *win,HV **hptr, int moan))) #endif /* #ifndef WindowCommand */ #ifndef XSTkCommand VFUNC(int,XSTkCommand,V_XSTkCommand,_ANSI_ARGS_((CV *cv, int mwcd, Tcl_ObjCmdProc *proc, int items, SV **args))) #endif /* #ifndef XSTkCommand */ #ifndef install_vtab VFUNC(void,install_vtab,V_install_vtab,_ANSI_ARGS_((char *name, void *table, size_t size))) #endif /* #ifndef install_vtab */ #endif /* _TKGLUE */ Tk-804.031/Listbox/000755 001750 001750 00000000000 12150132174 014507 5ustar00eserteeserte000000 000000 Tk-804.031/bin/000755 001750 001750 00000000000 12150132176 013635 5ustar00eserteeserte000000 000000 Tk-804.031/fix_4_os2.pl000644 001750 001750 00000002563 11400162251 015216 0ustar00eserteeserte000000 000000 sub OS2_massage { # Need to put before BEGIN if (@ARGV) { die <; die <; die < Message-Id: From: mgm@holos.com (Martha Armour) Subject: Yet Another SVR4 Update To: ptk@WPI.EDU Date: Thu, 27 Jul 1995 16:12:08 -0400 (EDT) Cc: perl5-porters@nicoh.com Reply-To: mgm@holos.com X-Mailer: ELM [version 2.4 PL24] Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Length: 3791 Sender: owner-ptk@WPI.EDU Precedence: bulk P-From: mgm@holos.com (Martha Armour) Tk-b5 is finally working on both of my SVR4 platforms. After much gnashing of my teeth and pulling of my hair, I turned my problems over to a co-worker. His trials, tribulations and successes follow: The following was written by Len Reed : I've been fooling with Tk on three platforms: (A) AT&T GIS (formerly NCR) SVR4. uname gives "4.0 3.0 3360,3430-R 386/486/MC" This is a 3430 Microchannel machine. It uses the "Metaware" compiler. (L) Linux (a.out executables), kernel version 1.2.5. Uses gcc. (M) Motorola 88k SVR4 Unix, uname gives "4.0 R40V4.2 m88k mc88100" This machine came from Motorola with gcc (named cc). I'm using perl5.001m and Tk-b5. (L) worked fine. Both SVR4 machines--(A) and (M)--built perl fine. I used the [svr4] hints: note that the ucb stuff was therefore included. Minor SVR4 troubles ------------------ Both SVR4 systems required changes to Tk-b5/pTk/tkPort.h due to conflicts between Tk-provided prototypes and the system headers. I removed tkPort.h's gettimeofday and TclOpen prototypes. (Since open() is defined as TclOpen, the TclOpen prototype conflicts the the system open() prototype: the latter uses ... for the 3rd parameter.) The (M) machine exhibited a weird problem generating position independent code. Perl detected that this was gcc and tried to use -fpic. That was pretty well ignored in the perl build. Then, the Tk build turned this into -fPIC. The -f was ignored, and -P became "run the preprocessor." I ended up forcing perl to use -kPIC, which worked fine for both perl and Tk. Major SVR4 troubles ------------------- Both SVR4 systems had trouble with dynamic linking. Specifically, they could not find XOpenDisplay(). This was traced to the dlopen semantics. The dlopen(3X) manual says that "objects loaded by a single ... dlopen may .. not directly reference symobls from objects loaded by a different dlopen." The Tk module could not find the Xwindows stuff. When I added -lX11 to the perl link command and rebuilt perl, the Xwindows library worked fine. Additional AT&T (NCR) troubles ------------------------------ The AT&T machine (A) had two additional problems, both of which were hell to find. Tk basic_demo script opens "/dev/tty" and the passes it to an event handler. On the AT&T machine, it appears that select (actually its poll at the kernel interface level) won't work if one of the descriptors is /dev/tty. It returned an error (ENXIO) and Tk went into a loop. No mouse or keyboard input was accepted. Interestingly, opening `tty`, which gave the name of the pseudo tty for my xterm, worked fine. I'm guessing that this is a bug in the /dev/tty driver. After fixing that, basic_demo (and other perl Tk scripts) worked fine on the console but not on other X servers. I discovered that XOpenDisplay() was hanging up on everything except the console. Even setting DISPLAY to something like "nosuchmachine:0" would lock it up. The fix was to remove -lnet from the perl link command. The /usr/lib/libnet.so library appears to contain something that really messes XOpenDisplay(): a trivial C program that did nothing but call XOpenDisplay() was the key to putting the blame on libnet.so. After taking -lnet out of perl's list of libraries, I found that Tk could not find strcasecmp, which oddly enough was in libnet.so. I then added -lresolv to perl's list--not to Tk's, mind you, for the same reason that -lX11 had to been in perl's list. Anyway, libresolv.so gave me strcasecmp. I dunno how much use any of this is to someone not on a GIS machine. Let me (lbr@holos.com) know if you'd like more info leading to easing installation on this GIS/NCR machine. --- End of Len's comments --- -- Martha G. Armour Holos Software, Inc. Atlanta, Georgia USA mgm@holos.com Tk-804.031/tkGlue.c000644 001750 001750 00000347114 12146672671 014514 0ustar00eserteeserte000000 000000 /* Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. */ #define PERL_NO_GET_CONTEXT #include #include #include #include #ifdef __CYGWIN__ # undef XS # define XS(name) void name(pTHXo_ CV* cv) #endif #define Tkgv_fullname(x,y,z) gv_fullname3(x,y,z) #include "tkGlue.def" #include "pTk/tkPort.h" #include "pTk/tkInt.h" #include "pTk/tix.h" /* for form */ #include "pTk/tkImgPhoto.h" #include "pTk/tkImgPhoto.m" #include "pTk/imgInt.h" #include "pTk/imgInt.m" #include "pTk/tkOption.h" #include "pTk/tkOption_f.h" #include "pTk/Lang_f.h" #include "pTk/Xlib.h" #include "pTk/tk_f.h" #include "pTk/tkInt_f.h" #include "pTk/Xlib_f.h" #include "pTk/tclDecls_f.h" #include "pTk/tkDecls_f.h" #include "pTk/tkIntDecls_f.h" #include "pTk/tkEvent.h" #include "pTk/tkEvent.m" #if defined(WIN32) || (defined(__WIN32__) && defined(__CYGWIN__)) #include "pTk/tkWin.h" #include "pTk/tkWinInt.h" #include "pTk/tkIntXlibDecls_f.h" #include "pTk/tkIntPlatDecls_f.h" #include "pTk/tkPlatDecls_f.h" #else # ifdef OS2 # include "pTk/tkOS2Int.h" # else # include "pTk/tkUnixInt.h" # endif #endif #include "tkGlue.h" #include "tkGlue_f.h" DECLARE_EVENT; /* #define DEBUG_REFCNT /* */ #ifdef WIN32 long DCcount = 0; void LangNoteDC(HDC dc,int inc) { #ifdef DEBUGGING DCcount += inc; #endif } void LangCheckDC(const char *file,int line) { #ifdef DEBUGGING if (DCcount) LangDebug("%s:%d DCcount %ld\n",file,line,DCcount); #endif } #else void LangCheckDC(const char *file,int line) { } #endif extern Tk_PhotoImageFormat imgFmtBMP; #if 0 extern Tk_PhotoImageFormat imgFmtGIF; #else extern Tk_PhotoImageFormat tkImgFmtGIF; #endif extern Tk_PhotoImageFormat imgFmtXBM; extern Tk_PhotoImageFormat imgFmtXPM; typedef struct { Lang_VarTraceProc *proc; ClientData clientData; Tcl_Interp *interp; char *part2; SV *sv; } Tk_TraceInfo; typedef struct { Tcl_Interp *interp; SV *cb; } GenericInfo; typedef struct Assoc_s { Tcl_InterpDeleteProc *proc; ClientData clientData; } Assoc_t; static int initialized = 0; static I32 ec = 0; static SV *my_watch; static char XEVENT_KEY[] = "_XEvent_"; static char GEOMETRY_KEY[] = "_ManageGeometry_"; static char CM_KEY[] = "_ClientMessage_"; static char ASSOC_KEY[] = "_AssocData_"; static char FONTS_KEY[] = "_Fonts_"; static char CMD_KEY[] = "_CmdInfo_"; #ifndef BASEEXT #define BASEEXT "Tk" #endif typedef XSdec((*XSptr)); static XSdec(XStoSubCmd); static XSdec(XStoDisplayof); static XSdec(XStoTk); static XSdec(XStoBind); static XSdec(XStoEvent); extern XSdec(XS_Tk__Widget_SelectionGet); extern XSdec(XS_Tk__Widget_ManageGeometry); extern XSdec(XS_Tk__MainWindow_Create); extern XSdec(XS_Tk__Interp_DESTROY); extern XSdec(XS_Tk__Widget_BindClientMessage); extern XSdec(XS_Tk__Widget_PassEvent); extern XSdec(XS_Tk_INIT); extern XSdec(XS_Tk_DoWhenIdle); extern XSdec(XS_Tk_CreateGenericHandler); #ifdef PERL_MG_UFUNC #define DECL_MG_UFUNC(name,a,b) PERL_MG_UFUNC(name,a,b) #else #define DECL_MG_UFUNC(name,a,b) I32 name(IV a, SV *b) #endif extern void LangPrint _((SV *sv)); static void handle_idle _((ClientData clientData)); static void LangCatArg _((SV * out, SV * sv, int refs)); static SV *NameFromCv _((CV * cv)); static AV *FindAv _((pTHX_ Tcl_Interp *interp, char *who, int create, char *key)); static HV *FindHv _((pTHX_ HV *interp, char *who, int create, char *key)); static SV *Blessed _((char *package, SV * sv)); static int PushObjCallbackArgs _((Tcl_Interp *interp, SV **svp,EventAndKeySym *obj)); static int Check_Eval _((Tcl_Interp *interp)); static int handle_generic _((ClientData clientData, XEvent * eventPtr)); static void HandleBgErrors _((ClientData clientData)); static void SetTclResult _((Tcl_Interp *interp,int count)); static int InfoFromArgs _((Lang_CmdInfo *info,Tcl_ObjCmdProc *proc,int mwcd, int items, SV **args)); static I32 InsertArg _((SV **mark,I32 posn,SV *sv)); extern Tk_Window TkToMainWindow _((Tk_Window tkwin)); static int isSwitch _((char *arg)); static void Lang_ClearErrorInfo _((Tcl_Interp *interp)); static void Lang_MaybeError _((Tcl_Interp *interp,int code,char *why)); static void Set_widget _((SV *widget)); static SV *tilde_magic _((SV *hv, SV *sv)); static SV *struct_sv _((void *ptr, STRLEN sz)); static int SelGetProc _((ClientData clientData, Tcl_Interp *interp, long *portion, int numItems, int format, Atom type, Tk_Window tkwin)); static void Perl_GeomRequest _((ClientData clientData,Tk_Window tkwin)); static void Perl_GeomLostSlave _((ClientData clientData, Tk_Window tkwin)); Tcl_ObjCmdProc *LangOptionCommand = (Tcl_ObjCmdProc *)Tk_OptionObjCmd; static GV *current_widget; static GV *current_event; static int Expire(int code) { return code; } #define EXPIRE(args) \ ( Tcl_SprintfResult args, Expire(TCL_ERROR) ) #ifdef DEBUG_TAINT #define do_watch() do { if (PL_tainting) taint_proper("tainted", __FUNCTION__); } while (0) #else extern void do_watch _((void)); void do_watch() { } #endif static void LangCatAv(pTHX_ SV *out, AV *av, int refs, char *bra) { int n = av_len(av) + 1; int i = 0; sv_catpvn(out, bra, 1); while (i < n) { SV **x = av_fetch(av, i, 0); LangCatArg(out, (x) ? (*x) : &PL_sv_undef, refs); if (++i < n) sv_catpv(out, ","); } sv_catpvn(out, bra+1, 1); } static void LangCatArg(out, sv, refs) SV *out; SV *sv; int refs; { dTHX; char buf[80]; if (sv) { STRLEN na; switch(SvTYPE(sv)) { case SVt_PVAV: LangCatAv(aTHX_ out, (AV *) sv, refs,"()"); break; case SVt_PVGV: {SV *tmp = newSVpv("", 0); Tkgv_fullname(tmp,(GV *) sv, Nullch); sv_catpv(out,"*"); sv_catpv(out,SvPV(tmp,na)); SvREFCNT_dec(tmp); } break; case SVt_PVCV: if (CvGV(sv)) { SV *tmp = newSVpv("", 0); Tkgv_fullname(tmp, CvGV(sv), Nullch); sv_catpv(out,"&"); sv_catpv(out,SvPV(tmp,na)); SvREFCNT_dec(tmp); break; } default: if (SvOK(sv)) { char *s = ""; if (SvROK(sv)) { if (SvTYPE(SvRV(sv)) == SVt_PVAV) LangCatAv(aTHX_ out, (AV *) SvRV(sv), refs,"[]"); else if (SvTYPE(SvRV(sv)) == SVt_PVHV) { SV *hv = SvRV(sv); sv_catpv(out,"{}"); if (refs) { sprintf(buf, "(%ld%s", (long) SvREFCNT(hv), SvTEMP(hv) ? "t)" : ")"); sv_catpv(out, buf); } } else { sv_catpv(out,"\\"); LangCatArg(out, SvRV(sv), refs); } } else { if (refs && !SvPOK(sv)) { sprintf(buf, "f=%08lX ", (unsigned long) SvFLAGS(sv)); sv_catpv(out, buf); } s = SvPV(sv, na); } sv_catpv(out, s); } else { sv_catpv(out, "undef"); } break; } } if (refs) { sprintf(buf, "(%ld%s", (long) SvREFCNT(sv), SvTEMP(sv) ? "t)" : ")"); sv_catpv(out, buf); } } int LangNull(sv) Tcl_Obj * sv; { STRLEN len = 0; if (!sv || !SvOK(sv) || (SvPOK(sv) && !SvCUR(sv))) return 1; return 0; } char * LangMergeString(argc, args) int argc; SV **args; { dTHX; SV *sv = newSVpv("", 0); STRLEN i = 0; STRLEN na; char *s; while (i < (STRLEN) argc) { LangCatArg(sv, args[i++], 0); if (i < (STRLEN) argc) sv_catpvn(sv, " ", 1); } SvPV(sv, i); s = strncpy(ckalloc(i + 1), SvPV(sv, na), i); s[i] = '\0'; SvREFCNT_dec(sv); return s; } void LangPrint(sv) SV *sv; { dTHX; static char *type_name[] = { "NULL", "IV", "NV", "RV", "PV", "PVIV", "PVNV", "PVMG", "PVBM", "PVLV", "PVAV", "PVHV", "PVCV", "PVGV", "PVFM", "PVIO" }; if (sv) { SV *tmp = newSVpv("", 0); int type = SvTYPE(sv); STRLEN na; LangCatArg(tmp, sv, 1); PerlIO_printf(PerlIO_stderr(), "0x%p %4s f=%08lx %s\n", sv, (type < 16) ? type_name[type] : "?", (unsigned long) SvFLAGS(sv), SvPV(tmp, na)); SvREFCNT_dec(tmp); } else { PerlIO_printf(PerlIO_stderr(), "0x%p <= SVt_PVAV) { if (!SvROK(sv) || SvTYPE(SvRV(sv)) != type) { Tcl_Panic("%s not a %u reference %s", key, type, SvPV_nolen(sv)); } else { sv = SvRV(sv); } } if (create < 0) { SvREFCNT_inc((SV *) sv); hv_delete(hv, key, len, G_DISCARD); } return sv; } else Tcl_Panic("%s exists but can't be fetched", key); } else if (create > 0) { SV *sv = (*createProc)(aTHX); if (sv) { TagIt(sv,key); if (type >= SVt_PVAV) { hv_store(hv, key, len, MakeReference(sv), 0); } else hv_store(hv, key, len, sv, 0); } return sv; } } return NULL; } static SV * createHV(pTHX) { return (SV *) newHV(); } static HV * FindHv(pTHX_ HV *hv, char *who, int create, char *key) { return (HV *) FindXv(aTHX_ hv, who, create, key, SVt_PVHV, createHV); } static SV * createAV(pTHX) { return (SV *) newAV(); } static AV * FindAv(pTHX_ HV *hv, char *who, int create, char *key) { return (AV *) FindXv(aTHX_ hv, who, create, key, SVt_PVAV, createAV); } static SV * createSV(pTHX) { return newSVsv(&PL_sv_undef); } static SV * FindSv(pTHX_ HV *hv, char *who, int create, char *key) { return FindXv(aTHX_ hv, who, create, key, SVt_NULL, createSV); } /* Result return handling Use the FindXv scheme to create an SV in the interp. */ Tcl_Obj * Tcl_GetObjResult(interp) Tcl_Interp *interp; { dTHX; return FindSv(aTHX_ interp, "Tcl_GetObjResult", 1, "_TK_RESULT_"); } void Tcl_ResetResult(interp) Tcl_Interp *interp; { dTHX; if (InterpHv(interp,0)) { /* We delete the entry in the interp. This means we are forever create/delete. Leaving an SV in the interp might be better, as might having Tcl_SetObjResult() which everything now uses just store the SV. */ SV *sv = FindSv(aTHX_ interp, "Tcl_ResetResult", -1, "_TK_RESULT_"); if (sv) { SvREFCNT_dec(sv); } } } void Tcl_SetObjResult(interp, sv) Tcl_Interp *interp; SV *sv; { dTHX; if (InterpHv(interp,0)) { SV *result = Tcl_GetObjResult(interp); if (result == sv) { /* Recent Tk does save = Tcl_GetObjResult(); Tcl_IncrRefCount(save); ... Tcl_SetObjResult(save); Tcl_DecrRefCount(save); So nothing more to do here. */ return; } else { Tcl_ResetResult(interp); SvSetMagicSV(Tcl_GetObjResult(interp), sv); } } /* normal coding in Tk is equivalent to Tcl_SetObjResult(interp,Tcl_NewXxxObj()); and then forget about the Tcl_Obj - i.e. ownership is handed to the interp. As we have taken a _copy_ we no longer need the original. */ Tcl_DecrRefCount(sv); } void Lang_SetBinaryResult(interp, string, len, freeProc) Tcl_Interp *interp; char *string; int len; Tcl_FreeProc *freeProc; { dTHX; do_watch(); if (string) { SV *sv = newSVpv(string, len); Tcl_SetObjResult(interp, sv); if (freeProc != TCL_STATIC && freeProc != TCL_VOLATILE) (*freeProc) (string); } else Tcl_ResetResult(interp); do_watch(); } void Tcl_SetResult(interp, string, freeProc) Tcl_Interp *interp; char *string; Tcl_FreeProc *freeProc; { STRLEN len = (string) ? strlen(string) : 0; Lang_SetBinaryResult(interp, string, len, freeProc); } void Tcl_CallWhenDeleted(interp, proc, clientData) Tcl_Interp *interp; Tcl_InterpDeleteProc *proc; ClientData clientData; { dTHX; HV *hv = InterpHv(interp,1); AV *av = FindAv(aTHX_ interp, "Tcl_CallWhenDeleted", 1, "_When_Deleted_"); av_push(av, newSViv(PTR2IV(proc))); av_push(av, newSViv(PTR2IV(clientData))); } XS(XS_Tk__Interp_DESTROY) { dXSARGS; Tcl_Interp *interp = (Tcl_Interp *) SvRV(ST(0)); #if 0 fprintf(stderr,"InterpDestroy %ld\n",SvREFCNT((SV *) interp)); #endif /* Tk_CheckHash((SV *)interp,NULL); */ hv_undef(interp); } static void DeleteInterp(char *cd) { Tcl_Interp *interp = (Tcl_Interp *) cd; dTHX; SV *exiting = FindSv(aTHX_ interp, "DeleteInterp", -1, "_TK_EXIT_"); AV *av = FindAv(aTHX_ interp, "DeleteInterp", -1, "_When_Deleted_"); HV *hv = FindHv(aTHX_ interp, "DeleteInterp", -1, ASSOC_KEY); if (av) { while (av_len(av) > 0) { SV *cd = av_pop(av); SV *pr = av_pop(av); Tcl_InterpDeleteProc *proc = INT2PTR(Tcl_InterpDeleteProc *, SvIV(pr)); ClientData clientData = INT2PTR(ClientData, SvIV(cd)); (*proc) (clientData, interp); SvREFCNT_dec(cd); SvREFCNT_dec(pr); } SvREFCNT_dec((SV *) av); } if (hv) {HE *he; /* Tk_CheckHash((SV *)hv,NULL); */ hv_iterinit(hv); while ((he = hv_iternext(hv))) { STRLEN sz; SV *val = hv_iterval(hv,he); Assoc_t *info = (Assoc_t *) SvPV(val,sz); if (sz != sizeof(*info)) croak("%s corrupted",ASSOC_KEY); if (info->proc) (*info->proc)(info->clientData, interp); } hv_undef(hv); } DecInterp(interp, "DeleteInterp"); if (exiting) { sv_2mortal(exiting); my_exit(SvIV(exiting)); } } int Tcl_InterpDeleted(Tcl_Interp *interp) { dTHX; SV *sv = FindSv(aTHX_ interp, "Tcl_InterpDeleted", 0, "_DELETED_"); if (sv) { return SvTRUE(sv); } return 0; } void Tcl_DeleteInterp(interp) Tcl_Interp *interp; { dTHX; SV *del = FindSv(aTHX_ interp, "Tcl_DeleteInterp", 1, "_DELETED_"); sv_setiv(del,1); Tcl_EventuallyFree((ClientData) interp, DeleteInterp); } /* * We just deleted the last window in the application. Delete * the TkMainInfo structure too and replace all of Tk's commands * with dummy commands that return errors (except don't replace * the "exit" command, since it may be needed for the application * to exit). */ void Lang_DeadMainWindow(interp,tkwin) Tcl_Interp *interp; Tk_Window tkwin; { dTHX; HV *hv = InterpHv(interp,1); HV *fonts = FindHv(aTHX_ interp, "Lang_DeadMainWindow", 0, FONTS_KEY); Display *dpy = Tk_Display(tkwin); STRLEN na; if (dpy) XSync(dpy,FALSE); if (0 && fonts) {HE *he; hv_iterinit(fonts); while ((he = hv_iternext(fonts))) { SV *val = hv_iterval(fonts,he); Lang_CmdInfo *info = WindowCommand(val,NULL,0); if (info && info->tkfont) { Tk_FreeFont(info->tkfont); info->tkfont = NULL; } } /* Tk_CheckHash((SV *)fonts,NULL); */ hv_undef(fonts); } sv_unmagic((SV *) hv, PERL_MAGIC_ext); Tcl_DeleteInterp(interp); } static SV * struct_sv(ptr,sz) void *ptr; STRLEN sz; { dTHX; SV *sv = (ptr) ? newSVpv((char *) ptr, sz) : newSV(sz); if (ptr) { SvREADONLY_on(sv); } else { Zero(SvPVX(sv),sz+1,char); SvCUR_set(sv,sz); SvPOK_only(sv); } return sv; } static int TkGlue_mgFree(pTHX_ SV *sv, MAGIC *mg) { STRLEN na; return 0; } MGVTBL TkGlue_vtab = { NULL, NULL, NULL, NULL, TkGlue_mgFree }; static SV * tilde_magic(hv,sv) SV *hv; SV *sv; { dTHX; MAGIC *mg; sv_magic(hv, sv, PERL_MAGIC_ext, NULL, 0); SvRMAGICAL_off(hv); mg = mg_find(hv, PERL_MAGIC_ext); if (mg->mg_obj != sv) abort(); mg->mg_virtual = &TkGlue_vtab; mg_magical(hv); return sv; } #define mSVPV(sv,na) (SvOK(sv) ? SvPV(sv,na) : "undef") void LangDumpVec(CONST char *who, int count, SV **data) { dTHX; int i; PerlIO_printf(PerlIO_stderr(), "%s (%d):\n", who, count); for (i = 0; i < count; i++) { SV *sv = data[i]; if (sv) { PerlIO_printf(PerlIO_stderr(), "%2d ", i); LangPrint(sv); sv_dump(sv); } } if (SvTRUE(get_sv("Tk::_AbortOnLangDump",0))) { abort(); } } void DumpStack(CONST char *who) { dTHX; do_watch(); LangDumpVec(who, PL_stack_sp - PL_stack_base, PL_stack_base + 1); } void LangSetString(sp, s) SV **sp; CONST char *s; { dTHX; SV *sv = *sp; do_watch(); if (!s) { /* tkOldConfig uses LangSetString when TK_CONFIG_NULL_OK is _NOT_ set we must set something. */ s = ""; } if (sv) { sv_setpv(sv, s); SvSETMAGIC(sv_maybe_utf8(sv)); return; } *sp = Tcl_NewStringObj(s, -1); } void LangSetDefault(sp, s) SV **sp; CONST char *s; { dTHX; SV *sv = *sp; do_watch(); if (sv) { if (!s || !*s || SvREADONLY(sv)) { Decrement(sv, "LangSetDefault"); } else { if (s && *s) { sv_setpv(sv, s); SvSETMAGIC(sv); return; } } } *sp = sv = (s && *s) ? TagIt(newSVpv(s, strlen(s)),"LangSetDefault") : &PL_sv_undef; } void LangSetObj(sp, arg) SV **sp; SV *arg; { dTHX; SV *sv = *sp; do_watch(); if (!arg) arg = &PL_sv_undef; if (SvTYPE(arg) == SVt_PVAV) arg = newRV_noinc(arg); if (sv && SvMAGICAL(sv)) { SvSetMagicSV(sv, arg); SvREFCNT_dec(arg); } else { *sp = arg; if (sv) SvREFCNT_dec(sv); } } static void Deprecated(char *what, char *file, int line) { LangDebug("%s:%d: %s is deprecated\n",file,line,what); } void LangOldSetArg(sp, arg, file, line) SV **sp; SV *arg; char *file; int line; { dTHX; Deprecated("LangSetArg",file,line); LangSetObj(sp,(arg) ? SvREFCNT_inc(arg) : arg); } /* This replaces LangSetArg(sp,LangVarArg(var)) which leaked RVs */ void LangSetVar(sp,sv) SV **sp; Var sv; { dTHX; if (sv) { SV *rv = newRV(sv); LangSetObj(sp,rv); } else LangSetObj(sp,NULL); } void LangSetInt(sp, v) SV **sp; int v; { dTHX; SV *sv = *sp; do_watch(); if (sv && sv != &PL_sv_undef) { sv_setiv(sv, v); SvSETMAGIC(sv); } else *sp = sv = newSViv(v); } void LangSetDouble(sp, v) SV **sp; double v; { dTHX; SV *sv = *sp; do_watch(); if (sv && sv != &PL_sv_undef) { sv_setnv(sv, v); SvSETMAGIC(sv); } else *sp = sv = newSVnv(v); } static void die_with_trace(SV *sv,char *msg) { dTHX; dSP; if (!sv) { sv = newSVpv("Tk",2); } ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv); XPUSHs(sv_2mortal(newSVpv(msg,0))); PUTBACK; perl_call_method("die_with_trace",G_VOID); FREETMPS; LEAVE; } Lang_CmdInfo * WindowCommand(sv, hv_ptr, need) SV *sv; HV **hv_ptr; int need; { dTHX; STRLEN na; char *msg = "not a Tk object"; if (SvROK(sv)) { HV *hash = (HV *) SvRV(sv); MAGIC *mg = mg_find((SV *) hash,PERL_MAGIC_ext); if (hv_ptr) *hv_ptr = hash; if (mg) { Lang_CmdInfo *info = (Lang_CmdInfo *) SvPV(mg->mg_obj,na); if (info) { if ((need & 1) && !info->interp) croak("%s is not a Tk object",SvPV(sv,na)); if ((need & 2) && !info->tkwin) croak("WindowCommand:%s is not a Tk Window",SvPV(sv,na)); if ((need & 4) && !info->image) croak("%s is not a Tk Image",SvPV(sv,na)); if ((need & 8) && !info->tkfont) croak("%s is not a Tk Font",SvPV(sv,na)); return info; } } } else msg = "not a reference"; if (need) /* Cannot always do this - after() does this a lot ! */ { die_with_trace(sv,msg); } return NULL; } Tk_Window SVtoWindow(sv) SV *sv; { Lang_CmdInfo *info = WindowCommand(sv, NULL, 2); if (info && info->tkwin) return info->tkwin; return NULL; } HWND SVtoHWND(sv) SV *sv; { Tk_Window tkwin = SVtoWindow(sv); if (tkwin) { #ifdef WIN32 Tk_MakeWindowExist(tkwin); return Tk_GetHWND(Tk_WindowId(tkwin)); #endif } return NULL; } void #ifdef STANDARD_C Tcl_SprintfResult(Tcl_Interp * interp, char *fmt,...) #else Tcl_SprintfResult(interp, fmt, va_alist) Tcl_Interp *interp; char *fmt; va_dcl #endif { dTHX; SV *sv = newSVpv("",0); va_list ap; #ifdef I_STDARG va_start(ap, fmt); #else va_start(ap); #endif sv_vsetpvfn(sv, fmt, strlen(fmt), &ap, Null(SV**), 0, NULL); Tcl_SetObjResult(interp, sv); va_end(ap); } #ifdef STANDARD_C void Tcl_IntResults _ANSI_ARGS_((Tcl_Interp * interp, int count, int append,...)) #else /*VARARGS0 */ void Tcl_IntResults(interp, count, append, va_alist) Tcl_Interp *interp; int count; int append; va_dcl #endif { dTHX; va_list ap; Tcl_Obj *result; #ifdef I_STDARG va_start(ap, append); #else va_start(ap); #endif if (!append) { Tcl_ResetResult(interp); } result = Tcl_GetObjResult(interp); if (count == 1 && !append) abort(); while (count--) { int value = va_arg(ap, int); Tcl_Obj *vObj = Tcl_NewIntObj(value); Tcl_ListObjAppendElement(interp,result,vObj); } va_end(ap); } #ifdef STANDARD_C void Tcl_DoubleResults _ANSI_ARGS_((Tcl_Interp * interp, int count, int append,...)) #else void Tcl_DoubleResults(interp, count, append, va_alist) Tcl_Interp *interp; int count; int append; va_dcl #endif { dTHX; va_list ap; Tcl_Obj *result; #ifdef I_STDARG va_start(ap, append); #else va_start(ap); #endif if (!append) Tcl_ResetResult(interp); result = Tcl_GetObjResult(interp); if (!count) { LangDebug("%s - No Results\n",__FUNCTION__); abort(); Tcl_Panic("No results"); } while (count--) { double value = va_arg(ap, double); Tcl_ListObjAppendElement(interp,result,Tcl_NewDoubleObj(value)); } va_end(ap); } #ifdef STANDARD_C void Tcl_AppendResult _ANSI_ARGS_((Tcl_Interp * interp,...)) #else void Tcl_AppendResult(interp, va_alist) Tcl_Interp *interp; va_dcl #endif { SV *result = Tcl_GetObjResult(interp); va_list ap; char *s; #ifdef I_STDARG va_start(ap, interp); #else va_start(ap); #endif while ((s = va_arg(ap, char *))) { Tcl_AppendStringsToObj(result,s, NULL); } va_end(ap); } SV * ObjectRef(interp, path) Tcl_Interp *interp; char *path; { dTHX; if (path) { HV *hv = InterpHv(interp,1); SV **x = hv_fetch(hv, path, strlen(path), 0); if (x) return *x; } return &PL_sv_undef; } SV * WidgetRef(interp, path) Tcl_Interp *interp; char *path; { dTHX; HV *hv = InterpHv(interp,1); SV **x = hv_fetch(hv, path, strlen(path), 0); if (x) { SV *w = *x; if (SvROK(w) && SvTYPE(SvRV(w)) == SVt_PVHV) return w; LangDumpVec(path,1,&w); abort(); } return &PL_sv_undef; } SV * TkToWidget(tkwin,pinterp) Tk_Window tkwin; Tcl_Interp **pinterp; { dTHX; Tcl_Interp *junk; if (!pinterp) pinterp = &junk; *pinterp = NULL; if (tkwin) { TkWindow *winPtr = (TkWindow *) tkwin; TkMainInfo *mainInfo = winPtr->mainPtr; if (mainInfo) { Tcl_Interp *interp = mainInfo->interp; if (interp) { *pinterp = interp; if (Tk_PathName(tkwin)) return WidgetRef(interp, Tk_PathName(tkwin)); } } } return &PL_sv_undef; } Tk_Window TkToMainWindow(tkwin) Tk_Window tkwin; { if (tkwin) { TkWindow *winPtr = (TkWindow *) tkwin; TkMainInfo *mainInfo = winPtr->mainPtr; if (mainInfo) { return (Tk_Window) mainInfo->winPtr; } } return NULL; } Tcl_Obj * LangWidgetObj(interp, tkwin) Tcl_Interp *interp; Tk_Window tkwin; { dTHX; return SvREFCNT_inc(TkToWidget(tkwin,NULL)); } Tcl_Obj * LangObjectObj(interp, name) Tcl_Interp *interp; char *name; { dTHX; return SvREFCNT_inc(ObjectRef(interp, name)); } Tk_Font SVtoFont(SV *sv) { dTHX; if (sv_isobject(sv) && SvPOK(SvRV(sv))) { Lang_CmdInfo *info = WindowCommand(sv, (HV **) &sv, 0); if (info) { if (!info->tkfont && info->interp) { Tk_Window tkwin = Tk_MainWindow(info->interp); if (tkwin) info->tkfont = Tk_GetFontFromObj(tkwin, sv); } if (info->tkfont) { STRLEN len; CONST char *s = Tk_NameOfFont(info->tkfont); if (strcmp(s,SvPV(sv,len)) != 0) { croak("Font %p name '%s' string '%s'",info->tkfont,s,SvPV(sv,len)); } } return info->tkfont; } } return NULL; } Tcl_Obj * LangFontObj(interp, tkfont, name) Tcl_Interp *interp; Tk_Font tkfont; char *name; { dTHX; HV *fonts = FindHv(aTHX_ interp, "LangFontArg", 1, FONTS_KEY); STRLEN na; SV *sv; SV **x; if (!name) name = (char *) Tk_NameOfFont(tkfont); x = hv_fetch(fonts, name, strlen(name), 0); if (x) { sv = *x; } else { Tk_Window tkwin = Tk_MainWindow(interp); Lang_CmdInfo info; SV *isv; sv = newSVpv(name,0); memset(&info,0,sizeof(info)); info.interp = interp; info.tkfont = tkfont; IncInterp(interp,name); isv = struct_sv(&info,sizeof(info)); tilde_magic(sv, isv); sv = Blessed("Tk::Font", MakeReference(sv)); hv_store(fonts, name, strlen(name), sv, 0); } return SvREFCNT_inc(sv); } void Font_DESTROY(SV *arg) { dTHX; STRLEN na; SV *sv; Lang_CmdInfo *info = WindowCommand(arg,(HV **) &sv,0); if (info) { if (info->interp) DecInterp(info->interp,SvPV(sv,na)); sv_unmagic(sv,PERL_MAGIC_ext); } } static void Lang_ClearErrorInfo(interp) Tcl_Interp *interp; { dTHX; AV *av = FindAv(aTHX_ interp, "Lang_ClearErrorInfo", -1, "_ErrorInfo_"); if (av) { SvREFCNT_dec((SV *) av); } } void Tcl_AddErrorInfo(interp, message) Tcl_Interp *interp; CONST char *message; { dTHX; if (InterpHv(interp,0)) { AV *av = FindAv(aTHX_ interp, "Tcl_AddErrorInfo", 1, "_ErrorInfo_"); SV *sv; while (isspace(UCHAR(*message))) message++; if (*message) av_push(av,newSVpv((char *)message,0)); } } static int Check_Eval(interp) Tcl_Interp *interp; { dTHX; SV *sv = ERRSV; if (FindSv(aTHX_ interp, "Check_Eval", 0, "_TK_EXIT_")) return TCL_BREAK; if (SvTRUE(sv)) { STRLEN len; char *s = SvPV(sv, len); if (!strncmp("_TK_EXIT_(",s,10)) { Tk_Window tkwin = Tk_MainWindow(interp); SV *sv = FindSv(aTHX_ interp, "Check_Eval", 1, "_TK_EXIT_"); char *e = strchr(s+=10,')'); sv_setpvn(sv,s,e-s); if (tkwin) Tk_DestroyWindow(tkwin); return TCL_BREAK; } else if (!strcmp("_TK_BREAK_\n",s)) { sv_setpv(sv,""); return TCL_BREAK; } else { SV *save = sv_2mortal(newSVsv(sv)); s = SvPV(save, len); #if 0 LangDebug("%s error:%.*s\n",__FUNCTION__,na,s); #endif if (!interp) croak("%s",s); Tcl_SetResult(interp, s, TCL_VOLATILE); sv_setpv(sv,""); return TCL_ERROR; } } return TCL_OK; } static void Restore_widget(pTHX_ void *arg) { SV *widget = (SV *) arg; SV * sv = GvSV(current_widget); SvSetMagicSV(sv,widget); SvREFCNT_dec(widget); #if 0 LangDumpVec("Restore Tk::widget",1,&sv); #endif } static void Set_widget(widget) SV *widget; { dTHX; if (!current_widget) current_widget = gv_fetchpv("Tk::widget",GV_ADD|GV_ADDWARN, SVt_PV); if (widget && SvROK(widget)) { SV * sv = GvSV(current_widget); /* We used to use save_item() here but that and other generic perl save routines make assumptions about REFCNT and magic which we don't obey. Our REFCNT may be high, and both old an new SVs may have '~' magic for Tcl_Obj internal stuff. */ #if 0 LangDumpVec("save Tk::widget",1,&sv); #endif save_destructor_x(Restore_widget,LangCopyArg(sv)); SvSetMagicSV(sv,widget); } } static void Set_event(SV *event) { dTHX; if (!current_event) current_event = gv_fetchpv("Tk::event",GV_ADD|GV_ADDWARN, SVt_PV); if (event && SvROK(event)) { SV * sv = GvSV(current_event); save_item(sv); SvSetMagicSV(sv,event); } } static int PushObjCallbackArgs(interp, svp ,obj) Tcl_Interp *interp; SV **svp; EventAndKeySym *obj; { SV *sv = *svp; dTHX; dSP; STRLEN na; if (SvTAINTED(sv)) { croak("Tainted callback %"SVf,sv); } if (1 && interp && !sv_isa(sv,"Tk::Callback") && !sv_isa(sv,"Tk::Ev")) { return EXPIRE((interp,"Not a Callback '%s'",SvPV(sv,na))); } else { if (SvROK(sv) && SvTYPE(SvRV(sv)) != SVt_PVCV) sv = SvRV(sv); } PUSHMARK(sp); if (SvTYPE(sv) == SVt_PVAV) { AV *av = (AV *) sv; int n = av_len(av) + 1; SV **x = av_fetch(av, 0, 0); if (n && x) { int i = 1; sv = *x; if (SvTAINTED(sv)) { croak("Callback slot 0 tainted %"SVf,sv); } /* FIXME: POE would like window passed to its callback objects Pending suggestion is: if ($object->can('_Tk_passWidget') && $object->_Tk_passWidget($widget) { proceed_as_non_object(); } */ if (!sv_isobject(sv)) { if (obj && obj->window) { XPUSHs(sv_mortalcopy(obj->window)); } } for (i = 1; i < n; i++) { x = av_fetch(av, i, 0); if (x) {SV *arg = *x; if (SvTAINTED(arg)) { croak("Callback slot %d tainted %"SVf,i,arg); } if (obj && sv_isa(arg,"Tk::Ev")) { SV *what = SvRV(arg); if (SvPOK(what)) {STRLEN len; char *s = SvPV(what,len); if (len == 1) { PUTBACK; arg = XEvent_Info(obj, s); SPAGAIN; } else {char *x; arg = sv_newmortal(); sv_setpv(arg,""); while ((x = strchr(s,'%'))) { if (x > s) sv_catpvn(arg,s,(unsigned) (x-s)); if (*++x) {SV *f = XEvent_Info(obj, x++); STRLEN len; char *p = SvPV(f,len); sv_catpvn(arg,p,len); } s = x; } sv_catpv(arg,s); } } else { switch(SvTYPE(what)) { case SVt_NULL: arg = &PL_sv_undef; break; case SVt_PVAV: { int code; PUTBACK; if ((code = PushObjCallbackArgs(interp,&arg,obj)) == TCL_OK) { int count = LangCallCallback(arg,G_ARRAY|G_EVAL); if ((code = Check_Eval(interp)) != TCL_OK) return code; SPAGAIN; arg = NULL; break; } else return code; } default: LangDumpVec("Ev",1,&arg); LangDumpVec(" ",1,&what); warn("Unexpected type %d %s",SvTYPE(what),SvPV(arg,na)); arg = sv_mortalcopy(arg); break; } } if (arg) { XPUSHs(arg); } } else XPUSHs(sv_mortalcopy(arg)); } else XPUSHs(&PL_sv_undef); } } else { if (interp) { return EXPIRE((interp,"No 0th element of %s", SvPV(sv, na))); } else sv = &PL_sv_undef; } } else { if (obj && obj->window) XPUSHs(sv_mortalcopy(obj->window)); } *svp = sv; PUTBACK; return TCL_OK; } static int PushCallbackArgs(interp, svp) Tcl_Interp *interp; SV **svp; { SV *sv = *svp; dTHX; dSP; if (0 && interp && !sv_isa(sv,"Tk::Callback") && !sv_isa(sv,"Tk::Ev")) { return EXPIRE((interp,"Not a Callback '%s'",SvPV_nolen(sv))); } LangPushCallbackArgs(svp); if (interp && (sv = *svp) == &PL_sv_undef) { return EXPIRE((interp,"No 0th element of %s", SvPV_nolen(sv))); } return TCL_OK; } static void SetTclResult(interp,count) Tcl_Interp *interp; int count; { dTHX; dSP; int offset = count; Tcl_ResetResult(interp); if (count) { Tcl_Obj *result = Tcl_GetObjResult(interp); SV **p = sp - count; if (count > 1) { while (count-- > 0) { Tcl_ListObjAppendElement(interp, result, newSVsv(*++p)); } } else { SvSetMagicSV(result,p[1]); } } sp -= offset; PUTBACK; } static void PushVarArgs(ap,argc) va_list ap; int argc; { dTHX; dSP; int i; char *fmt = va_arg(ap, char *); char *s = fmt; unsigned char ch = '\0'; int lng = 0; for (i = 0; i < argc; i++) { s = strchr(s, '%'); if (s) { ch = UCHAR(*++s); lng = 0; while (isdigit(ch) || ch == '.' || ch == '-' || ch == '+') ch = *++s; if (ch == 'l') { lng = 1; ch = *++s; } switch (ch) { case 'u': case 'i': case 'd': {IV val = (lng) ? va_arg(ap, long) : va_arg(ap, int); XPUSHs(sv_2mortal(newSViv(val))); } break; case 'g': case 'e': case 'f': XPUSHs(sv_2mortal(newSVnv(va_arg(ap, double)))); break; case 's': { char *x = va_arg(ap, char *); if (x) XPUSHs(sv_2mortal(Tcl_NewStringObj(x, -1))); /* for UTF-8-ness */ else XPUSHs(&PL_sv_undef); } break; case '_': { SV *x = va_arg(ap, SV *); if (x) XPUSHs(sv_mortalcopy(x)); else XPUSHs(&PL_sv_undef); } break; case 'L': { Tcl_Obj *x = va_arg(ap, Tcl_Obj *); Tcl_Obj **argv; int argc; if (Tcl_ListObjGetElements(NULL,x,&argc,&argv) == TCL_OK) { int i; for (i=0; i < argc; i++) { XPUSHs(sv_mortalcopy((SV *) (argv[i]))); } } } break; default: croak("Unimplemented format char '%c' in '%s'", ch, fmt); break; } } else croak("Not enough %%s (need %d) in '%s'", argc, fmt); } if (strchr(s,'%')) { croak("Too many %%s (need %d) in '%s'", argc, fmt); } PUTBACK; } #ifdef STANDARD_C int LangDoCallback _ANSI_ARGS_((Tcl_Interp * interp, LangCallback * sv, int result, int argc,...)) #else int LangDoCallback(interp, sv, result, argc, va_alist) Tcl_Interp *interp; SV *sv; int result; int argc; va_dcl #endif { STRLEN na; static int flags[3] = { G_DISCARD, G_SCALAR, G_ARRAY }; int count = 0; int code; SV *cb = sv; dTHX; ENTER; SAVETMPS; if (interp) { Tcl_ResetResult(interp); Lang_ClearErrorInfo(interp); } code = PushCallbackArgs(interp,&sv); if (code != TCL_OK) return code; if (argc) { va_list ap; #ifdef I_STDARG va_start(ap, argc); #else va_start(ap); #endif PushVarArgs(ap,argc); va_end(ap); } count = LangCallCallback(sv, flags[result] | G_EVAL); if (interp && result) SetTclResult(interp,count); FREETMPS; LEAVE; count = Check_Eval(interp); if (count == TCL_ERROR && interp) { SV *tmp = newSVpv("", 0); LangCatArg(tmp,cb,0); Tcl_AddErrorInfo(interp,SvPV(tmp,na)); SvREFCNT_dec(tmp); } return count; } static void HandleBgErrors(clientData) ClientData clientData; { dTHX; Tcl_Interp *interp = (Tcl_Interp *) clientData; AV *pend = FindAv(aTHX_ interp, "HandleBgErrors", 0, "_PendingErrors_"); ENTER; SAVETMPS; TAINT_NOT; if (pend) { Set_widget( WidgetRef(interp,".")); while (av_len(pend) >= 0) { SV *sv = av_shift(pend); if (sv && SvOK(sv)) { int result = PushCallbackArgs(interp,&sv); if (result == TCL_OK) { LangCallCallback(sv, G_DISCARD | G_EVAL); result = Check_Eval(interp); } if (result == TCL_BREAK) break; else if (result == TCL_ERROR) { warn("Background Error: %s",Tcl_GetStringResult(interp)); } } } av_clear(pend); } FREETMPS; LEAVE; Tcl_ResetResult(interp); DecInterp(interp,"HandleBgErrors"); } void Tcl_BackgroundError(interp) Tcl_Interp *interp; { dTHX; int old_taint = PL_tainted; TAINT_NOT; #if 0 warn(__FUNCTION__); #endif if (InterpHv(interp,0)) { AV *pend = FindAv(aTHX_ interp, "Tcl_BackgroundError", 1, "_PendingErrors_"); AV *av = FindAv(aTHX_ interp, "Tcl_BackgroundError", -1, "_ErrorInfo_"); SV *obj = WidgetRef(interp,"."); if (obj && SvROK(obj)) obj = SvREFCNT_inc(obj); else obj = newSVpv(BASEEXT,0); if (!av) { av = newAV(); TagIt((SV *) av, "Tcl_BackgroundError"); } av_unshift(av,3); av_store(av, 0, newSVpv("Tk::Error",0)); av_store(av, 1, obj); av_store(av, 2, newSVpv(Tcl_GetStringResult(interp),0)); av_push( pend, LangMakeCallback(MakeReference((SV *) av))); if (av_len(pend) <= 0) { /* 1st one - setup callback */ IncInterp(interp,"Tk_BackgroundError"); Tcl_DoWhenIdle(HandleBgErrors, (ClientData) interp); } Tcl_ResetResult(interp); } TAINT_IF(old_taint); } static void Lang_MaybeError(interp,code,why) Tcl_Interp *interp; int code; char *why; { if (code != TCL_OK) { Tcl_AddErrorInfo(interp,why); Tcl_BackgroundError(interp); } else Lang_ClearErrorInfo(interp); } void ClearErrorInfo(win) SV *win; {Lang_CmdInfo *info = WindowCommand(win,NULL,1); Lang_ClearErrorInfo(info->interp); } static int Return_Object(int items, int offset, Tcl_Obj *sv) { dTHX; int gimme = GIMME_V; int count = 0; int i; SV **objv = NULL; SV **args = NULL; /* Get stack as it is now */ dSP; switch(gimme) { case G_VOID : count = 0; objv = NULL; break; case G_ARRAY: if (!SvOK(sv)) { count = 0; break; } else if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV && !SvMAGICAL(sv) && !sv_isobject(sv)) { Tcl_ListObjGetElements(NULL,sv,&count,&objv); break; } else { /* warn("Special obj in list context"); */ } default: count = 1; objv = &sv; #if 0 /* Breaks Canvas group members return */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV && !sv_isobject(sv)) { if (av_len((AV *)SvRV(sv)) == 0) { die_with_trace(NULL,"One element array in scalar context"); objv = av_fetch((AV *)SvRV(sv),0,0); } } #endif break; } SPAGAIN; if (count > items) { EXTEND(sp, (count - items)); } /* Now move 'args' to 0'th arg position in current stack */ args = sp + offset; for (i = count-1; i >= 0; i--) { args[i] = sv_mortalcopy(objv[i]); } /* Copy stack pointer back to global */ PUTBACK; return count; } static int Return_Results(Tcl_Interp *interp,int items, int offset) { Tcl_Obj *result = Tcl_GetObjResult(interp); int count = Return_Object(items,offset,result); Tcl_ResetResult(interp); return count; } static void Lang_TaintCheck(char *s, int items, SV **args) { dTHX; if (PL_tainting) { int i; for (i=0; i < items; i++) { if (SvTAINTED(args[i])) croak("Tcl_Obj * %d to `%s' (%"SVf") is tainted",i,s,args[i]); } } } struct pTkCheckChain { struct pTkCheckChain *link; SV *sv; }; void Tk_CheckHash(SV *sv,struct pTkCheckChain *tail) { dTHX; struct pTkCheckChain chain; HE *he; HV *hv; SV **svp; if (SvROK(sv)) sv = SvRV(sv); chain.link = tail; chain.sv = sv; if (SvTYPE(sv) != SVt_PVHV) return; hv = (HV *) sv; hv_iterinit(hv); while ((he = hv_iternext(hv))) { SV *val = hv_iterval(hv,he); if (val) { if (SvREFCNT(val) <= 0) {I32 len; char *key = hv_iterkey(he,&len); LangDebug("%.*s has 0 REFCNT\n",(int) len, key); sv_dump((SV *)hv); abort(); } else { if (SvROK(val)) val = SvRV(val); if (SvTYPE((SV *) val) == SVt_PVHV /* && SvOBJECT(val) */) { struct pTkCheckChain *p = &chain; I32 len; while (p) { if (p->sv == val) {I32 len; char *key = hv_iterkey(he,&len); LangDebug("Check Loop %.*s %p - %p\n",(int) len, key, hv, val); goto skip; } p = p->link; } /* LangDebug("Check %p{%s}\n",hv,hv_iterkey(he,&len)); */ Tk_CheckHash(val,&chain); skip: /* do nothing */; } } } } } int Call_Tk(info, items, args) Lang_CmdInfo *info; int items; SV **args; { int count = 1; STRLEN na; if (info) { dTHX; dSP; SV *what = SvREFCNT_inc(args[0]); SV *exiting; Tcl_Interp *interp = info->interp; int old_taint = PL_tainted; IncInterp(interp,"Call_Tk"); PL_tainted = 0; do_watch(); Tcl_ResetResult(interp); if (info->Tk.proc || info->Tk.objProc) { int i; /* Must find offset of 0'th arg now in case stack moves as a result of the call */ int offset = args - sp; int code; SV **our_sp = sp; Tcl_ObjCmdProc *proc = info->Tk.objProc; ClientData cd = info->Tk.objClientData; if (!proc) { proc = (Tcl_ObjCmdProc *) (info->Tk.proc); cd = info->Tk.clientData; } if (PL_tainting) { Lang_TaintCheck(Tcl_GetString(args[0]),items, args); } for (i=0; i < items; i++) { if (SvPOK(args[i])) Tcl_GetString(args[i]); } Tcl_Preserve(interp); /* BEWARE if Tk code does a callback to perl and perl grows the stack then args that Tk code has will still point at old stack. Thus if Tk tests args[i] *after* the callback it will get junk. (Note it is only vector that is at risk, SVs themselves will stay put.) So we pre-emptively swap perl stack so any callbacks which grow their stack don't move our "args" */ ENTER; SAVETMPS; SPAGAIN; PUSHSTACK; PUTBACK; code = (*proc) (cd, interp, items, args); POPSTACK; SPAGAIN; FREETMPS; LEAVE; if (sp != our_sp) abort(); Tcl_Release(interp); /* info stucture may have been free'ed now ... */ #ifdef WIN32 if (DCcount) { warn("DCcount %ld for %s",DCcount, Tcl_GetString(what)); // LangDumpVec("DCcount",items,args); DCcount = 0; } #endif if ((exiting = FindSv(aTHX_ interp, "Check_Eval", 0, "_TK_EXIT_"))) { PL_tainted = old_taint; DecInterp(interp, "Call_Tk"); SvREFCNT_dec(what); TclpExit(SvIV(exiting)); } else if (code == TCL_OK) { count = Return_Results(interp,items,offset); } else if (code == TCL_BREAK) { PL_tainted = old_taint; DecInterp(interp, "Call_Tk"); SvREFCNT_dec(what); croak("_TK_BREAK_\n"); } else { SV *msg = sv_newmortal(); sv_setpv(msg,"Tk callback for "); sv_catpv(msg,Tcl_GetString(what)); Tcl_AddErrorInfo(interp, SvPV(msg,na)); sv_setpv(msg,Tcl_GetStringResult(interp)); PL_tainted = old_taint; DecInterp(interp, "Call_Tk"); SvREFCNT_dec(what); croak("%s",SvPV(msg,na)); } } else { /* call after DeleteWidget */ if (info->tkwin) croak("%s has been deleted",Tk_PathName(info->tkwin)); } PL_tainted = old_taint; DecInterp(interp, "Call_Tk"); SvREFCNT_dec(what); } else { /* Could be an "after" when mainwindow has been destroyed */ } do_watch(); return count; } static void InitVtabs(void) { dTHX; /* Called by Boot_Glue below, re-called in 5.004_50+ at start of run phase. * If we have been "Compiled" then module this code is defined in * will have been re-linked, so the 'static' above will be 0 again * which will cause us to re-set vtables with addresses where * we happen to be loaded now, as opposed to where we were loaded * at compile time. */ if (!initialized) { IMPORT_EVENT; install_vtab("LangVtab",LangVGet(),sizeof(LangVtab)); install_vtab("TcldeclsVtab",TcldeclsVGet(),sizeof(TcldeclsVtab)); install_vtab("TkVtab",TkVGet(),sizeof(TkVtab)); install_vtab("TkdeclsVtab",TkdeclsVGet(),sizeof(TkdeclsVtab)); install_vtab("TkglueVtab",TkglueVGet(),sizeof(TkglueVtab)); install_vtab("TkintVtab",TkintVGet(),sizeof(TkintVtab)); install_vtab("TkintdeclsVtab",TkintdeclsVGet(),sizeof(TkintdeclsVtab)); install_vtab("TkoptionVtab",TkoptionVGet(),sizeof(TkoptionVtab)); install_vtab("TkimgphotoVtab",TkimgphotoVGet(),sizeof(TkimgphotoVtab)); install_vtab("ImgintVtab",ImgintVGet(),sizeof(ImgintVtab)); #ifdef WIN32 install_vtab("TkintplatdeclsVtab",TkintplatdeclsVGet(),sizeof(TkintplatdeclsVtab)); install_vtab("TkplatdeclsVtab",TkplatdeclsVGet(),sizeof(TkplatdeclsVtab)); install_vtab("TkintxlibdeclsVtab",TkintxlibdeclsVGet(),sizeof(TkintxlibdeclsVtab)); #else install_vtab("XlibVtab",XlibVGet(),sizeof(XlibVtab)); #endif Boot_Tix(aTHX); } initialized++; } XS(XS_Tk__MainWindow_Create) { dXSARGS; STRLEN na; Tcl_Interp *interp = Tcl_CreateInterp(); SV **args = &ST(0); char *appName = SvPV(ST(1),na); int offset = args - sp; int code; if (!initialized) InitVtabs(); code = TkCreateFrame(NULL, interp, items, &ST(0), 1, appName); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "Tk::MainWindow::Create"); croak("%s",Tcl_GetStringResult(interp)); } #if !defined(WIN32) && !defined(__PM__) && !(defined(OS2) && defined(__WIN32__)) TkCreateXEventSource(); #endif TKXSRETURN(Return_Results(interp,items,offset)); } static int SelGetProc(clientData,interp,portion,numItems,format,type,tkwin) ClientData clientData; Tcl_Interp *interp; long *portion; int numItems; int format; Atom type; Tk_Window tkwin; { dTHX; Tcl_Obj *result = (Tcl_Obj *) clientData; char *p = (char *) portion; SV *sv = Nullsv; if (format == 8) { TkWindow *winPtr = (TkWindow *) tkwin; TkDisplay *dispPtr = winPtr->dispPtr; /* Whole can-of-worms here: Mozilla has various text/... targets with no charset data which are in some 16-bit Unicode UCS-2/utf-16 style for which this would be correct: format = 16; numItems /= 2; (It is a little-endian 16-bit on Linux-x86.) Note that the is_utf8_string test will _PASS_ for the 16-bit case with plain ASCII as '\0' is legitimate UTF-8 KDE's Konsole has text/plain;charset=xxxx charsets are mostly really 8-bit but also has ISO-10646-UCS-2 which is 16-bit with a leading BOM For KDE there is no real gain in using one of these as UTF8_STRING returns same information. The mozilla targets might be interesting. Bare is_utf8_string() test may be wrong as well as we may get partial characters ? */ if ((dispPtr->utf8Atom != None && type == dispPtr->utf8Atom) || is_utf8_string((U8 *) p, numItems)) { Tcl_AppendToObj(result, p, numItems); } else { const char *strType = Tk_GetAtomName(tkwin, type); /* Do NOT use NewStringObj on it that assumes UTF-8-ness and we have established it isn't */ sv = newSVpvn(p, numItems); #if 0 LangDebug("%s %d '%.*s'\n",__FUNCTION__,numItems,numItems,p); LangDumpVec(strType,1,&sv); abort(); #endif Tcl_ListObjAppendElement(interp,result,sv); } } else { if (type == Tk_InternAtom(tkwin,"TARGETS")) type = XA_ATOM; while (numItems-- > 0) { IV value = 0; sv = Nullsv; if (8 * sizeof(unsigned char) == format) { value = *((unsigned char *) p); } else if (8 * sizeof(unsigned short) == format) { value = *((unsigned short *) p); } else if (8 * sizeof(unsigned int) == format) { value = *((unsigned int *) p); } else if (8 * sizeof(unsigned long) == format) { value = *((unsigned long *) p); } else { return EXPIRE((interp, "No C type for format %d", format)); } p += (format / 8); if (type == XA_ATOM) { if (value) { sv = newSVpv(Tk_GetAtomName(tkwin,(Atom) value),0); sv_setiv(sv,value); SvPOK_on(sv); } } else sv = newSViv(value); if (sv) Tcl_ListObjAppendElement(interp,result,sv); } } return TCL_OK; } static int isSwitch(s) char *s; {int ch; if (*s++ != '-') return 0; if (!isalpha(UCHAR(*s))) return 0; while ((ch = UCHAR(*++s))) { if (!isalnum(ch) && ch != '_') return 0; } return 1; } XS(XS_Tk__Widget_SelectionGet) { dXSARGS; STRLEN na; int offset = &ST(0) - sp; Lang_CmdInfo *info = WindowCommand(ST(0), NULL, 3); TkWindow *winPtr = (TkWindow *) info->tkwin; TkDisplay *dispPtr = winPtr->dispPtr; Atom selection = XA_PRIMARY; Atom target = None; int i = 1; Tcl_Obj *result = NULL; int retval = TCL_ERROR; while (i < items) {STRLEN len; char *s = SvPV(ST(i),len); if (len && !isSwitch(s)) { target = Tk_InternAtom(info->tkwin,s); i += 1; } else if (len >= 2 && !strncmp(s,"-type",len)) { if (i+1 < items) target = Tk_InternAtom(info->tkwin,SvPV(ST(i+1),na)); i += 2; } else if (len >= 2 && !strncmp(s,"-selection",len)) { if (i+1 < items) selection = Tk_InternAtom(info->tkwin,SvPV(ST(i+1),na)); i += 2; } else croak("Bad option '%s'",s); } result = Tcl_NewObj(); if (target == None) { /* Caller did not specify a target Try UTF8_STRING and if that fails try STRING But if they _ask_ for STRING then target will be set so we don't come here and just go for STRING below. We could get TARGETS list and then only ask for UTF8_STRING if owner supports it. But that would still be two requests and involves either a direct call to XConvertSelection() which is at best faked on Win32, or poking about in list of strings returned for the atoms. The more sophisticated TARGETS approach might start to win if we want to try TEXT COMPOUND_TEXT text/plain and other legacy ways of passing non-ASCII. But it seems like most applications are doing UTF8_STRING these days. We do UTF8_STRING first as owner may advertise STRING but fail to return it if selection contains high characters, or it may return STRING with a lot of '?' or '#' or other "marker" for non-converted chars. In contrast UTF-8 gives then no excuses ;-) */ if (dispPtr->utf8Atom != None) { /* Try for UTF8_STRING */ retval = Tk_GetXSelection(info->interp, info->tkwin, selection, dispPtr->utf8Atom, SelGetProc, (ClientData) result); } target = XA_STRING; } if (retval != TCL_OK) { retval = Tk_GetXSelection(info->interp, info->tkwin, selection, target, SelGetProc, (ClientData) result); } if (retval != TCL_OK) { Tcl_DecrRefCount(result); croak("%s", Tcl_GetString(Tcl_GetObjResult(info->interp))); } retval = Return_Object(items,offset,result); Tcl_DecrRefCount(result); XSRETURN(retval); } static I32 InsertArg(mark,posn,sv) SV **mark; I32 posn; SV *sv; { dTHX; dSP; I32 items = sp - mark; MEXTEND(sp, 1); /* May not be room ? */ while (sp > mark + posn) /* Move all but one args up 1 */ { sp[1] = sp[0]; sp--; } mark[posn+1] = sv; sp = mark + (++items); PUTBACK; return items; } XS(XStoWidget) { dXSARGS; Lang_CmdInfo *info = WindowCommand(ST(0), NULL, 1); do_watch(); items = InsertArg(mark,1,XSANY.any_ptr); TKXSRETURN(Call_Tk(info, items, &ST(0))); } static SV * NameFromCv(cv) CV *cv; { dTHX; SV *sv = NULL; if (cv) { GV *gv = CvGV(cv); char *s = GvNAME(gv); STRLEN l = GvNAMELEN(gv); sv = sv_newmortal(); sv_setpvn(sv, s, l); #ifdef DEBUG_GLUE fprintf(stderr, "Recovered name '%s'\n", Tcl_GetString(sv)); #endif } else croak("No CV passed"); return sv; } Tk_Window Tk_MainWindow(interp) Tcl_Interp *interp; { dTHX; HV *hv = InterpHv(interp,0); if (hv) { MAGIC *mg = mg_find((SV *) hv, PERL_MAGIC_ext); if (mg) { return INT2PTR(Tk_Window, SvIV(mg->mg_obj)); } } return NULL; } static int InfoFromArgs(info,proc,mwcd,items,args) Lang_CmdInfo *info; Tcl_ObjCmdProc *proc; int mwcd; int items; SV **args; { dTHX; SV *fallback = NULL; int i; memset(info,0,sizeof(*info)); info->Tk.objProc = proc; for (i=0; i < items; i++) { SV *sv = args[i]; if (SvROK(sv) && sv_isobject(sv)) { Lang_CmdInfo *winfo = WindowCommand(sv,NULL,0); if (winfo && winfo->interp) { if (winfo->interp != info->interp) info->interp = winfo->interp; if (mwcd) { Tk_Window mw; if (winfo->tkwin) mw = TkToMainWindow(winfo->tkwin); else mw = Tk_MainWindow(winfo->interp); if (mw) { if ((ClientData) mw != info->Tk.objClientData) { if (info->Tk.objClientData) { PerlIO_printf(PerlIO_stderr(),"cmd %p/%p using %p/%p\n", info->Tk.objClientData,info->interp, mw, winfo->interp); } info->Tk.objClientData = (ClientData) mw; } } } return i; } } } fallback = perl_get_sv("Tk::_Interp",TRUE); if (!SvROK(fallback)) { Tcl_Interp *interp = Tcl_CreateInterp(); SV *sv = sv_2mortal(MakeReference((SV *) interp)); #if 0 Tcl_CallWhenDeleted(interp, TkEventCleanupProc, (ClientData) NULL); #endif SvSetMagicSV(fallback,sv); } info->interp = (Tcl_Interp *) SvRV(fallback); return -1; } static XS(XStoSubCmd) { dXSARGS; STRLEN na; Lang_CmdInfo info; SV *name = NameFromCv(cv); int posn = InfoFromArgs(&info,(Tcl_ObjCmdProc *) XSANY.any_ptr,1,items,&ST(0)); if (posn < 0) { #if 0 LangDumpVec(Tcl_GetString(name),items,&ST(0)); #endif die_with_trace(ST(0),"XStoSubCmd: Not a Tk Window"); } if (posn == 0) { /* Do arg re-ordering to covert grab/wm like calls from perl method call form to that expected by Tk 0 1 2 have [ win sub ?-opt? .... ] need [ cv sub ?-opt? win ... ] */ MEXTEND(sp, 1); /* May not be room ? */ while (sp > mark + 2) /* Move all but two args up 1 */ { if (SvPOK(*sp) && isSwitch(SvPV(*sp, na))) break; sp[1] = sp[0]; sp--; } sp[1] = mark[1]; /* Move object = window arg */ sp = mark + (++items); /* move sp past the lot */ PUTBACK; /* and reset the global */ } ST(0) = name; /* Fill in command name */ TKXSRETURN(Call_Tk(&info, items, &ST(0))); } static XS(XStoEvent) { dXSARGS; STRLEN na; Lang_CmdInfo info; SV *name = NameFromCv(cv); int posn = InfoFromArgs(&info,(Tcl_ObjCmdProc *) XSANY.any_ptr,1,items,&ST(0)); if (posn < 0) { croak("XStoEvent:%s is not a Tk Window",SvPV(ST(0),na)); } if (posn == 0) { if (SvPOK(mark[2]) && strcmp(SvPV(mark[2], na), "generate") == 0) { /* Do arg re-ordering to convert calls from perl method call form to that expected by Tk 0 1 2 have [ win sub ?-opt? .... ] need [ cv sub win ?-opt? ... ] */ MEXTEND(sp, 1); /* May not be room ? */ while (sp > mark + 2) /* Move all but two args up 1 */ { sp[1] = sp[0]; sp--; } sp[1] = mark[1]; /* Move object = window arg */ sp = mark + (++items); /* move sp past the lot */ PUTBACK; /* and reset the global */ } } ST(0) = name; /* Fill in command name */ TKXSRETURN(Call_Tk(&info, items, &ST(0))); } static XS(XStoAfterSub) { dXSARGS; STRLEN na; Lang_CmdInfo info; SV *name = NameFromCv(cv); int posn = InfoFromArgs(&info,(Tcl_ObjCmdProc *) XSANY.any_ptr,1,items,&ST(0)); if (posn != 0) { LangDumpVec(SvPV(name,na),items,&ST(0)); croak("Usage $widget->%s(...)",SvPV(name,na)); } /* Find a place for the widget arg after a possible subcommands */ posn = 1; if (posn < items && SvPOK(ST(posn)) && !isSwitch(SvPV(ST(posn),na))) posn++; items = InsertArg(mark,posn,ST(0)); ST(0) = name; /* Fill in command name */ Tcl_GetCommandInfo(info.interp,Tcl_GetString(name),&info.Tk); TKXSRETURN(Call_Tk(&info, items, &ST(0))); } static XS(XStoGrid) { dXSARGS; STRLEN na; Lang_CmdInfo info; SV *name = NameFromCv(cv); int posn = InfoFromArgs(&info,(Tcl_ObjCmdProc *) XSANY.any_ptr,1,items,&ST(0)); if (posn == 0 && 0) { /* Find a place for the widget arg after a possible subcommands */ posn = 1; if (posn < items && SvPOK(ST(posn)) && !isSwitch(SvPV(ST(posn),na))) posn++; items = InsertArg(mark,posn,ST(0)); ST(0) = name; /* Fill in command name */ } items = InsertArg(mark,0, name); #if 0 LangDumpVec("grid", items, &ST(0)); #endif TKXSRETURN(Call_Tk(&info, items, &ST(0))); } static XS(XStoDisplayof) { dXSARGS; STRLEN na; Lang_CmdInfo info; SV *name = NameFromCv(cv); int posn = InfoFromArgs(&info,(Tcl_ObjCmdProc *) XSANY.any_ptr,1,items,&ST(0)); if (posn != 0) { LangDumpVec(SvPV(name,na),items,&ST(0)); croak("Usage $widget->%s(...)",SvPV(name,na)); } posn = 1; if (posn < items && SvPOK(ST(posn)) && !isSwitch(SvPV(ST(posn),na))) posn++; items = InsertArg(mark,posn++,sv_2mortal(newSVpv("-displayof",0))); SPAGAIN; mark = sp-items; items = InsertArg(mark,posn,ST(0)); ST(0) = name; /* Fill in command name */ TKXSRETURN(Call_Tk(&info, items, &ST(0))); } static XS(XStoTk) { dXSARGS; STRLEN na; SV *name = NameFromCv(cv); Lang_CmdInfo info; int posn = InfoFromArgs(&info,(Tcl_ObjCmdProc *) XSANY.any_ptr,1,items,&ST(0)); if (posn < 0) { LangDumpVec(SvPV(name,na),items,&ST(0)); croak("Usage $widget->%s(...)",SvPV(name,na)); } if (items == 0 || !SvPOK(ST(0)) || strcmp(SvPV(ST(0),na),BASEEXT) != 0) { items = InsertArg(mark,0,name); } ST(0) = name; /* Fill in command name */ TKXSRETURN(Call_Tk(&info, items, &ST(0))); } static XS(XStoOption) { dXSARGS; STRLEN na; SV *name = NameFromCv(cv); Lang_CmdInfo info; int posn = InfoFromArgs(&info, LangOptionCommand, 1, items, &ST(0)); if (posn < 0) { LangDumpVec(SvPV(name,na),items,&ST(0)); croak("Usage $widget->%s(...)",SvPV(name,na)); } if (items > 1 && SvPOK(ST(1)) && !strcmp(SvPV(ST(1),na),"get")) { items = InsertArg(mark,2,ST(0)); } ST(0) = name; /* Fill in command name */ TKXSRETURN(Call_Tk(&info, items, &ST(0))); } static XS(XStoImage) { dXSARGS; STRLEN na; SV *name = NameFromCv(cv); Lang_CmdInfo info; int posn = InfoFromArgs(&info,(Tcl_ObjCmdProc *) XSANY.any_ptr,1,items,&ST(0)); if (posn < 0) { LangDumpVec(SvPV(name,na),items,&ST(0)); croak("Usage $widget->%s(...)",SvPV(name,na)); } if (items > 1 && SvPOK(ST(1))) { char *opt = SvPV(ST(1),na); if (strcmp(opt,"create") && strcmp(opt,"names") && strcmp(opt,"types")) { items = InsertArg(mark,2,ST(0)); } } ST(0) = name; /* Fill in command name */ #if 0 LangDumpVec("Image",items,&ST(0)); #endif TKXSRETURN(Call_Tk(&info, items, &ST(0))); } static XS(XStoFont) { dXSARGS; STRLEN na; SV *name = NameFromCv(cv); Lang_CmdInfo info; int posn = InfoFromArgs(&info,(Tcl_ObjCmdProc *) XSANY.any_ptr,1,items,&ST(0)); if (posn < 0) { LangDumpVec(SvPV(name,na),items,&ST(0)); croak("Usage $widget->%s(...)",SvPV(name,na)); } if (items > 1 && SvPOK(ST(1))) { char *opt = SvPV(ST(1),na); if (strcmp(opt,"create") && strcmp(opt,"names") && strcmp(opt,"families")) { /* FIXME: would be better to use hint from info rather than fact that object is not hash-based */ if (SvROK(ST(0)) && SvTYPE(SvRV(ST(0))) != SVt_PVHV) { items = InsertArg(mark,2,ST(0)); } else if (ST(2) == &PL_sv_undef) { #if 0 LangDumpVec("Font undef",items,&ST(0)); #endif croak("Cannot use undef as font object"); } } } ST(0) = name; /* Fill in command name */ #if 0 LangDumpVec("Font Post",items,&ST(0)); #endif TKXSRETURN(Call_Tk(&info, items, &ST(0))); } int XSTkCommand (CV *cv, int mwcd, Tcl_ObjCmdProc *proc, int items, SV **args) { dTHX; STRLEN na; Lang_CmdInfo info; SV *name = NameFromCv(cv); if (InfoFromArgs(&info,proc,mwcd,items,args) != 0) { croak("Usage $widget->%s(...)\n%s is not a Tk object", SvPV_nolen(name),SvPV_nolen(args[0])); } /* Having established a widget was passed in ST(0) overwrite with name of command Tk is expecting */ args[0] = name; /* Fill in command name */ if (1 || !mwcd) { char *s = Tcl_GetString(name); Tcl_GetCommandInfo(info.interp,s,&info.Tk); if (!proc && info.Tk.objProc) { proc = info.Tk.objProc; } CvXSUBANY(cv).any_ptr = proc; if (!info.Tk.objProc && !info.Tk.proc) { info.Tk.objProc = proc; Tcl_SetCommandInfo(info.interp,s,&info.Tk); } } return Call_Tk(&info, items, args); } static XS(XStoTclCmd) { dXSARGS; TKXSRETURN(XSTkCommand(cv,1,(Tcl_ObjCmdProc *) XSANY.any_ptr, items, &ST(0))); } static XS(XStoTclCmdNull) { dXSARGS; TKXSRETURN(XSTkCommand(cv,0,(Tcl_ObjCmdProc *) XSANY.any_ptr, items, &ST(0))); } static XS(XStoNoWindow) { dXSARGS; STRLEN na; Lang_CmdInfo info; SV *name = NameFromCv(cv); HV *cm; STRLEN sz; char *cmdName = SvPV(name,sz); SV **x ; InfoFromArgs(&info,(Tcl_ObjCmdProc *) XSANY.any_ptr,0,items,&ST(0)); cm = FindHv(aTHX_ info.interp, "XStoNoWindow", 0, CMD_KEY); Tcl_GetCommandInfo(info.interp,cmdName,&info.Tk); if (items > 0 && (sv_isobject(ST(0)) || !strcmp(SvPV(ST(0),na),BASEEXT))) ST(0) = name; /* Fill in command name */ else items = InsertArg(mark,0,name); TKXSRETURN(Call_Tk(&info, items, &ST(0))); } static CV * TkXSUB(const char *name,XSptr xs,Tcl_ObjCmdProc *proc) { dTHX; STRLEN na; SV *sv = newSVpv(BASEEXT,0); CV *cv; sv_catpv(sv,"::"); sv_catpv(sv,name); if (xs && proc) { cv = newXS(SvPV(sv,na),xs,__FILE__); CvXSUBANY(cv).any_ptr = (VOID *) proc; } else { cv = perl_get_cv(SvPV(sv,na),0); } SvREFCNT_dec(sv); return cv; } void Lang_TkCommand(name,proc) char *name; Tcl_ObjCmdProc *proc; { TkXSUB(name,XStoTclCmd,proc); } void Lang_TkSubCommand(name,proc) char *name; Tcl_ObjCmdProc *proc; { TkXSUB(name,XStoAfterSub,proc); } /* The bind command is handled specially, it must *always* be called with a widget object. And only the <> form of sequence is allowed so that the following forms of call can be spotted: $widget->bind(); $widget->bind('tag'); $widget->bind('<...>'); $widget->bind('tag','<...>'); $widget->bind('<...>',command); $widget->bind('tag','<...>',command); */ static XS(XStoBind) { dXSARGS; STRLEN na; Lang_CmdInfo info; SV *name = NameFromCv(cv); int posn = InfoFromArgs(&info,(Tcl_ObjCmdProc *) XSANY.any_ptr,1,items,&ST(0)); STRLEN len; if (posn < 0) { LangDumpVec(SvPV(name,na),items,&ST(0)); croak("Usage $widget->%s(...)",SvPV(name,na)); } if (items < 2 || *SvPV(ST(1),len) == '<') { /* Looks like $widget->bind([<..>]) * i.e. bind command to widget itself * Standard move up of all the args to make room for 'bind' * as argv[0] */ items = InsertArg(mark,0,name); } else { /* Looks like $widget->bind('tag',...) * simply overwrite 0'th argument with 'bind' */ ST(0) = name; /* Fill in command name */ #if 0 if (dowarn) { if (items == 4) { SV *sv = ST(3); if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { LangDumpVec("bind",items,&ST(0)); warn("Subreference for class binding"); } } } #endif } TKXSRETURN(Call_Tk(&info, items, &ST(0))); } void LangDeadWindow(interp, tkwin) Tcl_Interp *interp; Tk_Window tkwin; { dTHX; STRLEN na; HV *hv = InterpHv(interp,0); if (hv) { /* This is last hook before tkwin disapears - LangDeleteWidget has happened - bindings have happened */ char *cmdName = Tk_PathName(tkwin); STRLEN cmdLen = strlen(cmdName); SV *obj = hv_delete(hv, cmdName, cmdLen, G_SCALAR); if (obj && SvROK(obj) && SvTYPE(SvRV(obj)) == SVt_PVHV) { HV *hash = (HV *) SvRV(obj); MAGIC *mg = mg_find((SV *) hash,PERL_MAGIC_ext); /* Tk_CheckHash((SV *) hash, NULL); */ if (SvREFCNT(hash) < 1) { LangDebug("%s %s has REFCNT=%d\n",__FUNCTION__,cmdName,(int) SvREFCNT(hash)); sv_dump(obj); } if (mg) { Lang_CmdInfo *info = (Lang_CmdInfo *) SvPV_nolen(mg->mg_obj); if (info->interp != interp) Tcl_Panic("%s->interp=%p expected %p", cmdName, info->interp, interp); DecInterp(info->interp, cmdName); /* mg->mg_obj is SV holding the Lang_CmdInfo struct we have now finished with it */ SvREFCNT_dec(mg->mg_obj); sv_unmagic((SV *) hash,PERL_MAGIC_ext); } } } } int Tcl_DeleteCommandFromToken(interp, info) Tcl_Interp *interp; Tcl_Command info; { if (info) { if (info->Tk.deleteProc) { (*info->Tk.deleteProc) (info->Tk.deleteData); info->Tk.deleteProc = NULL; info->Tk.deleteData = NULL; } info->Tk.clientData = NULL; info->Tk.proc = NULL; info->Tk.objClientData = NULL; info->Tk.objProc = NULL; } return TCL_OK; } void Lang_DeleteWidget(interp, info) Tcl_Interp *interp; Tcl_Command info; { dTHX; Tk_Window tkwin = info->tkwin; char *cmdName = Tk_PathName(tkwin); SV *win = WidgetRef(interp, cmdName); /* This is first sign of disapearing widget, bindings are still to come. */ LangMethodCall(interp,win,"_Destroyed",0,0); Tcl_DeleteCommandFromToken(interp,info); if (win && SvOK(win)) { HV *hash = NULL; Lang_CmdInfo *info = WindowCommand(win,&hash,1); if (info->interp != interp) Tcl_Panic("%s->interp=%p expected %p", cmdName, info->interp, interp); if (hash) hv_delete(hash, XEVENT_KEY, strlen(XEVENT_KEY), G_DISCARD); /* Tk_CheckHash((SV *) hash, NULL); */ if (SvREFCNT(hash) < 2) { LangDebug("%s %s has REFCNT=%d",__FUNCTION__,cmdName,(int) SvREFCNT(hash)); } SvREFCNT_dec(hash); } } void Lang_DeleteObject(interp, info) Tcl_Interp *interp; Tcl_Command info; { dTHX; STRLEN na; char *cmdName = SvPV(info->image,na); if (info->interp != interp) Tcl_Panic("%s->interp=%p expected %p", cmdName, info->interp, interp); Tcl_DeleteCommandFromToken(interp, info); DecInterp(info->interp,cmdName); } void Lang_NewMainWindow(interp,tkwin) Tcl_Interp *interp; Tk_Window tkwin; { dTHX; tilde_magic((SV *) InterpHv(interp,1),newSViv(PTR2IV(tkwin))); } Tcl_Command Lang_CreateWidget(interp, tkwin, proc, clientData, deleteProc) Tcl_Interp *interp; Tk_Window tkwin; Tcl_ObjCmdProc *proc; ClientData clientData; Tcl_CmdDeleteProc *deleteProc; { dTHX; STRLEN na; HV *hv = InterpHv(interp,1); char *cmdName = (tkwin) ? Tk_PathName(tkwin) : "."; STRLEN cmdLen = strlen(cmdName); HV *hash = newHV(); SV *tmp; Lang_CmdInfo info; SV *sv; do_watch(); memset(&info,0,sizeof(info)); info.Tk.objProc = proc; info.Tk.deleteProc = deleteProc; info.Tk.objClientData = info.Tk.deleteData = clientData; info.interp = interp; info.tkwin = tkwin; info.image = NULL; sv = struct_sv(&info,sizeof(info)); /* Record the object in the main hash */ IncInterp(interp, cmdName); hv_store(hv, cmdName, cmdLen, newRV((SV *) hash), 0); /* At this point hash REFCNT should be 2, one for what is stored in interp and one representing Tk's use */ tilde_magic((SV *) hash, sv); return (Lang_CmdInfo *) SvPV(sv,na); } Tcl_Command Lang_CreateObject(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; char *cmdName; Tcl_ObjCmdProc *proc; ClientData clientData; Tcl_CmdDeleteProc *deleteProc; { dTHX; STRLEN na; HV *hv = InterpHv(interp,1); STRLEN cmdLen = strlen(cmdName); HV *hash = newHV(); SV *sv; Lang_CmdInfo info; do_watch(); memset(&info,0,sizeof(info)); info.Tk.objProc = proc; info.Tk.deleteProc = deleteProc; info.Tk.objClientData = info.Tk.deleteData = clientData; info.interp = interp; info.tkwin = NULL; info.image = newSVpv(cmdName,cmdLen); sv = struct_sv(&info,sizeof(info)); /* Record the object in the main hash */ IncInterp(interp, cmdName); hv_store(hv, cmdName, cmdLen, MakeReference((SV *) hash), 0); tilde_magic((SV *)hash, sv); return (Lang_CmdInfo *) SvPV(sv,na); } Tcl_Command Lang_CreateImage(interp, cmdName, proc, clientData, deleteProc, typePtr) Tcl_Interp *interp; char *cmdName; Tcl_ObjCmdProc *proc; ClientData clientData; Tcl_CmdDeleteProc *deleteProc; Tk_ImageType *typePtr; { return Lang_CreateObject(interp, cmdName, proc, clientData, deleteProc); } Tcl_Command Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; CONST char *cmdName; Tcl_ObjCmdProc *proc; ClientData clientData; Tcl_CmdDeleteProc *deleteProc; { Tk_Window mw = Tk_MainWindow(interp); if (cmdName[0] == '.') { Tk_Window tkwin; if (cmdName[1] == '\0') { tkwin = mw; } else { tkwin = Tk_NameToWindow(interp, (char *) cmdName, mw); } return Lang_CreateWidget(interp, tkwin, proc, clientData, deleteProc); } else { Tcl_CmdInfo info; CV *cv; char *kind = "NULL"; if (clientData) { kind = (clientData == (ClientData) mw) ? "mw" : "custom"; } memset(&info,0,sizeof(info)); info.objProc = proc; info.objClientData = clientData; info.deleteProc = deleteProc; if (!strcmp(cmdName,"menu")) { cmdName = "_menu"; } /* We cannot test sanity of clientData vs XStoXxxxx at this point as when 1st called XSs are still pointing a B::C friendly re-directors. Also CVs for "loaded" commands may not exist yet. */ #if 0 if ((cv = TkXSUB(cmdName,NULL,NULL))) { if (clientData) { if (clientData == (ClientData) mw) { if (CvXSUB(cv) == XStoTclCmdNull) { warn("Wrong xsub %s cd=%p (mw)",cmdName, clientData); CvXSUB(cv) = XStoTclCmd; } } else { if (CvXSUB(cv) == XStoTclCmd) { warn("Wrong xsub %s cd=%p",cmdName, clientData); CvXSUB(cv) = XStoTclCmdNull; } } } else { if (CvXSUB(cv) == XStoTclCmd) { warn("Wrong xsub %s cd=%p",cmdName, clientData); CvXSUB(cv) = XStoTclCmdNull; } } } else { warn("No cv for %s",cmdName); } #endif Tcl_SetCommandInfo(interp,cmdName,&info); if (deleteProc) { HV *hv = InterpHv(interp,1); Tcl_CallWhenDeleted(interp,(Tcl_InterpDeleteProc *)deleteProc,clientData); } } return NULL; } int Tcl_IsSafe(interp) Tcl_Interp *interp; { return 0; /* Is this interp in a 'safe' compartment - not yet implemented */ } int Tcl_HideCommand (Tcl_Interp *interp, CONST char *cmdName, CONST char *hiddenCmdName) { CV *cv = TkXSUB(cmdName,NULL,NULL); warn("Tcl_HideCommand %s => %s called",cmdName,hiddenCmdName); if (!cv) { return EXPIRE((interp,"Cannot find %s", cmdName)); } return TCL_OK; } int Tcl_SetCommandInfo(interp,cmdName,infoPtr) Tcl_Interp *interp; CONST char *cmdName; CONST Tcl_CmdInfo *infoPtr; { dTHX; HV *cm = FindHv(aTHX_ interp, "Tcl_SetCommandInfo", 1, CMD_KEY); hv_store(cm,cmdName,strlen(cmdName), struct_sv((char *) infoPtr,sizeof(*infoPtr)),0); return TCL_OK; } int Tcl_GetCommandInfo (Tcl_Interp *interp, CONST char *cmdName, Tcl_CmdInfo *infoPtr) { dTHX; HV *hv = InterpHv(interp,1); SV **svp = hv_fetch(hv,cmdName,strlen(cmdName),0); /* Widgets, images and named fonts get put in main hash */ if (svp && *svp) { Lang_CmdInfo *info = WindowCommand(*svp,NULL,0); *infoPtr = info->Tk; return 1; } /* widgets are special cased elsewhere */ else if (*cmdName != '.') { HV *cm = FindHv(aTHX_ interp, "Tcl_GetCommandInfo", 1, CMD_KEY); SV **svp = hv_fetch(cm,cmdName,strlen(cmdName),0); if (svp && *svp) { memcpy(infoPtr,SvPVX(*svp),sizeof(Tcl_CmdInfo)); return 1; } else if (0) { /* If we didn't find the info but this is supposed to be a known Tk builtin then something may have gone wrong but "after" seems to occur regularly */ CV *cv = TkXSUB(cmdName,NULL,NULL); if (cv) { LangDebug("No Tcl_GetCommandInfo for %s\n",cmdName); } } } return 0; } Tcl_Command Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_Interp *interp; CONST char *cmdName; Tcl_CmdProc *proc; ClientData clientData; Tcl_CmdDeleteProc *deleteProc; { return Tcl_CreateObjCommand(interp, cmdName, (Tcl_ObjCmdProc *) proc, clientData, deleteProc); } static SV *LangVar2 _((Tcl_Interp *interp, SV *sv, char *part2, int flags)); static SV * LangVar2(interp, sv, part2, store) Tcl_Interp *interp; SV *sv; char *part2; int store; { if (part2) { dTHX; if (SvTYPE(sv) == SVt_PVHV) {HV *hv = (HV *) sv; SV **x = hv_fetch(hv, part2, strlen(part2), store); if (x) return *x; } else { Tcl_Panic("two part %s not implemented", "Tcl_GetVar2"); } return NULL; } else return sv; } Tcl_Obj * Tcl_ObjGetVar2(interp, sv, part2, flags) Tcl_Interp *interp; SV *sv; SV *part2; int flags; { dTHX; if (sv) { if (SvPOK(sv)) { STRLEN len; char *s = SvPV(sv,len); if (len > 6 && !strncmp(s,"::tk::",6)) { sv = FindTkVarName(s+6,0); } } if (SvROK(sv) && SvTYPE(SvRV(sv)) != SVt_PVAV) { sv = SvRV(sv); } if (part2) { sv = LangVar2(interp, sv, Tcl_GetString(part2), 0); } } else { sv = newSV(0); } return sv; } Tcl_Obj * Tcl_ObjSetVar2(interp, sv, part2, newValue, flags) Tcl_Interp *interp; SV *sv; SV *part2; SV *newValue; int flags; { dTHX; if (SvROK(sv)) sv = SvRV(sv); if (part2) sv = LangVar2(interp, sv , Tcl_GetString(part2), 1); SvSetMagicSV(sv, newValue); return sv; } char * Tcl_SetVarArg(interp, sv, newValue, flags) Tcl_Interp *interp; SV *sv; Tcl_Obj * newValue; int flags; { dTHX; STRLEN na; if (!newValue) newValue = &PL_sv_undef; SvSetMagicSV(sv, newValue); return SvPV(sv, na); } int LangCmpOpt(opt,arg,len) CONST char *opt; CONST char *arg; size_t len; { int result = 0; if (!len) len = strlen(arg); if (*opt == '-') opt++; if (*arg == '-') { arg++; if (len) len--; } while (len--) {char ch = *arg++;; if ((result = *opt++ - ch) || !ch) break; } return result; } int LangCmpArg(a,b) CONST SV *a; CONST SV *b; { dTHX; STRLEN na; char *as; char *bs; if (a && SvGMAGICAL(a)) mg_get((SV *) a); if (b && SvGMAGICAL(b)) mg_get((SV *) b); as = (a && SvOK(a)) ? SvPV((SV *)a,na) : ""; bs = (b && SvOK(b)) ? SvPV((SV *)b,na) : ""; return strcmp(as,bs); } static I32 Perl_Value(pTHX_ IV ix, SV *sv) { Tk_TraceInfo *p = INT2PTR(Tk_TraceInfo *, ix); char *result; /* We are a "magic" set processor, whether we like it or not because this is the hook we use to get called. So we are (I think) supposed to look at "private" flags and set the public ones if appropriate. e.g. "chop" sets SvPOKp as a hint but not SvPOK presumably other operators set other private bits. Question are successive "magics" called in correct order? i.e. if we are tracing a tied variable should we call some magic list or be careful how we insert ourselves in the list? */ if (!SvPOK(sv) && SvPOKp(sv)) SvPOK_on(sv); if (!SvNOK(sv) && SvNOKp(sv)) SvNOK_on(sv); if (!SvIOK(sv) && SvIOKp(sv)) SvIOK_on(sv); return 0; } static void TraceExitHandler(ClientData clientData) { dTHX; Tk_TraceInfo *p = (Tk_TraceInfo *) clientData; char *result; ENTER; SvREFCNT_inc(p->sv); save_freesv(p->sv); result = (*p->proc) (p->clientData, p->interp, p->sv, p->part2, 0); if (result) Tcl_Panic("Tcl_VarTraceProc returned '%s'", result); LEAVE; } static DECL_MG_UFUNC(Perl_Trace, ix, sv) { Tk_TraceInfo *p = INT2PTR(Tk_TraceInfo *, ix); char *result; /* We are a "magic" set processor, whether we like it or not because this is the hook we use to get called. So we are (I think) supposed to look at "private" flags and set the public ones if appropriate. e.g. "chop" sets SvPOKp as a hint but not SvPOK presumably other operators set other private bits. Question are successive "magics" called in correct order? i.e. if we are tracing a tied variable should we call some magic list or be careful how we insert ourselves in the list? */ /* This seems to be wrong in at least one case --- see t/Trace.t and Message-ID: <3ef348b.0304240510.299e5519@posting.google.com> */ #if 0 if (!SvPOK(sv) && SvPOKp(sv)) SvPOK_on(sv); if (!SvNOK(sv) && SvNOKp(sv)) SvNOK_on(sv); if (!SvIOK(sv) && SvIOKp(sv)) SvIOK_on(sv); #endif ENTER; SvREFCNT_inc(sv); save_freesv(sv); result = (*p->proc) (p->clientData, p->interp, sv, p->part2, 0); if (result) Tcl_Panic("Tcl_VarTraceProc returned '%s'", result); LEAVE; return 0; } int Lang_TraceVar2(interp, sv, part2, flags, tkproc, clientData) Tcl_Interp *interp; Tcl_Obj * sv; char *part2; int flags; Lang_VarTraceProc *tkproc; ClientData clientData; { dTHX; Tk_TraceInfo *p; struct ufuncs *ufp; MAGIC **mgp; MAGIC *mg; MAGIC *mg_list; SV *exiting; int mgType = PERL_MAGIC_uvar; if (SvROK(sv)) sv = SvRV(sv); if (SvTHINKFIRST(sv)) { if (SvREADONLY(sv)) { return EXPIRE((interp, "Cannot trace readonly variable")); } } (void)SvUPGRADE(sv, SVt_PVMG); if (SvTYPE(sv) == SVt_PVAV) { mgType = PERL_MAGIC_ext; } /* * We can't use sv_magic() because it won't add in another magical struct * of type 'U' if there is already one there. We need multiple 'U' * magics hanging from one sv or else things like radiobuttons will * not work. That's because each radiobutton widget group needs to track * the same sv and update itself as necessary. */ New(601, p, 1, Tk_TraceInfo); p->proc = tkproc; p->clientData = clientData; p->interp = interp; p->part2 = part2; p->sv = sv; Tcl_CreateExitHandler(TraceExitHandler, (ClientData) p); /* We want to be last in the chain so that any other magic has been called first save the list so that this magic can be moved to the end */ mg_list = SvMAGIC(sv); SvMAGIC(sv) = NULL; /* Add 'U' magic to sv with all NULL args */ sv_magic(sv, 0, mgType, 0, 0); Newz(666, ufp, 1, struct ufuncs); ufp->uf_val = Perl_Value; ufp->uf_set = Perl_Trace; ufp->uf_index = PTR2IV(p); mg = SvMAGIC(sv); mg->mg_ptr = (char *) ufp; mg->mg_len = sizeof(struct ufuncs); /* put list back and add mg to end */ SvMAGIC(sv) = mg_list; mgp = &SvMAGIC(sv); while ((mg_list = *mgp)) { mgp = &mg_list->mg_moremagic; } *mgp = mg; if (mgType == PERL_MAGIC_ext) { /* We are not doing a real tie to an AV so we need to set the vtable and re-calc magic flags */ mg->mg_virtual = &PL_vtbl_uvar; mg_magical(sv); } if (!SvMAGICAL(sv)) abort(); return TCL_OK; } SV * FindTkVarName(varName,flags) CONST char *varName; int flags; { dTHX; STRLEN na; SV *name = newSVpv(BASEEXT,strlen(BASEEXT)); SV *sv; sv_catpv(name,"::"); if (!strncmp(varName,"tk_",3)) varName += 3; sv_catpv(name,varName); sv = get_sv(SvPV(name,na),flags); SvREFCNT_dec(name); return sv; } char * LangLibraryDir() { dTHX; STRLEN na; SV *sv = FindTkVarName("library",0); if (sv && SvPOK(sv)) return SvPV(sv,na); return NULL; } static DECL_MG_UFUNC(LinkIntSet,ix,sv) { int *p = INT2PTR(int *, ix); (*p) = SvIV(sv); return 0; } static DECL_MG_UFUNC(LinkDoubleSet,ix,sv) { double *p = INT2PTR(double *, ix); (*p) = SvNV(sv); return 0; } static DECL_MG_UFUNC(LinkCannotSet,ix,sv) { croak("Attempt to set readonly linked variable"); return 0; } static DECL_MG_UFUNC(LinkIntVal,ix,sv) { int *p = INT2PTR(int *, ix); sv_setiv(sv,*p); return 0; } static DECL_MG_UFUNC(LinkDoubleVal,ix,sv) { double *p = INT2PTR(double *, ix); sv_setnv(sv,*p); return 0; } int Tcl_LinkVar(interp,varName,addr,type) Tcl_Interp *interp; CONST char *varName; char *addr; int type; { dTHX; SV *sv = FindTkVarName(varName,0); if (sv) { struct ufuncs uf; uf.uf_index = PTR2IV(addr); switch(type & ~TCL_LINK_READ_ONLY) { case TCL_LINK_INT: case TCL_LINK_BOOLEAN: uf.uf_val = LinkIntVal; uf.uf_set = LinkIntSet; *((int *) addr) = SvIV(sv); break; case TCL_LINK_DOUBLE: uf.uf_val = LinkDoubleVal; uf.uf_set = LinkDoubleSet; *((double *) addr) = SvNV(sv); break; case TCL_LINK_STRING: default: return EXPIRE((interp,"Cannot link %s type %d\n",varName,type)); } if (type & TCL_LINK_READ_ONLY) { uf.uf_set = LinkCannotSet; } sv_magic(sv,NULL, PERL_MAGIC_uvar, (char *) (&uf), sizeof(uf)); return TCL_OK; } else { return EXPIRE((interp,"No variable %s\n",varName)); } } void Tcl_UnlinkVar(interp,varName) Tcl_Interp *interp; CONST char *varName; { dTHX; SV *sv = FindTkVarName(varName,0); if (sv) { sv_unmagic(sv,PERL_MAGIC_uvar); } } void Lang_UntraceVar(interp, sv, flags, tkproc, clientData) Tcl_Interp *interp; SV *sv; int flags; Lang_VarTraceProc *tkproc; ClientData clientData; { int mgType = PERL_MAGIC_uvar; MAGIC **mgp; /* it may not be magical i.e. it may never have been traced This occurs for example when cascade Menu gets untraced by same code that untraces checkbutton menu items. If it is not magical just ignore it. */ if (SvROK(sv)) sv = SvRV(sv); if (SvTYPE(sv) == SVt_PVAV) { mgType = PERL_MAGIC_ext; } if (SvMAGICAL(sv) && (mgp = &SvMAGIC(sv))) { MAGIC *mg; for (mg = *mgp; mg; mg = *mgp) { /* * Trawl through the linked list of magic looking * for the 'U' one which is our proc and ix. */ if (mg->mg_type == mgType && mg->mg_ptr && mg->mg_len == sizeof(struct ufuncs) && ((struct ufuncs *) (mg->mg_ptr))->uf_set == Perl_Trace) { struct ufuncs *uf = (struct ufuncs *) (mg->mg_ptr); Tk_TraceInfo *p = INT2PTR(Tk_TraceInfo *, uf->uf_index); if (p && p->proc == tkproc && p->interp == interp && p->clientData == clientData) { *mgp = mg->mg_moremagic; Tcl_DeleteExitHandler(TraceExitHandler, (ClientData) p); Safefree(p); uf->uf_index = 0; Safefree(mg->mg_ptr); mg->mg_ptr = NULL; Safefree(mg); } else mgp = &mg->mg_moremagic; } else mgp = &mg->mg_moremagic; } if (!SvMAGIC(sv)) { SvMAGICAL_off(sv); SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT; } } } int Lang_TraceVar(interp, varName, flags, proc, clientData) Tcl_Interp *interp; Var varName; int flags; Lang_VarTraceProc *proc; ClientData clientData; { return Lang_TraceVar2(interp, varName, NULL, flags, proc, clientData); } Tcl_Obj * LangFindVar(interp, tkwin, name) Tcl_Interp *interp; Tk_Window tkwin; CONST char *name; { dTHX; if (tkwin) { SV *sv = TkToWidget(tkwin,NULL); if (name == Tk_Name(tkwin)) name = "Value"; if (sv && SvROK(sv)) { HV *hv = (HV *) SvRV(sv); STRLEN l = strlen(name); SV **x = hv_fetch(hv, name, l, 1); if (!x) x = hv_store(hv, name, l, newSVpv("", 0), 0); if (x) return SvREFCNT_inc(*x); } } else { SV *sv = FindTkVarName(name,1); if (sv) return SvREFCNT_inc(sv); } return newSVpv("", 0); } int LangStringMatch(string, match) char *string; SV *match; { dTHX; STRLEN na; /* match could be a callback to perl sub to do re match */ return Tcl_StringMatch(string, SvPV(match, na)); } int LangSaveVar(interp,sv,vp,type) Tcl_Interp *interp; Tcl_Obj * sv; Var *vp; int type; { dTHX; STRLEN na; int old_taint = PL_tainted; TAINT_NOT; *vp = NULL; if (!sv) { return TCL_OK; } if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv)) { sv = SvRV(sv); if (sv == &PL_sv_undef) warn("variable is 'undef'"); switch(type) { case TK_CONFIG_HASHVAR: if (SvTYPE(sv) != SVt_PVHV) EXPIRE((interp,"%s is not a hash",SvPV(sv,na))); break; case TK_CONFIG_ARRAYVAR: if (SvTYPE(sv) != SVt_PVAV) EXPIRE((interp,"%s is not an array",SvPV(sv,na))); break; default: case TK_CONFIG_SCALARVAR: break; } *vp = SvREFCNT_inc(sv); PL_tainted = old_taint; return TCL_OK; } else if (SvPOK(sv)) { dTHX; HV *old_stash = CopSTASH(PL_curcop); char *name; SV *x = NULL; int prefix = '?'; name = SvPV(sv,na); #ifdef CAN_COPSTASH_SET_NULL CopSTASH_set(PL_curcop, NULL); #else # ifdef USE_ITHREADS CopSTASHPV(PL_curcop) = NULL; # else CopSTASH(PL_curcop) = NULL; # endif #endif switch (type) { case TK_CONFIG_SCALARVAR: prefix = '$'; default: if (!strchr(name,':')) { x = FindTkVarName(name,1); } else { x = perl_get_sv(name,1); } break; case TK_CONFIG_ARRAYVAR: x = (SV *) perl_get_av(name,TRUE); prefix = '@'; break; case TK_CONFIG_HASHVAR: x = (SV *) perl_get_hv(name,TRUE); prefix = '%'; break; } CopSTASH_set(PL_curcop, old_stash); if (x) { *vp = SvREFCNT_inc(x); PL_tainted = old_taint; return TCL_OK; } else Tcl_SprintfResult(interp,"%c%s does not exist",prefix,name); } else { Tcl_SprintfResult(interp,"Not a reference %s",SvPV(sv,na)); } PL_tainted = old_taint; return TCL_ERROR; } void LangFreeVar(sv) Var sv; { dTHX; SvREFCNT_dec(sv); } int LangConfigObj(Tcl_Interp *interp, Tcl_Obj **save, Tcl_Obj *obj, int type) { dTHX; *save = Nullsv; switch (type) { case TK_OPTION_OBJ: if (obj) *save = LangCopyArg(obj); return TCL_OK; case TK_OPTION_CALLBACK: if (obj) *save = LangMakeCallback(obj); return TCL_OK; case TK_OPTION_SCALARVAR: return LangSaveVar(interp,obj,save,TK_CONFIG_SCALARVAR); case TK_OPTION_ARRAYVAR: return LangSaveVar(interp,obj,save,TK_CONFIG_ARRAYVAR); case TK_OPTION_HASHVAR: return LangSaveVar(interp,obj,save,TK_CONFIG_HASHVAR); default: Tcl_SprintfResult(interp,"Unexpected type %d for LangConfigObj(%"SVf")", type,obj); } return TCL_ERROR; } int Lang_CallWithArgs(interp, sub, argc, argv) Tcl_Interp *interp; char *sub; int argc; SV *CONST *argv; { dTHX; dSP; STRLEN len; int count; SV *sv = newSVpv("",0); if (!strncmp(sub,"tk",2)) { sv_catpv(sv,"Tk::"); sub += 2; } sv_catpv(sv,sub); sub = SvPV(sv,len); ENTER; SAVETMPS; EXTEND(sp, argc); PUSHMARK(sp); while (argc-- > 0) { XPUSHs(*argv++); } PUTBACK; count = perl_call_pv(sub, G_EVAL|G_SCALAR); SetTclResult(interp,count); SvREFCNT_dec(sv); FREETMPS; LEAVE; return Check_Eval(interp); } int LangMethodCall #ifdef STANDARD_C _((Tcl_Interp * interp, Tcl_Obj * sv, char *method, int result, int argc,...)) #else (interp, sv, method, result, argc, va_alist) Tcl_Interp *interp; SV *sv; char *method; int result; int argc; va_dcl #endif { dTHX; dSP; int flags = (result) ? 0 : G_DISCARD; int count = 0; int old_taint = PL_tainted; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_mortalcopy(sv)); PUTBACK; if (argc) { va_list ap; #ifdef I_STDARG va_start(ap, argc); #else va_start(ap); #endif PushVarArgs(ap,argc); va_end(ap); } PL_tainted = 0; sv = sv_newmortal(); sv_setpv(sv,method); PL_tainted = old_taint; count = LangCallCallback(sv, flags | G_EVAL); if (result) SetTclResult(interp,count); FREETMPS; LEAVE; return Check_Eval(interp); } int Tcl_EvalObjEx (Tcl_Interp *interp,Tcl_Obj *objPtr, int flags) { dTHX; int code; SV *cb = LangMakeCallback(objPtr); SV *sv = cb; SvREFCNT_inc(interp); ENTER; SAVETMPS; if (PushCallbackArgs(interp,&sv) == TCL_OK) { int count = LangCallCallback(sv, G_SCALAR | G_EVAL); SetTclResult(interp,count); } FREETMPS; LEAVE; SvREFCNT_dec(cb); code = Check_Eval(interp); SvREFCNT_dec(interp); return code; } int Tcl_EvalObj(Tcl_Interp *interp,Tcl_Obj *objPtr) { return Tcl_EvalObjEx(interp,objPtr,0); } /* * Tcl_EvalObjv is used by tkMenu.c's CloneMenu * In order to allow Tk::Menu::tkMenuDup to return * the "object" for the created menu we pass actual * objects not mortal copies. * We also avoid the overhead of creating, blessing and destroying * "Callback" object. */ int Tcl_EvalObjv(Tcl_Interp * interp, int objc, Tcl_Obj *CONST objv[], int flags) { SV *sv = objv[0]; int i; dTHX; dSP; ENTER; SAVETMPS; PUSHMARK(sp); for (i=1; i < objc; i++) { XPUSHs(objv[i]); } PUTBACK; i = LangCallCallback(sv, G_SCALAR | G_EVAL); SetTclResult(interp,i); FREETMPS; LEAVE; return Check_Eval(interp); } int Tcl_GlobalEval(Tcl_Interp *interp, CONST char *command) { dTHX; if (!PL_tainting) { warn("Receive from Tk's 'send' ignored (no taint checking)\n"); return EXPIRE((interp,"send to non-secure perl/Tk application rejected\n")); } else { dSP; int count = 0; int old_taint = PL_tainted; SV *sv; PL_tainted = 0; ENTER; SAVETMPS; PUSHMARK(sp); Set_widget(sv = WidgetRef(interp,".")); XPUSHs(sv_mortalcopy(sv)); PL_tainted = 1; sv = newSVpv(command,strlen(command)); SvTAINT(sv); PL_tainted = 0; XPUSHs(sv_2mortal(sv)); PUTBACK; Tcl_ResetResult(interp); Lang_ClearErrorInfo(interp); sv = sv_2mortal(newSVpv("Receive",0)); PL_tainted = old_taint; count = LangCallCallback(sv, G_ARRAY | G_EVAL); SetTclResult(interp,count); FREETMPS; LEAVE; return Check_Eval(interp); } } XS(XS_Tk__Widget_BindClientMessage) { dXSARGS; if (items >= 1) { HV *hv = NULL; Lang_CmdInfo *info = WindowCommand(ST(0), &hv, 2); if (info) { HV *cm = FindHv(aTHX_ hv, "BindClientMessage", (items > 2), CM_KEY); if (items >= 2) { STRLEN len; char *key = SvPV(ST(1),len); if (items > 2) { SV *cb = LangMakeCallback(ST(2)); hv_store(cm, key, len, cb ,0); } else { if (cm) { SV **x = hv_fetch(cm, key, len, 0); if (x) ST(0) = sv_mortalcopy(*x); } } } else { if (cm) ST(0) = sv_2mortal(newRV((SV *) cm)); } } } else croak("Usage: $w->BindClientMessage(atom,callback)"); XSRETURN(1); } #ifdef WIN32 int Lang_WinEvent(tkwin, message, wParam, lParam, resultPtr) Tk_Window tkwin; UINT message; WPARAM wParam; LPARAM lParam; LRESULT *resultPtr; { dTHX; Tcl_Interp *interp = NULL; SV *w = TkToWidget(tkwin,&interp); char key[32]; HV *cm = NULL; STRLEN na; int code = 0; if ( !interp || !w || !SvROK(w)) { return 0; } sprintf(key,"%d",message); if (SvROK(w)) cm = FindHv(aTHX_ (HV *) SvRV(w),"Lang_WinMessage",0,CM_KEY); if (cm) { SV **x = hv_fetch(cm,key,strlen(key),0); SV *sv; if (!x) x = hv_fetch(cm,"0",1,0); if (x && (sv = *x)) { dSP; SV *data = struct_sv(NULL, sizeof(EventAndKeySym)); EventAndKeySym *info = (EventAndKeySym *) SvPVX(data); int result; #if 0 LangDebug("%s %d '%s'\n",Tk_PathName(tkwin), message,SvPV(sv,na)); #endif info->keySym = 0; info->interp = interp; info->window = w; info->tkwin = tkwin; ENTER; SAVETMPS; Tcl_ResetResult(interp); Lang_ClearErrorInfo(interp); Set_widget(w); result = PushObjCallbackArgs(interp,&sv,info); SPAGAIN; if (result == TCL_OK) { XPUSHs(sv_2mortal(newSViv(message))); XPUSHs(sv_2mortal(newSViv(wParam))); XPUSHs(sv_2mortal(newSViv(lParam))); PUTBACK; result = LangCallCallback(sv, G_DISCARD | G_EVAL); if (result) { SPAGAIN; sv = POPs; PUTBACK; if (SvIOK(sv)) { *resultPtr = SvIV(sv); code = 1; } } } Lang_MaybeError(interp,Check_Eval(interp),"ClientMessage handler"); FREETMPS; LEAVE; } } return code; } #endif /* WIN32 */ void LangClientMessage(interp, tkwin, event) Tcl_Interp *interp; Tk_Window tkwin; XEvent *event; { dTHX; SV *w = TkToWidget(tkwin,NULL); CONST char *key; HV *cm = NULL; if (!SvROK(w)) { Tk_Window mainwin = (Tk_Window)((((TkWindow*)tkwin)->mainPtr)->winPtr); w = TkToWidget(mainwin,NULL); } key = Tk_GetAtomName(tkwin, event->xclient.message_type); if (SvROK(w)) cm = FindHv(aTHX_ (HV *) SvRV(w),"LangClientMessage",0,CM_KEY); if (cm) { SV **x = hv_fetch(cm,key,strlen(key),0); SV *sv; if (!x) x = hv_fetch(cm,"any",3,0); if (x && (sv = *x)) { dSP; SV *data = struct_sv(NULL, sizeof(EventAndKeySym)); EventAndKeySym *info = (EventAndKeySym *) SvPVX(data); SV *e = Blessed("XEvent", MakeReference(data)); int result; info->event = *event; info->keySym = 0; info->interp = interp; info->window = w; info->tkwin = tkwin; ENTER; SAVETMPS; Tcl_ResetResult(interp); Lang_ClearErrorInfo(interp); Set_widget(w); Set_event(e); if (SvROK(w)) { HV *hash = (HV *) SvRV(w); hv_store(hash, XEVENT_KEY, strlen(XEVENT_KEY), e, 0); } else Decrement(e,"Unused Event"); result = PushObjCallbackArgs(interp,&sv,info); if (result == TCL_OK) LangCallCallback(sv, G_DISCARD | G_EVAL); Lang_MaybeError(interp,Check_Eval(interp),"ClientMessage handler"); if (0 && SvROK(w)) { HV *hash = (HV *) SvRV(w); hv_delete(hash, XEVENT_KEY, strlen(XEVENT_KEY), G_DISCARD); } FREETMPS; LEAVE; } #if 0 else { warn("%s has no handler for '%s'\n",Tk_PathName(tkwin),key); } #endif } #if 0 else { warn("ClientMessage '%s' for %s\n", key, Tk_PathName(tkwin)); } #endif } int LangEventCallback(cdata, interp, event, tkwin, keySym) ClientData cdata; Tcl_Interp *interp; Tk_Window tkwin; XEvent *event; KeySym keySym; { dTHX; SV *sv = (SV *) cdata; int result = TCL_ERROR; Tk_Window ewin = Tk_EventWindow(event); #ifdef LEAK_CHECKING hash_ptr *save = NULL; long hwm = note_used(&save); fprintf(stderr, "Event Entry count=%ld hwm=%ld\n", ec = sv_count, hwm); #endif Tcl_ResetResult(interp); Lang_ClearErrorInfo(interp); if (!SvOK(sv)) { Tcl_SetResult(interp,"Call of undefined callback",TCL_STATIC); return TCL_ERROR; } if (ewin && tkwin) { dSP; int code; SV *data = struct_sv(NULL, sizeof(EventAndKeySym)); EventAndKeySym *info = (EventAndKeySym *) SvPVX(data); SV *e = Blessed("XEvent", MakeReference(data)); SV *w = TkToWidget(tkwin,NULL); #ifdef DEBUG_GLUE fprintf(stderr, "%s:%s(%s) = %p\n", "LangEventCallback", SvPV_nolen(sv), Tk_PathName(tkwin), info); #endif info->event = *event; info->keySym = keySym; info->interp = interp; info->window = w; info->tkwin = tkwin; ENTER; PUSHSTACKi(PERLSI_MAGIC); SAVETMPS; PUTBACK; Tcl_ResetResult(interp); Lang_ClearErrorInfo(interp); Set_widget(w); Set_event(e); result = PushObjCallbackArgs(interp,&sv,info); if (SvROK(w)) { HV *hash = (HV *) SvRV(w); hv_store(hash, XEVENT_KEY, strlen(XEVENT_KEY), e, 0); } else Decrement(e,"Unused Event"); if (result == TCL_OK) { LangCallCallback(sv, G_DISCARD | G_EVAL); FREETMPS; result = Check_Eval(interp); } if (0 && SvROK(w)) { HV *hash = (HV *) SvRV(w); hv_delete(hash, XEVENT_KEY, strlen(XEVENT_KEY), G_DISCARD); } POPSTACK; LEAVE; } else { /* * Event pertains to a window which has been/is being deleted. * Although we may be able to call perl code we cannot make * any method calls because the widget hash object has probably vanished. * * Quietly return "OK" having done nothing */ result = TCL_OK; } #ifdef LEAK_CHECKING fprintf(stderr, "sv_count was %ld, now %ld (%ld)\n", ec, sv_count, sv_count - ec); check_used(&save); #endif return result; } void LangFreeArg(sv, freeProc) Tcl_Obj * sv; Tcl_FreeProc *freeProc; { dTHX; Decrement(sv, "LangFreeArg"); } static int handle_generic(clientData, eventPtr) ClientData clientData; XEvent *eventPtr; { int code = 0; Tk_Window tkwin = Tk_EventWindow(eventPtr); if (tkwin) { GenericInfo *p = (GenericInfo *) clientData; Tcl_Interp *interp = p->interp; SV *sv = p->cb; dTHX; dSP; SV *data = struct_sv(NULL, sizeof(EventAndKeySym)); EventAndKeySym *info = (EventAndKeySym *) SvPVX(data); SV *e = Blessed("XEvent", MakeReference(data)); SV *w = NULL; int count = 0; int result; info->event = *eventPtr; info->keySym = None; info->interp = interp; info->tkwin = tkwin; do_watch(); Tcl_ResetResult(interp); Lang_ClearErrorInfo(interp); ENTER; SAVETMPS; if (tkwin) w = TkToWidget(tkwin,&info->interp); /* Pending REFCNT */ if (!SvROK(w)) w = Blessed("Window", MakeReference(newSViv((IV) (eventPtr->xany.window)))); else Set_widget(w); result = PushObjCallbackArgs(interp, &sv,info); if (result == TCL_OK) { SPAGAIN; Set_event(e); XPUSHs(sv_mortalcopy(e)); XPUSHs(sv_mortalcopy(w)); PUTBACK; count = LangCallCallback(sv, G_EVAL); result = Check_Eval(interp); } if (count) { SPAGAIN; code = TOPi; sp -= count; PUTBACK; } else code = 0; Lang_MaybeError(interp,result,"Generic Event"); FREETMPS; LEAVE; } return code; } static void Perl_GeomRequest(clientData,tkwin) ClientData clientData; Tk_Window tkwin; { Lang_CmdInfo *info = (Lang_CmdInfo *) clientData; SV *master = TkToWidget(info->tkwin,NULL); SV *slave = TkToWidget(tkwin,NULL); dTHX; dSP; ENTER; SAVETMPS; Set_widget(master); PUSHMARK(sp); XPUSHs(sv_mortalcopy(master)); XPUSHs(sv_mortalcopy(slave)); PUTBACK; LangCallCallback(sv_2mortal(newSVpv("SlaveGeometryRequest",0)),G_DISCARD); FREETMPS; LEAVE; } static void Perl_GeomLostSlave(clientData,tkwin) ClientData clientData; Tk_Window tkwin; { Lang_CmdInfo *info = (Lang_CmdInfo *) clientData; SV *master = TkToWidget(info->tkwin,NULL); SV *slave = TkToWidget(tkwin,NULL); dTHX; dSP; ENTER; SAVETMPS; PUSHMARK(sp); Set_widget(master); XPUSHs(sv_mortalcopy(master)); XPUSHs(sv_mortalcopy(slave)); PUTBACK; LangCallCallback(sv_2mortal(newSVpv("LostSlave",0)),G_DISCARD); FREETMPS; LEAVE; } XS(XS_Tk__Widget_ManageGeometry) { dXSARGS; STRLEN na; if (items == 2) { HV *hash = NULL; Lang_CmdInfo *info = WindowCommand(ST(0), &hash, 0); if (info && info->tkwin) { Lang_CmdInfo *slave = WindowCommand(ST(1), NULL, 0); if (slave && slave->tkwin) { SV **x = hv_fetch(hash,GEOMETRY_KEY,strlen(GEOMETRY_KEY),0); SV *mgr_sv = NULL; if (!x) { Tk_GeomMgr mgr; mgr.name = Tk_PathName(info->tkwin); mgr.requestProc = Perl_GeomRequest; mgr.lostSlaveProc = Perl_GeomLostSlave; mgr_sv = struct_sv((char *) &mgr,sizeof(mgr)); hv_store(hash,GEOMETRY_KEY,strlen(GEOMETRY_KEY),mgr_sv, 0); } else mgr_sv = *x; Tk_ManageGeometry(slave->tkwin, (Tk_GeomMgr *) SvPV(mgr_sv,na), (ClientData) info); } else croak("Not a (slave) widget %s",SvPV(ST(1),na)); } else croak("Not a (master) widget %s",SvPV(ST(0),na)); } else croak("usage $master->ManageGeometry($slave)"); XSRETURN(1); } static void handle_idle(clientData) ClientData clientData; { dTHX; GenericInfo *p = (GenericInfo *) clientData; SV *sv = p->cb; dSP; int count = 0; int code = 0; ENTER; SAVETMPS; Tcl_ResetResult(p->interp); Lang_ClearErrorInfo(p->interp); Set_widget(WidgetRef(p->interp,".")); code = PushCallbackArgs(p->interp,&sv); if (code == TCL_OK) { LangCallCallback(sv, G_DISCARD | G_EVAL); code = Check_Eval(p->interp); } Lang_MaybeError(p->interp,code,"Idle Callback"); FREETMPS; LEAVE; LangFreeCallback(p->cb); DecInterp(p->interp, "handle_idle"); ckfree((char *) p); } XS(XS_Tk_DoWhenIdle) { dXSARGS; STRLEN na; if (items == 2) { Lang_CmdInfo *info = WindowCommand(ST(0), NULL, 0); if (info && info->interp && (info->tkwin || info->image)) { /* Try to get result to prove things are "still alive" */ if (Tcl_GetObjResult(info->interp)) { GenericInfo *p = (GenericInfo *) ckalloc(sizeof(GenericInfo)); IncInterp(info->interp,"Tk_DoWhenIdle"); p->interp = info->interp; p->cb = LangMakeCallback(ST(1)); Tcl_DoWhenIdle(handle_idle, (ClientData) p); } } else croak("Not a widget %s",SvPV(ST(0),na)); } else croak("Usage $w->DoWhenIdle(callback)"); XSRETURN(1); } XS(XS_Tk_CreateGenericHandler) { dXSARGS; STRLEN na; if (items == 2) { Lang_CmdInfo *info = WindowCommand(ST(0), NULL, 0); if (info && info->interp && (info->tkwin || info->image)) { if (Tcl_GetObjResult(info->interp)) { GenericInfo *p = (GenericInfo *) ckalloc(sizeof(GenericInfo)); IncInterp(info->interp,"Tk_CreateGenericHandler"); p->interp = info->interp; p->cb = LangMakeCallback(ST(1)); Tk_CreateGenericHandler(handle_generic, (ClientData) p); } } else croak("Not a widget %s",SvPV(ST(0),na)); } else croak("Usage $w->CreateGenericHandler(callback)"); XSRETURN(1); } SV * XEvent_Info(obj,s) EventAndKeySym *obj; char *s; { dTHX; SV *eventSv = sv_newmortal(); I32 ix = (I32) *s; char scratch[256]; if (obj) { if (ix == '@' || strncmp(s,"xy",2) == 0) { char result[80]; strcpy(result, "@"); strcat(result, Tk_EventInfo('x', obj->tkwin, &obj->event, obj->keySym, NULL, NULL, NULL, sizeof(scratch) - 1, scratch)); strcat(result, ","); strcat(result, Tk_EventInfo('y', obj->tkwin, &obj->event, obj->keySym, NULL, NULL, NULL, sizeof(scratch) - 1, scratch)); sv_setpv(eventSv, result); } else { int isNum = 0; int number = 0; int type = TK_EVENTTYPE_NONE; char *result = Tk_EventInfo(ix, obj->tkwin, &obj->event, obj->keySym, &number, &isNum, &type, sizeof(scratch) - 1, scratch); switch (type) { case TK_EVENTTYPE_WINDOW: { SV *w = &PL_sv_undef; if (result && result[0] == '.') w = WidgetRef(obj->interp, result); if (SvROK(w)) SvSetMagicSV(eventSv, w); else { if (number) sv_setref_iv(eventSv, "Window", number); } } break; case TK_EVENTTYPE_DISPLAY: sv_setref_pv(eventSv, "DisplayPtr", (void *) number); break; case TK_EVENTTYPE_DATA: sv_setpvn(eventSv, result, (unsigned) number); break; default: if (result) { sv_setpv(eventSv, result); } if (isNum) { sv_setiv(eventSv, number); if (result) SvPOK_on(eventSv); } break; } } } return sv_maybe_utf8(eventSv); } EventAndKeySym * SVtoEventAndKeySym(SV *arg) { dTHX; SV *sv; if (sv_isobject(arg) && (sv = SvRV(arg)) && SvPOK(sv) && SvCUR(sv) == sizeof(EventAndKeySym)) { return (EventAndKeySym *) SvPVX(sv); } else croak("obj is not an XEvent"); return NULL; } XS(XS_Tk__Widget_PassEvent) { dXSARGS; Tk_Window tkwin = NULL; EventAndKeySym *obj = NULL; if (items == 2 && (tkwin = (Tk_Window) SVtoWindow(ST(0))) && (obj = SVtoEventAndKeySym(ST(1))) ) { if (Tk_WindowId(tkwin) == None) Tk_MakeWindowExist(tkwin); TkBindEventProc((TkWindow *)tkwin, &obj->event); } else croak("Usage: $widget->PassEvent($event)"); ST(0) = &PL_sv_undef; XSRETURN(1); } void Tk_ChangeScreen(interp, dispName, screenIndex) Tcl_Interp *interp; char *dispName; int screenIndex; { } /* These are for file name handling which needs further abstraction */ char * Tcl_TranslateFileName(interp, name, bufferPtr) Tcl_Interp *interp; CONST char *name; Tcl_DString *bufferPtr; { dTHX; dSP; IV count; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSVpv((char *) name,0))); PUTBACK; perl_call_pv("Tk::TranslateFileName",G_EVAL|G_SCALAR); SPAGAIN; *bufferPtr = POPs; PUTBACK; SvREFCNT_inc(*bufferPtr); FREETMPS; LEAVE; return Tcl_DStringValue(bufferPtr); } CONST char * Tcl_PosixError(interp) Tcl_Interp *interp; { dTHX; return Strerror(errno); } #ifdef STANDARD_C void EnterWidgetMethods(char *package,...) #else /*VARARGS0 */ void EnterWidgetMethods(package, va_alist) char *package; va_dcl #endif { dTHX; va_list ap; char buf[80]; char *method; #ifdef I_STDARG va_start(ap, package); #else va_start(ap); #endif while ((method = va_arg(ap, char *))) { CV *cv; if (strcmp(method, "configure") && strcmp(method, "cget")) { sprintf(buf, "Tk::%s::%s", package, method); cv = newXS(buf, XStoWidget, __FILE__); CvXSUBANY(cv).any_ptr = newSVpv(method, 0); } } } void Lang_SetErrorCode(interp, code) Tcl_Interp *interp; char *code; { } void Tcl_SetObjErrorCode (Tcl_Interp * interp,Tcl_Obj * errorObjPtr) { } char * Lang_GetErrorCode(interp) Tcl_Interp *interp; { warn("Lang_GetErrorCode not implemented"); return ""; } char * Lang_GetErrorInfo(interp) Tcl_Interp *interp; { warn("Lang_GetErrorInfo not implemented"); return ""; } void LangBadFile(fd) int fd; { warn("File (%d) closed without deleting handler",fd); } int LangEventHook(flags) int flags; /* Used by Tcl_Async stuff for signal handling */ { #if 0 #if defined(WNOHANG) && (defined(HAS_WAITPID) || defined(HAS_WAIT4)) int status = -1; I32 pid = wait4pid(-1,&status,WNOHANG); if (pid > 0) { pidgone(pid, status); warn("Child process %d status=%d",pid,status); return 1; } #endif #endif return 0; } /* Tcl caches compiled regexps so does not free them */ struct WrappedRegExp { #if HAS_PMOP_EXTRA_FLAGS PMOP op; #else U32 flags; #endif #if USE_REGEXP_511 REGEXP *pat; #else regexp *pat; #endif SV *source; }; void Lang_FreeRegExp(re) Tcl_RegExp re; { dTHX; if (re->pat) ReREFCNT_dec(re->pat); if (re->source) SvREFCNT_dec(re->source); Safefree(re); } /* An "XS" routine to call with G_EVAL set */ static void do_comp(pTHX_ CV *cv) { dMARK; dAX; struct WrappedRegExp *p = (struct WrappedRegExp *) CvXSUBANY(cv).any_ptr; #if USE_PREGCOMP_31027 p->pat = pregcomp(p->source,p->flags); #else /* USE_PREGCOMP_31027 */ int len = 0; char *string = Tcl_GetStringFromObj(p->source,&len); #if HAS_PMOP_EXTRA_FLAGS p->op.op_pmdynflags |= PMdf_DYN_UTF8; p->pat = pregcomp(string,string+len,&p->op); #else p->pat = pregcomp(string,string+len,p->flags); #endif #if 0 LangDebug("/%.*s/ => %p\n",len,string,p->pat); #endif #endif /* USE_PREGCOMP_31027 */ XSRETURN(0); } I32 Lang_catch(pTHX_ XSUBADDR_t subaddr, void *any, I32 flags,char *filename) { dSP; CV *cv = (CV *) sv_newmortal(); int count; SV **oldSP = sp; sv_upgrade((SV *)cv, SVt_PVCV); CvFILE(cv) = filename; CvXSUB(cv) = subaddr; CvXSUBANY(cv).any_ptr = any; #ifdef CvISXSUB_on CvISXSUB_on(cv); /* this is needed for perl5.9@27244 */ #endif count = call_sv((SV *)cv,flags|G_EVAL); SPAGAIN; if (sp != oldSP) { LangDebug("Stack moved %p => %p\n",oldSP,sp); } return count; } Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *obj, int flags) { dTHX; Tcl_RegExp re; MAGIC *mg = Null(MAGIC*); Newz('R', re, 1, struct WrappedRegExp); re->source = Tcl_DuplicateObj(obj); /* If source is a reference and thing refrered to has right magic we can use regexp from the qr// */ if (SvROK(re->source)) { SV *sv = SvRV(re->source); if(SvMAGICAL(sv)) mg = mg_find(sv, PERL_MAGIC_qr); } #if HAS_PMOP_EXTRA_FLAGS /* Could do more conversions here Not sure how/if to override case-ness of qr// pattern */ if (flags & TCL_REG_NOCASE) { re->op.op_pmflags |= PMf_FOLD; } #else #if USE_REGEXP_511 re->flags = (flags & TCL_REG_NOCASE ? RXf_PMf_FOLD : 0); #else re->flags = RXf_UTF8 | (flags & TCL_REG_NOCASE ? RXf_PMf_FOLD : 0); #endif #endif if (mg) { #if USE_REGEXP_511 re->pat = (REGEXP *)mg->mg_obj; #else re->pat = (regexp *)mg->mg_obj; #endif /* Guess wildly ... */ ReREFCNT_inc(re->pat); } else { dSP; SV *err; ENTER; SAVETMPS; PUSHMARK(sp); Lang_catch(aTHX_ do_comp, re, G_VOID, __FILE__); FREETMPS; LEAVE; err = ERRSV; if (SvTRUE(err)) { Lang_FreeRegExp(re); Tcl_SetResult(interp,SvPV_nolen(err),TCL_VOLATILE); return NULL; } } return re; } int Tcl_RegExpExec(interp, re, cstring, cstart) Tcl_Interp *interp; Tcl_RegExp re; CONST char *cstring; CONST char *cstart; { dTHX; SV *tmp = sv_newmortal(); int code; sv_upgrade(tmp,SVt_PV); SvCUR_set(tmp,strlen(cstring)); SvPVX(tmp) = (char *) cstring; SvLEN(tmp) = 0; SvREADONLY_on(tmp); SvPOK_on(tmp); /* From Tk all strings are UTF-8 */ SvUTF8_on(tmp); #ifdef ROPT_MATCH_UTF8 RX_MATCH_UTF8_on(re->pat); #else /* eeek what do we do now ... */ #endif code = pregexec(re->pat,SvPVX(tmp),SvEND(tmp),(char *) cstart,0, tmp,REXEC_COPY_STR); #if 0 LangDebug("%d '%.*s'\n",code,SvCUR(tmp),SvPVX(tmp)); sv_dump(tmp); regdump(re->pat); #endif return code; } void Tcl_RegExpRange(wrap, index, startPtr, endPtr) Tcl_RegExp wrap; int index; CONST84 char **startPtr; CONST84 char **endPtr; { #if USE_REGEXP_511 REGEXP *rx = wrap->pat; regexp *const re = (struct regexp *)SvANY(rx); #else regexp *re = wrap->pat; #endif #if USE_NEWSTYLE_REGEXP_STRUCT if (re->offs[index].start != -1 && re->offs[index].end != -1) { *startPtr = re->subbeg+re->offs[index].start; *endPtr = re->subbeg+re->offs[index].end; } #else if (re->startp[index] != -1 && re->endp[index] != -1) { *startPtr = re->subbeg+re->startp[index]; *endPtr = re->subbeg+re->endp[index]; } #endif else { *startPtr = NULL; *endPtr = NULL; } } void Lang_BuildInImages() { #if 0 Tk_CreateImageType(&tkBitmapImageType); Tk_CreateImageType(&tkPixmapImageType); Tk_CreateImageType(&tkPhotoImageType); /* * Create built-in photo image formats. */ Tk_CreatePhotoImageFormat(&tkImgFmtPPM); #endif } ClientData Tcl_GetAssocData(interp,name,procPtr) Tcl_Interp *interp; CONST char *name; Tcl_InterpDeleteProc **procPtr; { dTHX; HV *cm = FindHv(aTHX_ interp, "Tcl_GetAssocData", 0, ASSOC_KEY); SV **x = hv_fetch(cm, name, strlen(name), 0); if (x) { STRLEN sz; Assoc_t *info = (Assoc_t *) SvPV(*x,sz); if (sz != sizeof(*info)) croak("%s corrupted",ASSOC_KEY); if (procPtr) *procPtr = info->proc; return info->clientData; } return NULL; } void Tcl_SetAssocData(interp,name,proc,clientData) Tcl_Interp *interp; CONST char *name; Tcl_InterpDeleteProc *proc; ClientData clientData; { dTHX; HV *cm = FindHv(aTHX_ interp, "Tcl_SetAssocData", 1, ASSOC_KEY); Assoc_t info; SV *d; info.proc = proc; info.clientData = clientData; d = struct_sv((char *) &info,sizeof(info)); hv_store(cm,name,strlen(name),d,0); } #define MkXSUB(str,name,xs,proc) \ extern XSdec(name); \ XS(name) \ { \ CvXSUB(cv) = xs; \ CvXSUBANY(cv).any_ptr = (VOID *) proc; \ xs(aTHX_ cv); \ } #include "TkXSUB.def" #undef MkXSUB void install_vtab(name, table, size) char *name; void *table; size_t size; { dTHX; if (table) { typedef unsigned (*fptr)_((void)); fptr *q = table; unsigned i; if ((*q[0])() != size) { croak("%s table is %u not %u",name,(*q[0])(),(unsigned) size); } sv_setiv(FindTkVarName(name,GV_ADD|GV_ADDMULTI),PTR2IV(table)); if (size % sizeof(fptr)) { warn("%s is strange size %d",name,size); } size /= sizeof(void *); for (i=0; i < size; i++) { if (!q[i]) warn("%s slot %d is NULL",name,i); } } else { croak("%s pointer is NULL",name); } } XS(XS_Tk_INIT) { dXSARGS; InitVtabs(); XSRETURN_EMPTY; } void Boot_Glue _((pTHX)) { dSP; /* A wonder how you call $e-># ? */ char *XEventMethods = "abcdfhkmopstvwxyABDEKNRSTWXY#"; char buf[128]; CV *cv; #if PERL_REVISION > 5 || (PERL_REVISION == 5 && PERL_VERSION >= 9) #define COP_WARNINGS_TYPE STRLEN* #else #define COP_WARNINGS_TYPE SV* #endif #ifdef pWARN_NONE COP_WARNINGS_TYPE old_warn = PL_curcop->cop_warnings; PL_curcop->cop_warnings = pWARN_NONE; #endif /* Arrange to call initialization code - an XSUB called INIT */ cv = newXS("Tk::INIT", XS_Tk_INIT, __FILE__); #ifdef pWARN_NONE PL_curcop->cop_warnings = old_warn; #endif initialized = 0; InitVtabs(); #ifdef VERSION sprintf(buf, "%s::VERSION", BASEEXT); sv_setpv(perl_get_sv(buf,1),VERSION); #endif sprintf(buf, "%s::Widget::%s", BASEEXT, "BindClientMessage"); cv = newXS(buf, XS_Tk__Widget_BindClientMessage, __FILE__); sprintf(buf, "%s::Widget::%s", BASEEXT, "PassEvent"); cv = newXS(buf, XS_Tk__Widget_PassEvent, __FILE__); sprintf(buf, "%s::Widget::%s", BASEEXT, "SelectionGet"); cv = newXS(buf, XS_Tk__Widget_SelectionGet, __FILE__); cv = newXS("Tk::MainWindow::Create", XS_Tk__MainWindow_Create, __FILE__); newXS("Tk::DoWhenIdle", XS_Tk_DoWhenIdle, __FILE__); newXS("Tk::CreateGenericHandler", XS_Tk_CreateGenericHandler, __FILE__); sprintf(buf, "%s::Widget::%s", BASEEXT, "ManageGeometry"); cv = newXS(buf, XS_Tk__Widget_ManageGeometry, __FILE__); cv = newXS("Tk::Interp::DESTROY", XS_Tk__Interp_DESTROY, __FILE__); #define MkXSUB(str,name,xs,proc) \ newXS(str, name, __FILE__); #include "TkXSUB.def" #undef MkXSUB Tk_CreateImageType(&tkPhotoImageType); Tk_CreatePhotoImageFormat(&tkImgFmtPPM); #if 0 Tk_CreatePhotoImageFormat(&imgFmtGIF); #else Tk_CreatePhotoImageFormat(&tkImgFmtGIF); #endif Tk_CreatePhotoImageFormat(&imgFmtXBM); Tk_CreatePhotoImageFormat(&imgFmtXPM); Tk_CreatePhotoImageFormat(&imgFmtBMP); } void Tcl_AllowExceptions (Tcl_Interp *interp) { /* FIXME: What should this do ? */ } static HV *uidHV; Tk_Uid Tk_GetUid(key) CONST char *key; /* String to convert. */ { dTHX; STRLEN klen; SV *svkey = newSVpv((char *)key,strlen(key)); HE *he; if (!uidHV) uidHV = newHV(); he = hv_fetch_ent(uidHV,svkey,0,0); /* added by SRT: prevents leak of auto-created SVs */ if (!he) he = hv_store_ent(uidHV,svkey,Nullsv,0); /* ... */ SvREFCNT_dec(svkey); return (Tk_Uid) HePV(he,klen); } Tcl_Obj* Tcl_FSGetCwd(interp) Tcl_Interp *interp; { dTHX; dSP; SV *ret = Nullsv; ENTER; SAVETMPS; PUSHMARK(sp); PUTBACK; if (call_pv("Cwd::getcwd",G_SCALAR) == 1) { SPAGAIN; ret = POPs; PUTBACK; SvREFCNT_inc(ret); } else { SPAGAIN; } FREETMPS; LEAVE; return ret; } char * Tcl_GetCwd(interp, cwdPtr) Tcl_Interp *interp; Tcl_DString *cwdPtr; { Tcl_Obj *cwd; cwd = Tcl_FSGetCwd(interp); if (cwd == NULL) { return NULL; } else { Tcl_DStringInit(cwdPtr); Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1); Tcl_DecrRefCount(cwd); return Tcl_DStringValue(cwdPtr); } } void LangSelectHook(CONST char *what,Tk_Window tkwin, Atom selection, Atom target, Atom type) { #if 0 /* There is still something not-quite-right about Selection but we don't want all this noise in the release */ TkWindow *winPtr = (TkWindow *)tkwin; char *name = (tkwin == winPtr->dispPtr->clipWindow) ? "ClipWindow" : Tk_PathName(tkwin); LangDebug("%s sel=%s target=%s type=%s win=%p '%s'\n", what, Tk_GetAtomName(tkwin, selection), Tk_GetAtomName(tkwin, target), (type == None) ? "None" : Tk_GetAtomName(tkwin, type), tkwin, name); #endif } Tk-804.031/rebuild000755 001750 001750 00000001243 11400162254 014436 0ustar00eserteeserte000000 000000 #!/usr/local/bin/new/perl -w open(STDERR,">&STDOUT") || die "Cannot redirect STDERR"; $| = 1; use Cwd; my $host = `uname -n`; chomp($host); my $cwd = getcwd(); print "$host in $cwd executing $0\n"; print $ENV{'PATH'},"\n"; #System("make",'-f','Makefile.old',"clean") if -f "Makefile.old"; #System("make","clean") if -f "Makefile"; System("cleanup"); System("$^X","Makefile.PL"); System("time","make","parallel"); sub System { print join(' ',@_),"\n"; my $pid = fork; if ($pid) { local %SIG; $SIG{INT} = sub { warn "\nInterrupt"; kill 9,$pid; exit 1 }; wait; die "Error $?" if ($?); } else { exec(@_) || die "Cannot exec".join(' ',@_).":$!"; } } Tk-804.031/TList/000755 001750 001750 00000000000 12150132176 014124 5ustar00eserteeserte000000 000000 Tk-804.031/sm000644 001750 001750 00000004620 11400162254 013426 0ustar00eserteeserte000000 000000 after cancel afterCancel cancelAfter after idle afterIdle idleAfter clipboard append clipboardAppend appendClipboard clipboard clear clipboardClear clearClipboard grab current grabCurrent currentGrab grab release grabRelease releaseGrab grab set grabSet setGrab grab status grabStatus statusGrab image create imageCreate createImage image delete imageDelete deleteImage image height imageHeight heightImage image names imageNames namesImage image type imageType typeImage image types imageTypes typesImage image width imageWidth widthImage option add optionAdd addOption option clear optionClear clearOption option get optionGet getOption option readfile optionReadfile readfileOption pack after packAfter afterPack pack append packAppend appendPack pack before packBefore beforePack pack configure packConfigure configurePack pack forget packForget forgetPack pack info packInfo infoPack pack propagate packPropagate propagatePack pack slaves packSlaves slavesPack pack unpack packUnpack unpackPack place configure placeConfigure configurePlace place forget placeForget forgetPlace place info placeInfo infoPlace place slaves placeSlaves slavesPlace property delete propertyDelete deleteProperty property exists propertyExists existsProperty property get propertyGet getProperty property list propertyList listProperty property set propertySet setProperty selection clear selectionClear clearSelection selection get selectionGet getSelection selection handle selectionHandle handleSelection selection own selectionOwn ownSelection tk appname tkAppname appnameTk tkwait variable waitVariable variableWait tkwait visibility waitVisibility visibilityWait tkwait window waitWindow windowWait update idletasks updateIdletasks idletasksUpdate Tk-804.031/symbols000755 001750 001750 00000001323 11400162254 014477 0ustar00eserteeserte000000 000000 #!/usr/local/bin/perl -w use Config; $nm_opt = ""; $nm_opt = "-g" if ($Config{'osname'} eq 'sunos'); $nm_opt = "-px" if ($Config{'osname'} eq 'solaris'); chomp(@so_files = `find blib -name '*.so' -print`); %sym = (); foreach $module (@so_files) { my ($leaf) = ($module =~ m#/([^/]+)\.so$#); foreach (`nm $nm_opt $module`) { if (/^(0x)?[0-9a-f]{8}\s+([A-Z])\s+_?(.*)$/) { my ($kind,$name) = ($2,$3); if ($kind ne 'U') { $sym{$name} = [] unless (exists $sym{$name}); push(@{$sym{$name}},$leaf,$kind); } } } } foreach $name (sort keys %sym) { my @def = @{$sym{$name}}; if (@def != 2) { print "$name defined ",join(',',@def),"\n"; } } Tk-804.031/mkExt000755 001750 001750 00000001345 11400161414 014100 0ustar00eserteeserte000000 000000 #!/usr/local/bin/perl -w sub translate { my ($src,$dst,$ext,$ref) = @_; $ref = "\L$ref"; my $Ref = "\u$ref"; open(TEXT,"<$src") || die "Cannot open $src:$!"; open(MINE,">$dst") || die "Cannot open $dst:$!"; while () { s/\b$Ref\b/$ext/g; s/${Ref}Cmd/${ext}Cmd/g; s/\b$ref\b/\L$ext/g; print MINE $_; } close(TEXT); close(MINE); } sub mkExt {my ($ref,$ext) = @_; mkdir($ext,0777) unless (-d $ext); if (-f "Tk/$ext.pm") { rename("Tk/$ext.pm","$ext/$ext.pm"); } translate("$ref/GNUmakefile","$ext/GNUmakefile",$ext,$ref); translate("$ref/Makefile.PL","$ext/Makefile.PL",$ext,$ref); translate("$ref/$ref.xs","$ext/$ext.xs",$ext,$ref); } my $ref = shift; foreach $ext (@ARGV) { mkExt($ref,$ext); } Tk-804.031/InputO/000755 001750 001750 00000000000 12150132176 014303 5ustar00eserteeserte000000 000000 Tk-804.031/IO/000755 001750 001750 00000000000 12150132174 013372 5ustar00eserteeserte000000 000000 Tk-804.031/WinPhoto/000755 001750 001750 00000000000 12150132176 014634 5ustar00eserteeserte000000 000000 Tk-804.031/Text/000755 001750 001750 00000000000 12150132175 014010 5ustar00eserteeserte000000 000000 Tk-804.031/HList/000755 001750 001750 00000000000 12150132176 014110 5ustar00eserteeserte000000 000000 Tk-804.031/Mwm/000755 001750 001750 00000000000 12150132176 013625 5ustar00eserteeserte000000 000000 Tk-804.031/encGlue.c000644 001750 001750 00000051771 11705121730 014625 0ustar00eserteeserte000000 000000 /* Copyright (c) 2000-2004 Nick Ing-Simmons. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. */ #define PERL_NO_GET_CONTEXT #include #include #include #ifdef HAS_NL_LANGINFO #include #endif #define U8 U8 #include "tkGlue.def" #include "pTk/tkPort.h" #include "pTk/tkInt.h" #include "tkGlue.h" #ifdef WIN32 #include "pTk/tkWinInt.h" #endif #ifdef SvUTF8 #ifndef utf8_to_uv #define utf8_to_uv utf8_to_uvchr #endif #ifndef UTF8_MAXBYTES_CASE #define UTF8_MAXBYTES_CASE UTF8_MAXLEN_UCLC #endif /* -------------------------------------------------------------------------- */ /* UTF8-ness routines /* -------------------------------------------------------------------------- */ int Tcl_UtfCharComplete(str, len) CONST char *str; /* String to check if first few bytes * contain a complete UTF-8 character. */ int len; /* Length of above string in bytes. */ { return len >= UTF8SKIP((U8 *) str); } Tcl_UniChar Tcl_UniCharToUpper(int ch) { dTHX; U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; STRLEN len; return Perl_to_uni_upper(aTHX_ ch, tmpbuf, &len); } Tcl_UniChar Tcl_UniCharToLower(int ch) { dTHX; U8 tmpbuf[UTF8_MAXBYTES_CASE+1]; STRLEN len; return Perl_to_uni_lower(aTHX_ ch, tmpbuf, &len); } int Tcl_UniCharIsAlpha(int ch) { dTHX; return Perl_is_uni_alpha(aTHX_ ch); } int Tcl_UniCharIsWordChar(int ch) { dTHX; return Perl_is_uni_alnum(aTHX_ ch); } int Tcl_UniCharIsSpace(int ch) { dTHX; return Perl_is_uni_space(aTHX_ ch); } int Tcl_UniCharIsUpper(int ch) { dTHX; return Perl_is_uni_upper(aTHX_ ch); } int Tcl_NumUtfChars(CONST char * src, int len) { U8 *s = (U8 *) src; U8 *send; if (len < 0) len = strlen(src); send = s + len; len = 0; while (s < send) { s += UTF8SKIP(s); len++; } return len; } CONST char * Tcl_UtfNext (CONST char * src) { CONST U8 *s = (CONST U8 *) src; if (*s) src += UTF8SKIP(s); return src; } CONST char * Tcl_UtfPrev (CONST char * src,CONST char * start) { dTHX; U8 *s = (U8 *) src; if (src > start) return (CONST char *) Perl_utf8_hop(aTHX_ s,-1); else return (CONST char *) s; } CONST char * Tcl_UtfAtIndex (CONST char * src, int index) { dTHX; U8 *s = (U8 *) src; return (CONST char*)Perl_utf8_hop(aTHX_ s,index); } int Tcl_UtfToUniChar (CONST char * src,Tcl_UniChar * chPtr) { dTHX; #if defined(utf8_to_uvchr) STRLEN len; *chPtr = utf8_to_uv((U8 *)src,&len); #else I32 len; *chPtr = utf8_to_uv((U8 *)src,&len); #endif return len; } int Tcl_UniCharToUtf(int ch, char * buf) { dTHX; /* We "allow any" as the page cache algorithm hits at least U+FFFE */ #ifdef UNICODE_ALLOW_ANY U8 *p = uvchr_to_utf8_flags((U8 *) buf,ch, UNICODE_ALLOW_ANY); #else U8 *p = Perl_uv_to_utf8(aTHX_ (U8 *) buf,ch); #endif return p - (U8 *) buf; } char * Tcl_UniCharToUtfDString(wString, numChars, dsPtr) CONST Tcl_UniChar *wString; /* Unicode string to convert to UTF-8. */ int numChars; /* Length of Unicode string in Tcl_UniChars * (must be >= 0). */ Tcl_DString *dsPtr; /* UTF-8 representation of string is * appended to this previously initialized * DString. */ { CONST Tcl_UniChar *w, *wEnd; char *p, *string; int oldLength; /* * UTF-8 string length in bytes will be <= Unicode string length * * TCL_UTF_MAX. */ oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, (oldLength + numChars + 1) * UTF8_MAXBYTES_CASE); string = Tcl_DStringValue(dsPtr) + oldLength; p = string; wEnd = wString + numChars; for (w = wString; w < wEnd; ) { p += Tcl_UniCharToUtf(*w, p); w++; } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; } Tcl_UniChar * Tcl_UtfToUniCharDString(string, length, dsPtr) CONST char *string; /* UTF-8 string to convert to Unicode. */ int length; /* Length of UTF-8 string in bytes, or -1 * for strlen(). */ Tcl_DString *dsPtr; /* Unicode representation of string is * appended to this previously initialized * DString. */ { Tcl_UniChar *w, *wString; CONST char *p, *end; int oldLength; if (length < 0) { length = strlen(string); } /* * Unicode string length in Tcl_UniChars will be <= UTF-8 string length * in bytes. */ oldLength = Tcl_DStringLength(dsPtr); Tcl_DStringSetLength(dsPtr, (int) ((oldLength + length + 1) * sizeof(Tcl_UniChar))); wString = (Tcl_UniChar *) (Tcl_DStringValue(dsPtr) + oldLength); w = wString; end = string + length; for (p = string; p < end; ) { p += Tcl_UtfToUniChar(p, w); w++; } *w = '\0'; Tcl_DStringSetLength(dsPtr, (oldLength + ((char *) w - (char *) wString))); return wString; } int Tcl_UniCharLen(str) CONST Tcl_UniChar *str; /* Unicode string to find length of. */ { int len = 0; while (*str != '\0') { len++; str++; } return len; } /* Doing these in-place seems risky ... */ int Tcl_UtfToLower (char * src) { dTHX; U8 *s = (U8 *)src; U8 *d = s; while (*s) { STRLEN len; Perl_to_utf8_lower(aTHX_ s, d, &len ); d += len; s += len; } *d = '\0'; return (d-(U8 *)src); } int Tcl_UtfToUpper(char * src) { dTHX; U8 *s = (U8 *)src; U8 *d = s; while (*s) { STRLEN len; Perl_to_utf8_upper(aTHX_ s, d, &len ); d += len; s += len; } *d = '\0'; return (d-(U8 *)src); } #else /* -------------------------------------------------------------------------- */ /* Dummy UTF8-ness routines /* -------------------------------------------------------------------------- */ Tcl_UniChar Tcl_UniCharToUpper(int ch) { return toupper(ch); } Tcl_UniChar Tcl_UniCharToLower(int ch) { return tolower(ch); } int Tcl_UniCharIsAlpha(int ch) { return isalpha(ch); } int Tcl_UniCharIsUpper(int ch) { return isupper(ch); } int Tcl_NumUtfChars(CONST char * src, int len) { if (len < 0) return strlen(src); return len; } int Tcl_UtfToLower (char * src) { char *s = src; int n = 0; while (*s) { *s = tolower(UCHAR(*s)); s++; } *s = '\0'; return (s-src); } int Tcl_UtfToUpper(char * src) { char *s = src; int n = 0; while (*s) { *s = toupper(UCHAR(*s)); s++; } *s = '\0'; return (s-src); } CONST char * Tcl_UtfNext (CONST char * src) { return src+1; } char * Tcl_UtfPrev (CONST char * src,CONST char * start) { if (src > start) src--; return (char *)src; } char * Tcl_UtfAtIndex (CONST char * src, int index) { return (char*)src+index; } int Tcl_UtfToUniChar (CONST char * src,Tcl_UniChar * chPtr) { *chPtr = *src; return 1; } int Tcl_UniCharToUtf(int ch, char * buf) { *buf = ch; return 1; } #endif /* SvUTF8 */ /* *---------------------------------------------------------------------- * * Tcl_StringMatch -- * * See if a particular string matches a particular pattern. * * Results: * The return value is 1 if string matches pattern, and * 0 otherwise. The matching operation permits the following * special characters in the pattern: *?\[] (see the manual * entry for details on what these mean). * * Side effects: * None. * *---------------------------------------------------------------------- */ int Tcl_StringMatch(string, pattern) CONST char *string; /* String. */ CONST char *pattern; /* Pattern, which may contain special * characters. */ { int p, s; CONST char *pstart = pattern; while (1) { p = *pattern; s = *string; /* * See if we're at the end of both the pattern and the string. If * so, we succeeded. If we're at the end of the pattern but not at * the end of the string, we failed. */ if (p == '\0') { if (s == '\0') { return 1; } else { return 0; } } if ((s == '\0') && (p != '*')) { return 0; } /* Check for a "*" as the next pattern character. It matches * any substring. We handle this by calling ourselves * recursively for each postfix of string, until either we * match or we reach the end of the string. */ if (p == '*') { pattern++; if (*pattern == '\0') { return 1; } while (1) { if (Tcl_StringMatch(string, pattern)) { return 1; } if (*string == '\0') { return 0; } string++; } } /* Check for a "?" as the next pattern character. It matches * any single character. */ if (p == '?') { Tcl_UniChar ch; pattern++; string += Tcl_UtfToUniChar(string, &ch); continue; } /* Check for a "[" as the next pattern character. It is followed * by a list of characters that are acceptable, or by a range * (two characters separated by "-"). */ if (p == '[') { Tcl_UniChar ch, startChar, endChar; pattern++; string += Tcl_UtfToUniChar(string, &ch); while (1) { if ((*pattern == ']') || (*pattern == '\0')) { return 0; } pattern += Tcl_UtfToUniChar(pattern, &startChar); if (*pattern == '-') { pattern++; if (*pattern == '\0') { return 0; } pattern += Tcl_UtfToUniChar(pattern, &endChar); if (((startChar <= ch) && (ch <= endChar)) || ((endChar <= ch) && (ch <= startChar))) { /* * Matches ranges of form [a-z] or [z-a]. */ break; } } else if (startChar == ch) { break; } } while (*pattern != ']') { if (*pattern == '\0') { pattern = Tcl_UtfPrev(pattern, pstart); break; } pattern++; } pattern++; continue; } /* If the next pattern character is '\', just strip off the '\' * so we do exact matching on the character that follows. */ if (p == '\\') { pattern++; p = *pattern; if (p == '\0') { return 0; } } /* There's no special character. Just make sure that the next * bytes of each string match. */ if (s != p) { return 0; } pattern++; string++; } } static HV *encodings = NULL; Tcl_Encoding system_encoding = NULL; Tcl_Encoding GetSystemEncoding(void) { if (!system_encoding) { char *codeset = NULL; /* This assumes perl's Configure probe stuff is #include-d above */ #if defined(HAS_NL_LANGINFO) && defined(CODESET) codeset = nl_langinfo(CODESET); #endif if (!codeset) codeset = "iso8859-1"; system_encoding = Tcl_GetEncoding(NULL,codeset); if (!system_encoding) system_encoding = Tcl_GetEncoding(NULL,"iso8859-1"); } return system_encoding; } #define PerlEncObj(enc) (HeVAL((HE *) (enc))) SV * Lang_SystemEncoding(void) { dTHX; return SvREFCNT_inc(PerlEncObj(GetSystemEncoding())); } Tcl_Encoding Tcl_GetEncoding (Tcl_Interp * interp, CONST char * name) { dTHX; HE *he; STRLEN len = strlen(name); SV *sv = NULL; SV *nmsv = newSVpv((char *)name,len); if (!encodings) { encodings = newHV(); } he = hv_fetch_ent(encodings,nmsv,0,0); if (!he || !HeVAL(he)) { dSP; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(sv_2mortal(newSVpv("Tk",0))); XPUSHs(nmsv); PUTBACK; perl_call_method("getEncoding",G_SCALAR); SPAGAIN; sv = POPs; PUTBACK; he = hv_store_ent(encodings,nmsv,newSVsv(sv),0); if (0 && !SvOK(sv)) warn("Cannot find '%s'",name); FREETMPS; LEAVE; } SvREFCNT_dec(nmsv); sv = HeVAL(he); if (sv_isobject(sv)) { SvREFCNT_inc(sv); return (Tcl_Encoding) he; } else { if (SvOK(sv)) warn("Strange encoding %"SVf,sv); } return NULL; } Tcl_Encoding Lang_CreateEncoding(CONST char *encodingName, Tcl_EncodingConvertProc *toUtfProc, Tcl_EncodingConvertProc *fromUtfProc, Tcl_EncodingFreeProc *freeProc, ClientData clientData, int nullSize) { return Tcl_GetEncoding(NULL,encodingName); } void Tcl_FreeEncoding (Tcl_Encoding t) { if (t) { dTHX; HE *he = (HE *) t; SV *sv = HeVAL(he); SvREFCNT_dec(sv); } } CONST char * Tcl_GetEncodingName(Tcl_Encoding encoding) { dTHX; HE *he; STRLEN len; if (!encoding) encoding = GetSystemEncoding(); he = (HE *) encoding; return HePV(he,len); } static int CallEncode(Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr, const char *method) { dTHX; int srcRead; int dstWrote; int dstChars; int code = TCL_OK; U8 *s = (U8 *) src; U8 *send; U8 *d = (U8 *) dst; U8 *dend; int chars = 0; dSP; SV *quiet; SV *stmp; SV *dtmp; char *td; STRLEN dbytes; if (flags & TCL_ENCODING_STOPONERROR) quiet = get_sv("Tk::encodeStopOnError",0); else quiet = get_sv("Tk::encodeFallback",0); if (!encoding) encoding = GetSystemEncoding(); if (!sv_isobject(PerlEncObj(encoding))) abort(); if (!srcReadPtr) srcReadPtr = &srcRead; if (!dstWrotePtr) dstWrotePtr = &dstWrote; if (!dstCharsPtr) dstCharsPtr = &dstChars; else { LangDebug("%s wants char count\n",method); } if (!src) srcLen = 0; if (srcLen < 0) srcLen = strlen(src); send = s+srcLen; dstLen -= 2; dend = d + dstLen; stmp = newSV(srcLen); while (s < send) { STRLEN len = srcLen; if (*method == 'e') { #if 0 /* We used to do things one char at a time ... can't remember why perhaps to handle partial chars ? we got perl to tell us length of one char using call below Only makes sense for encode when source is UTF-8, though by luck it worked for "decode" of UTF-8 as well provided we did not set SvUTF8_on which upset Encode.xs */ UV ch = utf8n_to_uvchr(s, send-s, &len, UTF8_ALLOW_ANY|UTF8_CHECK_ONLY); #endif sv_setpvn(stmp,s,len); if (has_highbit(s,len)) SvUTF8_on(stmp); } else { sv_setpvn(stmp,s,len); } SPAGAIN; PUSHMARK(sp); XPUSHs(PerlEncObj(encoding)); XPUSHs(stmp); XPUSHs(quiet); PUTBACK; perl_call_method(method,G_SCALAR|G_EVAL); if (SvTRUE(ERRSV)) { code = TCL_ERROR; if (interp) { Tcl_SetResult(interp,SvPV_nolen(ERRSV),TCL_VOLATILE); } else { warn("%"SVf,ERRSV); } break; } SPAGAIN; dtmp = POPs; PUTBACK; #if 0 /* XXX This code seems to be wrong since Encode 2.10, when LEAVE_SRC was * default (is this true?). * This would fix the "selection conversion left too many bytes unconverted" * aborts. */ if (SvCUR(stmp)) { /* This could also be TCL_CONVERT_MULTIBYTE - how do we tell ? */ code = TCL_CONVERT_UNKNOWN; break; } #endif td = SvPV(dtmp,dbytes); if (!dbytes) { code = TCL_CONVERT_UNKNOWN; break; } if (d+dbytes > dend) { code = TCL_CONVERT_NOSPACE; dbytes = dend-d; break; } memcpy(d,td,dbytes); d += dbytes; /* FIXME? : Char count is bogus unless we do one-at-atime - if we find something that wants it we need to get it some other way - e.g. UTF8_SKIP()ing over whichever of src/dst is UTF-8 */ chars++; s += len; } SvREFCNT_dec(stmp); *srcReadPtr = (s - (U8 *)src); *dstCharsPtr = chars; dst[dstLen] = '\0'; dst[dstLen+1] = '\0'; /* If dest is wide single '\0' may not be enough */ Zero(d,dend-d,char); *dstWrotePtr = (d- (U8 *)dst); return code; } int Tcl_ExternalToUtf (Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr) { return CallEncode(interp,encoding,src,srcLen,flags,statePtr,dst,dstLen, srcReadPtr,dstWrotePtr,dstCharsPtr,"decode"); } int Tcl_UtfToExternal(Tcl_Interp * interp, Tcl_Encoding encoding, CONST char * src, int srcLen, int flags, Tcl_EncodingState * statePtr, char * dst, int dstLen, int * srcReadPtr, int * dstWrotePtr, int * dstCharsPtr) { return CallEncode(interp,encoding,src,srcLen,flags,statePtr,dst,dstLen, srcReadPtr,dstWrotePtr,dstCharsPtr,"encode"); } char * Tcl_UtfToExternalDString(Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr) { dTHX; dSP; SV *sv; char *s = ""; STRLEN len = 0; SV *fallback = get_sv("Tk::encodeFallback",0); Tcl_DStringInit(dsPtr); if (!encoding) encoding = GetSystemEncoding(); if (!src) srcLen = 0; if (srcLen < 0) srcLen = strlen(src); if (srcLen) { int count; SPAGAIN; ENTER; SAVETMPS; PUSHMARK(sp); XPUSHs(PerlEncObj(encoding)); sv = newSV(srcLen); sv_setpvn(sv,src,srcLen); sv_maybe_utf8(sv); XPUSHs(sv_2mortal(sv)); XPUSHs(fallback); PUTBACK; count = perl_call_method("encode",G_SCALAR); SPAGAIN; if (count > 0) { sv = POPs; PUTBACK; if (sv && SvPOK(sv)) s = SvPV(sv,len); } else { LangDebug("Encode did not return a value:%s\n",SvPV_nolen(ERRSV)); } Tcl_DStringAppend(dsPtr,s,len); FREETMPS; LEAVE; } else { Tcl_DStringAppend(dsPtr,"\0",1); } /* Perl has appended a \0 for us, but that may not be enough if encoding is "wide" */ Tcl_DStringAppend(dsPtr,"\0\0\0",3); Tcl_DStringSetLength(dsPtr,len); return Tcl_DStringValue(dsPtr); } char * Tcl_ExternalToUtfDString(Tcl_Encoding encoding, CONST char * src, int srcLen, Tcl_DString * dsPtr) { dTHX; dSP; SV *sv; char *s; STRLEN len; if (!encoding) encoding = GetSystemEncoding(); SPAGAIN; ENTER; SAVETMPS; if (!src) srcLen = 0; if (srcLen < 0) { /* FIXME - this is supposed to be based on size of encoding's thingies ! */ #ifdef WIN32 if (encoding == TkWinGetUnicodeEncoding()) { srcLen = sizeof(Tcl_UniChar)*Tcl_UniCharLen((Tcl_UniChar *) src); } else #endif srcLen = strlen(src); } SPAGAIN; PUSHMARK(sp); XPUSHs(PerlEncObj(encoding)); sv = newSV(srcLen); sv_setpvn(sv,src,srcLen); XPUSHs(sv_2mortal(sv)); PUTBACK; perl_call_method("decode",G_SCALAR); SPAGAIN; sv = POPs; PUTBACK; s = SvPV(sv,len); Tcl_DStringInit(dsPtr); Tcl_DStringAppend(dsPtr,s,len); FREETMPS; LEAVE; return Tcl_DStringValue(dsPtr); } #if defined(WIN32) || (defined(__WIN32__) && defined(__CYGWIN__)) /* *--------------------------------------------------------------------------- * * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- * * Convert between UTF-8 and Unicode when running Windows NT or * the current ANSI code page when running Windows 95. * * On Mac, Unix, and Windows 95, all strings exchanged between Tcl * and the OS are "char" oriented. We need only one Tcl_Encoding to * convert between UTF-8 and the system's native encoding. We use * NULL to represent that encoding. * * On NT, some strings exchanged between Tcl and the OS are "char" * oriented, while others are in Unicode. We need two Tcl_Encoding * APIs depending on whether we are targeting a "char" or Unicode * interface. * * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an * encoding of NULL should always used to convert between UTF-8 * and the system's "char" oriented encoding. The following two * functions are used in Windows-specific code to convert between * UTF-8 and Unicode strings (NT) or "char" strings(95). This saves * you the trouble of writing the following type of fragment over and * over: * * if (running NT) { * encoding <- Tcl_GetEncoding("unicode"); * nativeBuffer <- UtfToExternal(encoding, utfBuffer); * Tcl_FreeEncoding(encoding); * } else { * nativeBuffer <- UtfToExternal(NULL, utfBuffer); * } * * By convention, in Windows a TCHAR is a character in the ANSI code * page on Windows 95, a Unicode character on Windows NT. If you * plan on targeting a Unicode interfaces when running on NT and a * "char" oriented interface while running on 95, these functions * should be used. If you plan on targetting the same "char" * oriented function on both 95 and NT, use Tcl_UtfToExternal() * with an encoding of NULL. * * Results: * The result is a pointer to the string in the desired target * encoding. Storage for the result string is allocated in * dsPtr; the caller must call Tcl_DStringFree() when the result * is no longer needed. * * Side effects: * None. * *--------------------------------------------------------------------------- */ static Tcl_Encoding tclWinTCharEncoding; void TclWinSetInterfaces( int wide) /* Non-zero to use wide interfaces, 0 * otherwise. */ { Tcl_FreeEncoding(tclWinTCharEncoding); if (wide) { tclWinTCharEncoding = Tcl_GetEncoding(NULL, "unicode"); } else { tclWinTCharEncoding = NULL; } } TCHAR * Tcl_WinUtfToTChar(string, len, dsPtr) CONST char *string; /* Source string in UTF-8. */ int len; /* Source string length in bytes, or < 0 for * strlen(). */ Tcl_DString *dsPtr; /* Uninitialized or free DString in which * the converted string is stored. */ { TCHAR *res = (TCHAR *) Tcl_UtfToExternalDString(tclWinTCharEncoding, string, len, dsPtr); return res; } char * Tcl_WinTCharToUtf(string, len, dsPtr) CONST TCHAR *string; /* Source string in Unicode when running * NT, ANSI when running 95. */ int len; /* Source string length in bytes, or < 0 for * platform-specific string length. */ Tcl_DString *dsPtr; /* Uninitialized or free DString in which * the converted string is stored. */ { return Tcl_ExternalToUtfDString(tclWinTCharEncoding, (CONST char *) string, len, dsPtr); } #endif Tk-804.031/uninstall000755 001750 001750 00000001725 11400162254 015026 0ustar00eserteeserte000000 000000 #!/usr/local/bin/perl -w BEGIN {exec('perl5.002',$0,@ARGV) unless ($] >= 5.002)} use Config; use Getopt::Long; $opt_perl = ""; $opt_site = ""; $opt_man = ""; GetOptions('site','perl','inc','man'); my %dirs = (); sub maybe { foreach (@_) { $dirs{$_} = 0 if (defined($_) && -d $_ && !exists $dirs{$_}); } } maybe($Config{'installarchlib'},$Config{'installprivlib'}) if ($opt_perl); maybe($Config{'installsitearch'},$Config{'installsitelib'}) if ($opt_site); my %done = (); my $dir; foreach $dir (keys %dirs) { my $file; foreach $file ('Tk.pm','Tk','auto/Tk') { my $path = "$dir/$file"; next if (exists $done{$path}); $done{$path} = 0; if (-f $path) { print "rm -f $path\n"; } elsif (-d $path) { print "rm -rf $path\n"; } } } if ($opt_man) { my $path; foreach $path (<$Config{'installman3dir'}/Tk::*.$Config{'man3ext'}>) { if (-f $path) { print "rm -f $path\n"; } } } Tk-804.031/vtab.def000644 001750 001750 00000010045 11400162272 014476 0ustar00eserteeserte000000 000000 #define IMPORT_VTABLE(ptr,type,name) do { \ ptr = INT2PTR(type *,SvIV(get_sv(name,GV_ADDWARN|GV_ADD))); \ if ((*ptr->tabSize)() != sizeof(type)) { \ Perl_warn(aTHX_ "%s wrong size for %s",name,#type); \ } \ } while (0) #ifdef WIN32 #define DECLARE_VTABLES \ LangVtab *LangVptr; \ TcldeclsVtab *TcldeclsVptr; \ TkVtab *TkVptr; \ TkdeclsVtab *TkdeclsVptr; \ TkeventVtab *TkeventVptr; \ TkglueVtab *TkglueVptr; \ TkintVtab *TkintVptr; \ TkintdeclsVtab *TkintdeclsVptr; \ TkintplatdeclsVtab *TkintplatdeclsVptr;\ TkintxlibdeclsVtab *TkintxlibdeclsVptr;\ TkoptionVtab *TkoptionVptr; \ TkplatdeclsVtab *TkplatdeclsVptr #define IMPORT_VTABLES do { \ IMPORT_VTABLE(LangVptr , LangVtab,"Tk::LangVtab"); \ IMPORT_VTABLE(TcldeclsVptr , TcldeclsVtab,"Tk::TcldeclsVtab"); \ IMPORT_VTABLE(TkVptr , TkVtab,"Tk::TkVtab"); \ IMPORT_VTABLE(TkdeclsVptr , TkdeclsVtab,"Tk::TkdeclsVtab"); \ IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \ IMPORT_VTABLE(TkglueVptr , TkglueVtab,"Tk::TkglueVtab"); \ IMPORT_VTABLE(TkintVptr , TkintVtab,"Tk::TkintVtab"); \ IMPORT_VTABLE(TkintdeclsVptr , TkintdeclsVtab,"Tk::TkintdeclsVtab"); \ IMPORT_VTABLE(TkintplatdeclsVptr,TkintplatdeclsVtab,"Tk::TkintplatdeclsVtab"); \ IMPORT_VTABLE(TkintxlibdeclsVptr,TkintxlibdeclsVtab,"Tk::TkintxlibdeclsVtab"); \ IMPORT_VTABLE(TkoptionVptr , TkoptionVtab,"Tk::TkoptionVtab"); \ IMPORT_VTABLE(TkplatdeclsVptr , TkplatdeclsVtab,"Tk::TkplatdeclsVtab"); \ } while (0) #else #define DECLARE_VTABLES \ LangVtab *LangVptr; \ TcldeclsVtab *TcldeclsVptr; \ TkVtab *TkVptr; \ TkdeclsVtab *TkdeclsVptr; \ TkeventVtab *TkeventVptr; \ TkglueVtab *TkglueVptr; \ TkintVtab *TkintVptr; \ TkintdeclsVtab *TkintdeclsVptr; \ TkoptionVtab *TkoptionVptr; \ XlibVtab *XlibVptr #define IMPORT_VTABLES do { \ IMPORT_VTABLE(LangVptr , LangVtab,"Tk::LangVtab"); \ IMPORT_VTABLE(TcldeclsVptr , TcldeclsVtab,"Tk::TcldeclsVtab"); \ IMPORT_VTABLE(TkVptr , TkVtab,"Tk::TkVtab"); \ IMPORT_VTABLE(TkdeclsVptr , TkdeclsVtab,"Tk::TkdeclsVtab"); \ IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \ IMPORT_VTABLE(TkglueVptr , TkglueVtab,"Tk::TkglueVtab"); \ IMPORT_VTABLE(TkintVptr , TkintVtab,"Tk::TkintVtab"); \ IMPORT_VTABLE(TkintdeclsVptr , TkintdeclsVtab,"Tk::TkintdeclsVtab"); \ IMPORT_VTABLE(TkoptionVptr , TkoptionVtab,"Tk::TkoptionVtab"); \ IMPORT_VTABLE(XlibVptr , XlibVtab,"Tk::XlibVtab"); \ } while (0) #endif #define DECLARE_TIX \ TixVtab *TixVptr; \ TixintVtab *TixintVptr #define IMPORT_TIX do { \ IMPORT_VTABLE(TixVptr , TixVtab,"Tk::TixVtab"); \ IMPORT_VTABLE(TixintVptr , TixintVtab,"Tk::TixintVtab"); \ } while (0) #define DECLARE_PHOTO \ ImgintVtab *ImgintVptr; \ TkimgphotoVtab *TkimgphotoVptr #define IMPORT_PHOTO do { \ IMPORT_VTABLE(ImgintVptr , ImgintVtab,"Tk::ImgintVtab"); \ IMPORT_VTABLE(TkimgphotoVptr , TkimgphotoVtab,"Tk::TkimgphotoVtab"); \ } while (0) #define DECLARE_EVENT \ TkeventVtab *TkeventVptr #define IMPORT_EVENT do { \ IMPORT_VTABLE(TkeventVptr , TkeventVtab,"Tk::TkeventVtab"); \ } while (0) #define DECLARE_TIXXPM \ TiximgxpmVtab *TiximgxpmVptr #define IMPORT_TIXXPM do { \ IMPORT_VTABLE(TiximgxpmVptr , TiximgxpmVtab,"Tk::TiximgxpmVtab"); \ } while (0) Tk-804.031/README.AIX000644 001750 001750 00000001031 11400162220 014346 0ustar00eserteeserte000000 000000 As of perl5.002b1f the MakeMaker shipped with perl moans a lot building dynamic loaded extension on AIX. They have been reported to work. There may be 'make install' problems too. Getting latest MakeMaker from CPAN may help. Tk800.018 was giving core dumps with some compilers: James Walden Reports: I fixed the problem by upgrading to from VAC 4.4.0.0 to 4.4.0.2. This might be worth adding to the README for AIX. > lslpp -L | grep -i vac vac.C 4.4.0.2 A C for AIX Compiler Tk-804.031/MANIFEST.SKIP.PL000755 001750 001750 00000004321 12146672671 015316 0ustar00eserteeserte000000 000000 #!/usr/local/bin/nperl -w use File::Find; use File::Basename; my %skip; my %files; my %maybe; sub wanted { my $s = $File::Find::name; $s =~ s#^\./##; return if $s =~ m#^\.pc/#; # quilt state dir $files{$s} = 1 if (-f $_); if (/\.xs$/) { $s =~ s#\.xs$#.c#; $skip{$s} = 1; } if ($s =~ m#^((.*)/mTk/.*?)/([^/]+\.[ch])$#x) { $maybe{$1}{$3} = $2 unless $_ eq 'Xlib.h'; } } find(\&wanted,'.'); foreach my $dir (sort keys %maybe) { if (open(INC,"$dir/pTk.inc")) { warn "Reading $dir/pTk.inc\n"; my %only; while () { $only{$1} = 1 if (/(\S+)/); } close(INC); foreach my $name (keys %{$maybe{$dir}}) { delete $maybe{$dir}{$name} unless exists $only{$name}; } } elsif (open(EXC,"$dir/pTk.exc")) { warn "Reading $dir/pTk.exc\n"; while () { delete $maybe{$dir}{$1} if /(\S+)/; } close(EXC); } foreach my $name (sort keys %{$maybe{$dir}}) { my $wh = $maybe{$dir}{$name}; $skip{"$wh/$name"} = 1; } } chmod(0644,"MANIFEST.SKIP"); open(SKIP,">MANIFEST.SKIP") || die "Cannot open MANIFEST.SKIP:$!"; print SKIP <<'EOF' \.[oaid]$ \.(bso?|old|bak|bck|base|exp|broke|out|hide|q4|gz|tcl|rtf|orig)$ ^\. /\. C\+\+/Main$ \bcore$ \bConfig.pm$ \bpTk/tkConfig\.h$ \bpTk/(need|canvas_sources)$ \b(pm_to_blib|blibdirs|perl|wedge|efdebug)$ [%~]$ \b(blib|merge|Ilya|Pixmap|patches|pod2)/ \bTix/ tcl\.pm$ \bcore\b Canvas/diag\.txt$ pod/html$ \bdoc/ Tk.ppd$ \b(ToDo|learn|Pending|Obsolete)/ \b(GNU)?[Mm]akefile(\.aperl)?$ -bug$ \bperlmain\.c$ \btkperl\b \bHTML/doc\b \bEvent/Play\b \bEvent/fe pod/tkman.ps$ extralibs\.ld doc/index\.html$ doc/MANFILES$ doc/.*\.htm$ myConfig\.out \bMYMETA.yml$ \bMYMETA.json$ JPEG/jpeg/testout* JPEG/jpeg/config\.(log|status) JPEG/jpeg/([cd]jpeg|jpegtran|(rd|wr)jpgcom) JPEG/jpeg/Makefile\.PL$ PNG/libpng/Makefile\.PL$ PNG/libpng/pngtest$ PNG/libpng/config.h$ PNG/libpng/config.log$ PNG/libpng/config.status$ PNG/libpng/libpng-config$ PNG/libpng/libpng.pc$ PNG/libpng/libtool$ PNG/libpng/stamp-h1$ PNG/zlib/example$ PNG/zlib/Makefile\.PL$ PNG/zlib/minigzip$ \.todo$ \bswapm$ bin/patchls$ JPEG/jpeg/jconfig.h$ prep_rel$ EOF ; foreach (sort keys %skip) { s#\.#\\.#; print SKIP "$_\$\n"; } close(SKIP); Tk-804.031/exetype000644 001750 001750 00000002741 11400162221 014466 0ustar00eserteeserte000000 000000 #!perl -w use strict; unless (@ARGV == 2) { print "Usage: $0 exefile [CONSOLE|WINDOWS]\n"; exit; } unless ($ARGV[1] =~ /^(console|windows)$/i) { print "Invalid subsystem $ARGV[1], please use CONSOLE or WINDOWS\n"; exit; } my ($record,$magic,$offset,$size); open EXE, "+< $ARGV[0]" or die "Cannot open $ARGV[0]: $!"; binmode EXE; read EXE, $record, 32*4; ($magic,$offset) = unpack "Sx58L", $record; die "Not an MSDOS executable file" unless $magic == 0x5a4d; seek EXE, $offset, 0; read EXE, $record, 24; ($magic,$size) = unpack "Lx16S", $record; die "PE header not found" unless $magic == 0x4550; die "Optional header not in NT32 format" unless $size == 224; seek EXE, $offset+24+68, 0; print EXE pack "S", uc($ARGV[1]) eq 'CONSOLE' ? 3 : 2; close EXE; __END__ =head1 NAME exetype - Change executable subsystem type between "Console" and "Windows" =head1 SYNOPSIS C:\perl\bin> copy perl.exe guiperl.exe C:\perl\bin> exetype guiperl.exe windows =head1 DESCRIPTION This program edits an executable file to indicate which subsystem the operating system must invoke for execution. You can specify any of the following subsystems: =over =item CONSOLE The CONSOLE subsystem handles a Win32 character-mode application that use a console supplied by the operating system. =item WINDOWS The WINDOWS subsystem handles an application that does not require a console and creates its own windows, if required. =back =head1 AUTHOR Jan Dubois =cut Tk-804.031/COPYING000644 001750 001750 00000002074 11400162250 014114 0ustar00eserteeserte000000 000000 Copyright (c) 1995-2003 Nick Ing-Simmons. All rights reserved. This package is free software; you can redistribute it and/or modify it under the same terms as Perl itself, with the exception of the files in the pTk sub-directory which have separate terms derived from those of the orignal Tk4.0 sources and/or Tix. IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. See pTk/license.terms for details of this Tk license, and pTk/Tix.license for the Tix license. Tk-804.031/Tk.xs000644 001750 001750 00000047245 11705121720 014031 0ustar00eserteeserte000000 000000 /* Copyright (c) 1995-2004 Nick Ing-Simmons. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. */ #define PERL_NO_GET_CONTEXT #include #include #include #include #include "tkGlue.def" static STRLEN na; /* Quick and dirty fix */ #include "pTk/tkPort.h" #include "pTk/tkInt.h" #include "pTk/tkFont.h" #include "pTk/tkXrm.h" #include "pTk/default.h" #if defined(__WIN32__) && !defined(__EMX__) # include "pTk/tkWinInt.h" #endif #include "tkGlue.h" #ifdef NEED_PRELOAD #ifdef I_DLFCN #include /* the dynamic linker include file for Sunos/Solaris */ #else #include #include #endif #define NeedPreload() 1 #else #define NeedPreload() 0 #endif #define Tk_tainting() (PL_tainting) #define Tk_tainted(sv) ((sv) ? SvTAINTED(sv) : PL_tainted) static void DebugHook(SV *sv) { } #define XEvent_DESTROY(obj) #define Tk_XRaiseWindow(w) XRaiseWindow(Tk_Display(w),Tk_WindowId(w)) #define Const_DONT_WAIT() (TCL_DONT_WAIT) #define Const_WINDOW_EVENTS() (TCL_WINDOW_EVENTS) #define Const_FILE_EVENTS() (TCL_FILE_EVENTS) #define Const_TIMER_EVENTS() (TCL_TIMER_EVENTS) #define Const_IDLE_EVENTS() (TCL_IDLE_EVENTS) #define Const_ALL_EVENTS() (TCL_ALL_EVENTS) #ifndef SELECT_FG /* Should really depend on color/mono */ #define SELECT_FG BLACK #endif #define Const_NORMAL_BG() (NORMAL_BG) #define Const_ACTIVE_BG() (ACTIVE_BG) #define Const_SELECT_BG() (SELECT_BG) #define Const_SELECT_FG() (SELECT_FG) #define Const_TROUGH() (TROUGH) #define Const_INDICATOR() (INDICATOR) #define Const_DISABLED() (DISABLED) #define Const_BLACK() (BLACK) #define Const_WHITE() (WHITE) static XFontStruct * TkwinFont _((Tk_Window tkwin, Tk_Uid name)); #define pTk_Synchronize(win,flag) \ XSynchronize(Tk_Display(win), flag) static IV PointToWindow(Tk_Window tkwin, int x, int y, Window dest) { Display *dpy = Tk_Display(tkwin); Window root = RootWindowOfScreen(Tk_Screen(tkwin)); Window win = None; if (dest == None) dest = root; #ifdef WIN32 { HWND hwnd = (HWND) Tk_GetHWND(dest); RECT r; if (GetWindowRect(hwnd,&r)) { POINT pt; HWND child; pt.x = x - r.left; pt.y = y - r.top; child = ChildWindowFromPoint(hwnd, pt); if (child != hwnd) { TkWindow *winPtr = (TkWindow *) Tk_HWNDToWindow(child); if (winPtr) { win = winPtr->window; } } } return (IV) win; } #else if (!XTranslateCoordinates(dpy, root, dest, x, y, &x, &y, &win)) { win = None; } return (IV) win; #endif } static SV * StringAlias(pTHX_ const char *s) { SV *sv = newSV(0); sv_upgrade(sv,SVt_PV); SvPVX(sv) = (char *) s; SvCUR_set(sv,strlen(s)); SvLEN(sv) = 0; SvPOK_only(sv); SvREADONLY_on(sv); return sv; } typedef struct { CONST char *foundary; CONST char *encoding; TkFontAttributes attrib; const char *name; } LangFontInfo; static SV * FontInfo(pTHX_ const char *encoding, const char *foundary, const TkFontAttributes *attrib, const char *name) { SV *sv = newSV(sizeof(LangFontInfo)); LangFontInfo *info = (LangFontInfo *) SvPVX(sv); SvCUR_set(sv,sizeof(LangFontInfo)); SvPOK_only(sv); info->encoding = encoding; info->foundary = foundary; info->attrib = *attrib; /* FIXME */ info->name = name; return sv_bless(newRV_noinc(sv),gv_stashpv("Tk::FontRankInfo", TRUE)); } #define Boolean int #define FontInfo_encoding(p) (StringAlias(aTHX_ (p)->encoding)) #define FontInfo_foundary(p) (StringAlias(aTHX_ (p)->foundary)) #define FontInfo_Xname(p) (StringAlias(aTHX_ (p)->name)) #define FontInfo_family(p) (StringAlias(aTHX_ (p)->attrib.family)) #define FontInfo_size(p) ((p)->attrib.size) #define FontInfo_bold(p) ((p)->attrib.weight == TK_FW_BOLD) #define FontInfo_italic(p) ((p)->attrib.slant == TK_FS_ITALIC) unsigned int LangFontRank(unsigned int suggested, int ch, CONST char *gotName, CONST char *wantFoundary, CONST TkFontAttributes *wantAttrib, CONST char *wantEncoding, CONST char *gotFoundary, CONST TkFontAttributes *gotAttrib, CONST char *gotEncoding) { dTHX; SV *hook = get_sv("Tk::FontRank",0); if (hook && SvOK(hook)) { dSP; int flags = (suggested == 0 || suggested == (unsigned int) -1) ? G_VOID : G_SCALAR; SV *result, *sv; int count; ENTER; SAVETMPS; LangPushCallbackArgs(&hook); result = Nullsv; sv = newSV(UTF8_MAXLEN); sv_upgrade(sv,SVt_PVIV); #ifdef UNICODE_ALLOW_ANY count = uvchr_to_utf8_flags((U8 *) SvPVX(sv),ch, UNICODE_ALLOW_ANY) - (U8 *) SvPVX(sv); #else count = Perl_uv_to_utf8(aTHX_ (U8 *) SvPVX(sv),ch) - (U8 *) SvPVX(sv); #endif SvCUR_set(sv,count); SvPOK_on(sv); SvUTF8_on(sv); SvIVX(sv) = ch; SvIOK_on(sv); SPAGAIN; XPUSHs(sv_2mortal(newSViv((IV) suggested))); XPUSHs(sv_2mortal(sv)); XPUSHs(sv_2mortal(FontInfo(aTHX_ wantEncoding, wantFoundary, wantAttrib, Nullch))); XPUSHs(sv_2mortal(FontInfo(aTHX_ gotEncoding, gotFoundary, gotAttrib,gotName))); PUTBACK; if ((count = LangCallCallback(hook, G_EVAL | flags))) { SPAGAIN; result = POPs; PUTBACK; } if (SvTRUE(ERRSV)) { warn("%"SVf,ERRSV); sv_setsv(hook,&PL_sv_undef); } else { if (result && SvOK(result)) { if (SvPOK(result) && !SvCUR(result)) { suggested = (unsigned int) -2; } else suggested = (unsigned int) SvIV(result); } else { suggested = (unsigned int) -1; } } FREETMPS; LEAVE; } /* Placeholder for a hook */ if (0 && !suggested) LangDebug("%08x for U+%04x %s from %s\n",suggested,ch, gotEncoding, gotName); return suggested; } MODULE = Tk PACKAGE = Tk::FontRankInfo PREFIX = FontInfo_ PROTOTYPES: ENABLE SV * FontInfo_encoding(LangFontInfo *p) SV * FontInfo_foundary(LangFontInfo *p) SV * FontInfo_Xname(LangFontInfo *p) SV * FontInfo_family(LangFontInfo *p) int FontInfo_size(LangFontInfo *p) Boolean FontInfo_bold(LangFontInfo *p) Boolean FontInfo_italic(LangFontInfo *p) MODULE = Tk PACKAGE = Tk PREFIX = Const_ PROTOTYPES: ENABLE char * Const_BLACK() char * Const_WHITE() char * Const_NORMAL_BG() char * Const_ACTIVE_BG() char * Const_SELECT_BG() char * Const_SELECT_FG() char * Const_TROUGH() char * Const_INDICATOR() char * Const_DISABLED() IV Const_DONT_WAIT() IV Const_WINDOW_EVENTS() IV Const_FILE_EVENTS() IV Const_TIMER_EVENTS() IV Const_IDLE_EVENTS() IV Const_ALL_EVENTS() MODULE = Tk PACKAGE = Tk::Xrm PREFIX = Xrm_ PROTOTYPES: DISABLE void Xrm_import(class,...) char * class MODULE = Tk PACKAGE = XEvent PREFIX = XEvent_ void XEvent_Info(obj,s) EventAndKeySym * obj char * s CODE: { ST(0) = XEvent_Info(obj,s); } void XEvent_DESTROY(obj) SV * obj MODULE = Tk PACKAGE = Tk::MainWindow PREFIX = pTk_ PROTOTYPES: DISABLE void pTk_Synchronize(win,flag = True) Tk_Window win int flag int Count(self) SV * self CODE: { ST(0) = sv_2mortal(newSViv(Tk_GetNumMainWindows())); } MODULE = Tk PACKAGE = Tk::Callback PREFIX = Callback_ void new(package,what) char * package SV * what CODE: { ST(0) = sv_2mortal(sv_bless(LangMakeCallback(what),gv_stashpv(package, TRUE))); } void Substitute(cb,src,dst) SV * cb SV * src SV * dst CODE: { if (!SvROK(cb)) croak("callback is not a reference"); cb = SvRV(cb); if (!SvROK(src)) croak("src is not a reference"); src = SvRV(src); if (!SvROK(dst)) croak("dst is not a reference"); if (SvTYPE(cb) == SVt_PVAV) { AV *av = newAV(); int n = av_len((AV *) cb); int i; int match = 0; for (i=0; i <= n; i++) { SV **svp = av_fetch((AV *) cb,i,0); if (svp) { if (SvROK(*svp) && SvRV(*svp) == src) { av_store(av, i, SvREFCNT_inc(dst)); match++; } else { av_store(av, i, SvREFCNT_inc(*svp)); } } } if (match) { ST(0) = sv_2mortal(sv_bless(MakeReference((SV *) av),SvSTASH(cb))); } else { SvREFCNT_dec(av); } } } MODULE = Tk PACKAGE = Tk PREFIX = Tk int NeedPreload() void Preload(filename) char * filename CODE: #ifdef NEED_PRELOAD void *h = dlopen(filename, RTLD_LAZY|RTLD_GLOBAL) ; if (!h) croak("Cannot load %s",filename); #endif double timeofday() CODE: { Tcl_Time t; Tcl_GetTime(&t); RETVAL = t.sec + (double) t.usec/1e6; } OUTPUT: RETVAL TkWindow * TkGetFocusWin(win) TkWindow * win void TkGetPointerCoords(win) Tk_Window win PPCODE: { int x, y; TkGetPointerCoords(win, &x, &y); PUSHs(sv_2mortal(newSViv(x))); PUSHs(sv_2mortal(newSViv(y))); } MODULE = Tk PACKAGE = Tk PREFIX = Tk_ void Tk_CheckHash(widget) SV * widget CODE: { Tk_CheckHash(widget,NULL); } void Debug(widget,string) SV * widget; char * string CODE: { LangDumpVec(string,1,&SvRV(widget)); } void WidgetMethod(widget,name,...) SV * widget; SV * name; CODE: { Lang_CmdInfo *info = WindowCommand(widget, NULL, 1); TKXSRETURN(Call_Tk(info, items, &ST(0))); } void OldEnterMethods(package,file,...) char * package char * file CODE: {int i; char buf[80]; /* FIXME Size of buffer */ for (i=2; i < items; i++) { STRLEN len; SV *method = newSVsv(ST(i)); CV *cv; sprintf(buf, "%s::%s", package, SvPV(method,len)); cv = newXS(buf, XStoWidget, file); CvXSUBANY(cv).any_ptr = method; } } IV GetFILE(arg,w) SV * arg int w CODE: { IO *io = sv_2io(arg); RETVAL = -1; if (io) { PerlIO *f = (w) ? IoOFP(io) : IoIFP(io); if (f) { RETVAL = PerlIO_fileno(f); } } } OUTPUT: RETVAL MODULE = Tk PACKAGE = Tk::Widget PREFIX = pTk_ IV PointToWindow(tkwin,x,y,parent = None) Tk_Window tkwin int x int y IV parent void WindowXY(tkwin,src = None, dst = None) Tk_Window tkwin IV src IV dst PPCODE: { Display *dpy = Tk_Display(tkwin); Window root = RootWindowOfScreen(Tk_Screen(tkwin)); int x = 0; int y = 0; if (src == None) src = Tk_WindowId(tkwin); if (dst == None) dst = root; XTranslateCoordinates(dpy, src, dst, 0, 0, &x, &y, &root); XPUSHs(sv_2mortal(newSViv(x))); XPUSHs(sv_2mortal(newSViv(y))); } void pTk_DefineBitmap (tkwin, name, width, height, source) Tk_Window tkwin; char * name; int width; int height; SV * source; CODE: { Tcl_Interp *interp; if (TkToWidget(tkwin,&interp) && interp) {STRLEN len; unsigned char *data = (unsigned char *) SvPV(source, len); STRLEN byte_line = (width + 7) / 8; if (len == height * byte_line) { Tcl_ResetResult(interp); if (Tk_DefineBitmap(interp, Tk_GetUid(name), data, width, height) != TCL_OK) croak("%s",Tcl_GetStringResult(interp)); } else { croak("Data wrong size for %dx%d bitmap",width,height); } } else { croak("Invalid widget"); } } void pTk_GetBitmap(tkwin, name) Tk_Window tkwin; char * name; PPCODE: { Tcl_Interp *interp; Pixmap pixmap; if (TkToWidget(tkwin,&interp) && interp) { pixmap = Tk_GetBitmap(interp, tkwin, name); if (pixmap == None) PUSHs(&PL_sv_undef); else PUSHs(sv_2mortal(newSViv((IV)pixmap))); } else { croak("Invalid widget"); } } MODULE = Tk PACKAGE = Tk::Widget PREFIX = Tk_ void UnmanageGeometry(win) Tk_Window win CODE: { Tk_ManageGeometry(win, NULL, NULL); } void DisableButtonEvents(win) Tk_Window win CODE: { Tk_Attributes(win)->event_mask &= ~(ButtonPressMask | ButtonReleaseMask | ButtonMotionMask); Tk_ChangeWindowAttributes(win, CWEventMask, Tk_Attributes(win)); } void MakeAtom(win,...) Tk_Window win CODE: { int i; for (i=1; i < items; i++) { SV *sv = ST(i); Atom a = None; const char *name = Nullch; if (SvGMAGICAL(sv)) mg_get(sv); if (SvIOK(sv) && !SvPOK(sv)) { a = (Atom) SvIVX(sv); if (a != None) { sv_upgrade(sv,SVt_PVIV); name = Tk_GetAtomName(win,a); sv_setpvn(sv,name,strlen(name)); SvIVX(sv) = (IV) a; SvIOK_on(sv); } } else if (SvPOK(sv) && !SvIOK(sv)) { name = SvPVX(sv); if (name && *name) { sv_upgrade(sv,SVt_PVIV); a = Tk_InternAtom(win,name); SvIVX(sv) = (IV) a; SvIOK_on(sv); } } else if (SvPOK(sv) && SvIOK(sv)) { name = SvPVX(sv); a = (Atom) SvIVX(sv); if (a != Tk_InternAtom(win,name)) { croak("%s/%ld is not a valid atom for %s\n",name,a,Tk_PathName(win)); } } } } int SendClientMessage(win,type,xid,format,data) Tk_Window win char * type IV xid IV format SV * data CODE: { XClientMessageEvent cM; STRLEN len; char *s = SvPV(data,len); if (len > sizeof(cM.data)) len = sizeof(cM.data); cM.type = ClientMessage; cM.serial = 0; cM.send_event = 0; cM.display = Tk_Display(win); cM.window = xid; cM.message_type = Tk_InternAtom(win,type); cM.format = format; memmove(cM.data.b,s,len); if ((RETVAL = XSendEvent(cM.display, cM.window, False, NoEventMask, (XEvent *) & cM))) { /* XSync may be overkill - but need XFlush ... */ XSync(cM.display, False); } else { croak("XSendEvent failed"); } } OUTPUT: RETVAL #if 0 int SendNetWMClientMessage(win,type,xid,format,data) Tk_Window win char * type IV xid IV format SV * data CODE: { /* It's not clear if this function should go into Perl/Tk. This function would make is possible to send some netwm messages, for example NET_WM_STATE_ABOVE: my($wrapper) = $toplevel->wrapper; my $_NET_WM_STATE_ADD = 1; my $data = pack("LLLLL", $_NET_WM_STATE_ADD, $w->InternAtom('_NET_WM_STATE_ABOVE'), 0, 0, 0); $w->SendNetWMClientMessage('_NET_WM_STATE', $wrapper, 32, $data); */ XClientMessageEvent cM; Window root = RootWindowOfScreen(Tk_Screen(win)); STRLEN len; char *s = SvPV(data,len); if (len > sizeof(cM.data)) len = sizeof(cM.data); cM.type = ClientMessage; cM.serial = 0; cM.send_event = 0; cM.display = Tk_Display(win); cM.window = xid; cM.message_type = Tk_InternAtom(win,type); cM.format = format; memmove(cM.data.b,s,len); if ((RETVAL = XSendEvent(cM.display, root, False, SubstructureNotifyMask|SubstructureRedirectMask, (XEvent *) & cM))) { /* XSync may be overkill - but need XFlush ... */ XSync(cM.display, False); } else { croak("XSendEvent failed"); } } OUTPUT: RETVAL #endif void XSync(win,flush) Tk_Window win int flush CODE: { XSync(Tk_Display(win),flush); } void Tk_GetRootCoords(win) Tk_Window win PPCODE: { int x, y; Tk_GetRootCoords(win, &x, &y); PUSHs(sv_2mortal(newSViv(x))); PUSHs(sv_2mortal(newSViv(y))); } void Tk_GetVRootGeometry(win) Tk_Window win PPCODE: { int x, y; int width, height; Tk_GetVRootGeometry(win, &x, &y, &width, &height); PUSHs(sv_2mortal(newSViv(x))); PUSHs(sv_2mortal(newSViv(y))); PUSHs(sv_2mortal(newSViv(width))); PUSHs(sv_2mortal(newSViv(height))); } Colormap Tk_Colormap(win) Tk_Window win Display * Tk_Display(win) Tk_Window win int Tk_ScreenNumber(win) Tk_Window win Screen * Tk_Screen(win) Tk_Window win Visual * Tk_Visual(win) Tk_Window win Window Tk_WindowId(win) Tk_Window win int Tk_X(win) Tk_Window win int Tk_Y(win) Tk_Window win int Tk_ReqWidth(win) Tk_Window win int Tk_ReqHeight(win) Tk_Window win int Tk_Width(win) Tk_Window win int Tk_Height(win) Tk_Window win int Tk_IsMapped(win) Tk_Window win int Tk_Depth(win) Tk_Window win int Tk_InternalBorderWidth(win) Tk_Window win int Tk_IsTopLevel(win) Tk_Window win const char * Tk_Name(win) Tk_Window win char * Tk_PathName(win) Tk_Window win const char * Tk_Class(win) Tk_Window win void Tk_MakeWindowExist(win) Tk_Window win void Tk_SetClass(win,class) Tk_Window win char * class void Tk_MoveWindow(win,x,y) Tk_Window win int x int y void Tk_XRaiseWindow(win) Tk_Window win void Tk_MoveToplevelWindow(win,x,y) Tk_Window win int x int y CODE: { TkWindow *winPtr = (TkWindow *) win; if (!(winPtr->flags & TK_TOP_LEVEL)) { croak("Tk_MoveToplevelWindow called with non-toplevel window"); } Tk_MoveToplevelWindow(win,x,y); } void Tk_MoveResizeWindow(win,x,y,width,height) Tk_Window win int x int y int width int height void Tk_ResizeWindow(win,width,height) Tk_Window win int width int height void Tk_GeometryRequest(win,width,height) Tk_Window win int width int height void Tk_MaintainGeometry(slave,master,x,y,width,height) Tk_Window slave Tk_Window master int x int y int width int height void Tk_SetGrid(win,reqWidth,reqHeight,gridWidth,gridHeight) Tk_Window win int reqWidth int reqHeight int gridWidth int gridHeight void Tk_UnmaintainGeometry(slave,master) Tk_Window slave Tk_Window master void Tk_MapWindow(win) Tk_Window win void Tk_UnmapWindow(win) Tk_Window win void Tk_UnsetGrid(win) Tk_Window win void Tk_AddOption(win,name,value,priority) Tk_Window win char * name char * value int priority const char * Tk_GetAtomName(win,atom) Tk_Window win Atom atom void Tk_ClearSelection(win,selection) Tk_Window win Atom selection const char * Tk_DisplayName(win) Tk_Window win const char * Tk_GetOption(win,name,class) Tk_Window win char * name char * class IV Tk_InternAtom(win,name) Tk_Window win char * name void Tk_Ungrab(win) Tk_Window win const char * Tk_SetAppName(win,name) Tk_Window win char * name int IsWidget(win) SV * win CODE: { if (!SvROK(win) || SvTYPE(SvRV(win)) != SVt_PVHV) RETVAL = 0; else { Lang_CmdInfo *info = WindowCommand(win,NULL,0); RETVAL = (info && info->tkwin); } } OUTPUT: RETVAL int Tk_Grab(win,global) SV * win int global CODE: { Lang_CmdInfo *info = WindowCommand(win,NULL,3); RETVAL = Tk_Grab(info->interp,info->tkwin,global); } SV * Widget(win,path) SV * win char * path CODE: { Lang_CmdInfo *info = WindowCommand(win,NULL,1); ST(0) = sv_mortalcopy(WidgetRef(info->interp,path)); } SV * _object(win,name) SV * win char * name CODE: { Lang_CmdInfo *info = WindowCommand(win,NULL,1); ST(0) = sv_mortalcopy(ObjectRef(info->interp,name)); } Tk_Window Containing(win,X,Y) Tk_Window win int X int Y CODE: { RETVAL = Tk_CoordsToWindow(X, Y, win); } OUTPUT: RETVAL Tk_Window Tk_Parent(win) Tk_Window win SV * MainWindow(interp) Tcl_Interp * interp CODE: { RETVAL = SvREFCNT_inc(WidgetRef(interp,".")); } OUTPUT: RETVAL MODULE = Tk PACKAGE = Tk PREFIX = Tcl_ void Tcl_AddErrorInfo(interp,message) Tcl_Interp * interp char * message void Tcl_BackgroundError(interp) Tcl_Interp * interp void Fail(interp,message) Tcl_Interp * interp char * message CODE: { Tcl_SetResult(interp,message,TCL_VOLATILE); Tcl_BackgroundError(interp); } int Tcl_DoOneEvent(...) CODE: { int flags = 0; if (items) {int i; for (i=0; i < items; i++) { SV *sv = ST(i); if (SvIOK(sv) || looks_like_number(sv)) flags |= SvIV(sv); else if (!sv_isobject(sv)) {STRLEN l; char *s = SvPV(sv,l); if (strcmp(s,BASEEXT)) { /* string to integer lookup here */ croak("Usage [$object->]DoOneEvent([flags]) got '%s'\n",s); } } } } RETVAL = Tcl_DoOneEvent(flags); } OUTPUT: RETVAL MODULE = Tk PACKAGE = Tk::Font PREFIX = Font_ void Font_DESTROY(sv) SV * sv MODULE = Tk PACKAGE = Tk::Font PREFIX = Tk_ int Tk_PostscriptFontName(tkfont,name) Tk_Font tkfont SV * &name OUTPUT: name MODULE = Tk PACKAGE = Tk PREFIX = Lang_ SV * Lang_SystemEncoding() MODULE = Tk PACKAGE = Tk PREFIX = Tk_ void abort() int Tk_tainting() int Tk_tainted(sv = NULL) SV * sv void DebugHook(arg) SV * arg void ClearErrorInfo(win) SV * win BOOT: { Boot_Glue(aTHX); #ifdef WIN32 /* Force inclusion of DllMain() */ TkWin32DllPresent(); TkWinXInit(Tk_GetHINSTANCE()); #endif /* We need to call Tcl_Preserve() on something so its exit handler is first on the list, and so last to be called */ Tcl_Preserve((ClientData) cv); Tcl_Release((ClientData) cv); } Tk-804.031/Extensions/000755 001750 001750 00000000000 12150132173 015221 5ustar00eserteeserte000000 000000 Tk-804.031/README-Strawberry.txt000644 001750 001750 00000002010 11705122224 016714 0ustar00eserteeserte000000 000000 Tk804.030 should work with a 32bit *standard* Strawberry Perl 5.12.3.0 The *portable* Strawberry Perl 5.12.3.0 has some problems with the bundled Config.pm which prevents a successful compilation of Tk. A fix is proposed in http://rt.cpan.org/Public/Bug/Display.html?id=68937 Compiling with a 64bit Strawberry Perl works, but some (tix-related) tests are failing. See https://rt.cpan.org/Public/Bug/Display.html?id=71718 ---------------------------------------------------------------------- Older notes: Tk804.028_501 should compile out-of-the box with Strawberry Perl 5.8.8.3 and 5.10.0.3. Older stuff: Previous Tk versions do not compile under Windows Vista, possibly because of file permission problems. Strawberry Perl's default CPAN.pm configuration in 5.8.8.2 and 5.10.0.2 has the setting makepl_arg [LIBS=-LC:\strawberry\c\lib INC=-IC:\strawberry\c\include] This breaks the Tk build (and also other CPAN modules). The "fix" is to change the setting to the usual default: o conf makepl_arg "" Tk-804.031/ptksh000644 001750 001750 00000044174 11705121720 014151 0ustar00eserteeserte000000 000000 #!perl -w # # PTKSH 2.0 # # A graphical user interface for testing Perl/Tk commands and scripts. # # VERSION HISTORY: # ...truncated earlier stuff... # 4/23/98 V1.7 Achim Bohnet -- some fixes to "o" command # 6/08/98 V2.01 M. Beller -- merge in GUI code for "wish"-like interface # # 2.01d1 6/6/98 First development version # # 2.01d2 6/7/98 # - apply A.B. patch for pod and -option # - fix "use of uninitialized variable" in END{ } block (for -c option) # - support h and ? only for help # - misc. pod fixes (PITFALLS) # - use default fonts and default colors ## NOT YET--still working on it # - get rid of Data::Dumper for history # # 2.01d3 6/8/98 # - Remove "use Data::Dumper" line # - Put in hack for unix vs. win32 window manager focus problem # - Achim's pod and histfile patch # # 2.01d4 6/18/98 # - Slaven's patch to make work properly # - Add help message to banner (per Steve Lydie) # - Fix horizontal scrolling (turn off wrapping in console window) # - Clarify in docs and help means "up arrow" # - Use HOMEDRIVE/HOMEPATH on Win32 # # For more history look at the various Changes files in the Perl/Tk # distribution. =head1 NAME ptksh - Perl/Tk script to provide a graphical user interface for testing Perl/Tk commands and scripts. =head1 SYNOPSIS % ptksh ?scriptfile? ... version information ... ptksh> $b=$mw->Button(-text=>'Hi',-command=>sub{print 'Hi'}) ptksh> $b->pack ptksh> o $b ... list of options ... ptksh> help ... help information ... ptksh> exit % =head1 DESCRIPTION ptksh is a perl/Tk shell to enter perl commands interactively. When one starts ptksh a L is automaticly created, along with a ptksh command window. One can access the main window by typing commands using the variable $mw at the 'ptksh> ' prompt of the command window. ptksh supports command line editing and history. Just type "" at the command prompt to see a history list. The last 50 commands entered are saved, then reloaded into history list the next time you start ptksh. ptksh supports some convenient commands for inspecting Tk widgets. See below. To exit ptksh use: C. ptksh is B<*not*> a full symbolic debugger. To debug perl/Tk programs at a low level use the more powerful L. (Just enter ``O tk'' on debuggers command line to start the Tk eventloop.) =head1 FEATURES =head2 History Press (the Up Arrow) in the perlwish window to obtain a gui-based history list. Press on any history line to enter it into the perlwish window. Then hit return. So, for example, repeat last command is . You can quit the history window with . NOTE: history is only saved if exit is "graceful" (i.e. by the "exit" command from the console or by quitting all main windows--NOT by interrupt). =head2 Debugging Support ptksh provides some convenience function to make browsing in perl/Tk widget easier: =over 4 =item B, or B displays a short help summary. =item B, or B ?I, ...? Dumps recursively arguments to stdout. (see L). You must have installed to support this feature. B was introduced for perl debugger compatibility. =item B

?I, ...? appends "|\n" to each of it's arguments and prints it. If value is B, '(undef)' is printed to stdout. =item B I<$widget> ?I<-option> ...? prints the option(s) of I<$widget> one on each line. If no options are given all options of the widget are listed. See L for more details on the format and contents of the returned list. =item B I<$widget> BIB Lists options of I<$widget> matching the L I. =item B ?I? If no argument is given it lists the modules loaded by the commands you executed or since the last time you called C. If argument is the empty string lists all modules that are loaded by ptksh. If argument is a string, ``text'' it tries to do a ``use Tk::Text;''. =back =head2 Packages Ptksh compiles into package Tk::ptksh. Your code is eval'ed into package main. The coolness of this is that your eval code should not interfere with ptksh itself. =head2 Multiline Commands ptksh will accept multiline commands. Simply put a "\" character immediately before the newline, and ptksh will continue your command onto the next line. =head2 Source File Support If you have a perl/Tk script that you want to do debugging on, try running the command ptksh> do 'myscript'; -- or (at shell command prompt) -- % ptksh myscript Then use the perl/Tk commands to try out different operations on your script. =head1 ENVIRONMENT Looks for your .ptksh_history in the directory specified by the $HOME environment variable ($HOMEPATH on Win32 systems). =head1 FILES =over 4 =item F<.ptksh_init> If found in current directory it is read in an evaluated after the mainwindow I<$mw> is created. F<.ptksh_init> can contain any valid perl code. =item F<~/.ptksh_history> Contains the last 50 lines entered in ptksh session(s). =back =head1 PITFALLS It is best not to use "my" in the commands you type into ptksh. For example "my $v" will make $v local just to the command or commands entered until is pressed. For a related reason, there are no file-scopy "my" variables in the ptksh code itself (else the user might trounce on them by accident). =head1 BUGS B function interactively entered or sourced in a init or script file will block ptksh. =head1 SEE ALSO L L =head1 VERSION VERSION 2.03 =head1 AUTHORS Mike Beller , Achim Bohnet Copyright (c) 1996 - 1998 Achim Bohnet and Mike Beller. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut package Tk::ptksh; require 5.004; use strict; use Tk; ##### Constants use vars qw($NAME $VERSION $FONT @FONT $WIN32 $HOME $HISTFILE $HISTSAVE $PROMPT $INITFILE); $NAME = 'ptksh'; $VERSION = '2.03'; $WIN32 = 1 if $^O =~ /Win32/; $HOME = $WIN32 ? ($ENV{HOMEDRIVE} . $ENV{HOMEPATH}) || 'C:\\' : $ENV{HOME} . "/"; @FONT = ($WIN32 ? (-font => 'systemfixed') : () ); #@FONT = ($WIN32 ? (-font => ['courier', 9, 'normal']) : () ); $HISTFILE = "${HOME}.${NAME}_history"; $HISTSAVE = 50; $INITFILE = ".${NAME}_init"; $PROMPT = "$NAME> "; sub Win32Fix { my $p = shift; $p =~ s'\\'/'g; $p =~ s'/$''; return $p } use vars qw($mw $st $t @hist $hist $list $isStartOfCommand); # NOTE: mainwindow creation order seems to impact who gets focus, and # order is different on Win32 & *nix!! So hack is to create the windows # in an order dependent on the OS! $mw = Tk::MainWindow->new unless $WIN32; # &&& hack to work around focus problem ##### set up user's main window package main; $main::mw = Tk::MainWindow->new; $main::mw->title('$mw'); $main::mw->geometry("+1+1"); package Tk::ptksh; ##### Set up ptksh windows $mw = Tk::MainWindow->new if $WIN32; # &&& hack to work around focus problem $mw->title($NAME); $st = $mw->Scrolled('Text', -scrollbars => 'osoe', -wrap => 'none', -width => 80, -height => 25, @FONT); $t = $st->Subwidget('scrolled'); $st->pack(-fill => 'both', -expand => 'true'); # $mw_mapped assures that Center is only called exactly twice: first time # will determine geometry of window, second time centering will work. # I observed a couple of further events, which are now ignored # and thus window creation seems to be faster now. my $mw_mapped; $mw->bind('', sub {return if $mw_mapped && $mw_mapped>=2; Center($mw); $mw_mapped++;} ); # Event bindings $t->bindtags([$t, ref($t), $t->toplevel, 'all']); # take first crack at events $t->bind('', \&EvalInput); $t->bind('', \&BackSpace); $t->bind('', \&HistKill); $t->bind('', \&History); $t->bind('', \&BeginLine); $t->bind('', \&BeginLine); $t->bind('', [\&Key, Tk::Ev('K'), Tk::Ev('A')]); my $default_font = $t->cget(-font); my %default_font = $t->fontActual($default_font); my $normal_font; if (!$t->fontMetrics($default_font, '-fixed')) { $normal_font = $t->fontCreate(%default_font, -family => "courier"); $t->configure(-font => $normal_font); } else { $normal_font = $default_font; } my %normal_font = $t->fontActual($normal_font); my $bold_font = $t->fontCreate(%normal_font, -weight => "bold"); # Set up different colors for the various window outputs #$t->tagConfigure('prompt', -underline => 'true'); $t->tagConfigure('prompt', -foreground => 'blue', -font => $bold_font); $t->tagConfigure('result', -foreground => 'purple'); $t->tagConfigure('error', -foreground => 'red'); $t->tagConfigure('output', -foreground => 'blue'); # The tag 'limit' is the beginning of the input command line $t->markSet('limit', 'insert'); $t->markGravity('limit', 'left'); # redirect stdout #tie (*STDOUT, 'Tk::Text', $t); tie (*STDOUT, 'Tk::ptksh'); #tie (*STDERR, 'Tk::ptksh'); # Print banner print "$NAME V$VERSION"; print " perl V$] Tk V$Tk::VERSION MainWindow -> \$mw\n"; print "\n\t\@INC:\n"; foreach (@INC) { print "\t $_\n" }; print "Type 'h' at the prompt for help\n"; ##### Read .ptkshinit if ( -r $INITFILE) { print "Reading $INITFILE ...\n"; package main; do $Tk::ptksh::INITFILE; package Tk::ptksh; } ###### Source the file if given as argument 0 if (defined($ARGV[0]) && -r $ARGV[0]) { print "Reading $ARGV[0] ...\n"; package main; do $ARGV[0]; package Tk::ptksh; } ##### Read history @hist = (); if ( -r $HISTFILE and open(HIST, $HISTFILE) ) { print "Reading history ...\n"; my $c = ""; while () { chomp; $c .= $_; if ($_ !~ /\\$/) { #end of command if no trailing "\" push @hist, $c; $c = ""; } else { chop $c; # kill trailing "\" $c .= "\n"; } } close HIST; } ##### Initial prompt Prompt($PROMPT); $Tk::ptksh::mw->focus; $t->focus; #$mw->after(1000, sub {print STDERR "now\n"; $mw->focus; $t->focus;}); ##### Now enter main loop #$mw->afterIdle(sub {Center($mw);}); MainLoop(); ####### Callbacks/etc. # EvalInput -- Eval the input area (between 'limit' and 'insert') # in package main; use vars qw($command $result); # use globals instead of "my" to avoid conflict w/ 'eval' sub EvalInput { # If return is hit when not inside the command entry range, reprompt if ($t->compare('insert', '<=', 'limit')) { $t->markSet('insert', 'end'); Prompt($PROMPT); Tk->break; } # Support multi-line commands if ($t->get('insert-1c', 'insert') eq "\\") { $t->insert('insert', "\n"); $t->insert('insert', "> ", 'prompt'); # must use this pattern for continue $t->see('insert'); Tk->break; } # Get the command and strip out continuations $command = $t->get('limit','end'); $t->markSet('insert','end'); $command =~ s/\\\n>\s/\n/mg; # Eval it if ( $command !~ /^\s*$/) { chomp $command; push(@hist, $command) unless @hist && ($command eq $hist[$#hist]); #could elim more redundancy $t->insert('insert', "\n"); $isStartOfCommand = 1; $command = PtkshCommand($command); exit if ($command eq 'exit'); package main; no strict; $Tk::ptksh::result = eval "local \$^W=0; $Tk::ptksh::command;"; use strict; package Tk::ptksh; if ($t->compare('insert', '!=', 'insert linestart')) { $t->insert('insert', "\n"); } if ($@) { $t->insert('insert', '## ' . $@, 'error'); } else { $result = "" if !defined($result); $t->insert('insert', '# ' . $result, 'result'); } } Prompt($PROMPT); Tk->break; } sub Prompt { my $pr = shift; if ($t->compare('insert', '!=', 'insert linestart')) { $t->insert('insert', "\n"); } $t->insert('insert', $pr, 'prompt'); $t->see('insert'); $t->markSet('limit', 'insert'); } sub BackSpace { if ($t->tagNextrange('sel', '1.0', 'end')) { $t->delete('sel.first', 'sel.last'); } elsif ($t->compare('insert', '>', 'limit')) { $t->delete('insert-1c'); $t->see('insert'); } Tk->break; } sub BeginLine { $t->SetCursor('limit'); $t->break; } sub Key { my ($self, $k, $a) = @_; #print "key event: ", $k, "\n"; if ($t->compare('insert', '<', 'limit')) { $t->markSet('insert', 'end'); } #$t->break; #for testing bindtags } sub History { Tk->break if defined($hist); $hist = $mw->Toplevel; $hist->title('History'); $list = $hist->ScrlListbox(-scrollbars => 'oe', -width => 30, -height => 10, @FONT)->pack(qw(-fill both -expand 1)); Center($hist); $list->insert('end', @hist); $list->see('end'); $list->activate('end'); $hist->bind('', \&HistPick); $hist->bind('', \&HistPick); $hist->bind('', \&HistKill); my $hist_mapped; # see above for $mw_mapped $hist->bind('', sub {return if $hist_mapped && $hist_mapped>=2; Center($hist); $hist_mapped++;} ); $hist->bind('', \&HistDestroy); $hist->focus; $list->focus; $hist->grab; #$mw->afterIdle(sub {Center($hist);}); Tk->break; } sub HistPick { my $item = $list->get('active'); return if (!$item); $t->markSet('insert', 'end'); $t->insert('insert',$item); $t->see('insert'); $mw->focus; $t->focus; HistKill(); } sub HistKill { if ($hist) { $hist->grabRelease; $hist->destroy; } } # Called from destroy event mapping sub HistDestroy { if (defined($hist) && (shift == $hist)) { $hist = undef; $mw->focus; $t->focus; } } sub LastCommand { if ($t->compare('insert', '==', 'limit')) { $t->insert('insert', $hist[$#hist]); $t->break; } } # Center a toplevel on screen or above parent sub Center { my $w = shift; my ($x, $y); if ($w->parent) { #print STDERR $w->screenwidth, " ", $w->width, "\n"; $x = $w->parent->x + ($w->parent->width - $w->width)/2; $y = $w->parent->y + ($w->parent->height - $w->height)/2; } else { #print STDERR $w->screenwidth, " ", $w->width, "\n"; $x = ($w->screenwidth - $w->width)/2; $y = ($w->screenheight - $w->height)/2; } $x = int($x); $y = int($y); my $g = "+$x+$y"; #print STDERR "Setting geometry to $g\n"; $w->geometry($g); } # To deal with "TIE". # We have to make sure the prints don't go into the command entry range. sub TIEHANDLE { # just to capture the tied calls my $self = []; return bless $self; } sub PRINT { my ($bogus) = shift; $t->markSet('insert', 'end'); if ($isStartOfCommand) { # Then no prints have happened in this command yet so... if ($t->compare('insert', '!=', 'insert linestart')) { $t->insert('insert', "\n"); } # set flag so we know at least one print happened in this eval $isStartOfCommand = 0; } while (@_) { $t->insert('end', shift, 'output'); } $t->see('insert'); $t->markSet('limit', 'insert'); # don't interpret print as an input command } sub PRINTF { my $w = shift; $w->PRINT(sprintf(shift,@_)); } ### ### Utility function ### sub _o { my $w = shift; my $what = shift; $what =~ s/^\s+//; $what =~ s/\s+$//; my (@opt) = split " ", $what; print 'o(', join('|', @opt), ")\n"; require Tk::Pretty; # check for regexp if ($opt[0] =~ s|^/(.*)/$|$1|) { print "options matching /$opt[0]/:\n"; foreach ($w->configure()) { print Tk::Pretty::Pretty($_),"\n" if $_->[0] =~ /\Q$opt[0]\E/; } return; } # list of options (allow as bar words) foreach (@opt) { s/^['"]//; s/,$//; s/['"]$//; s/^([^-])/-$1/; } if (length $what) { foreach (@opt) { print Tk::Pretty::Pretty($w->configure($_)),"\n"; } } else { foreach ($w->configure()) { print Tk::Pretty::Pretty($_),"\n" } } } sub _p { foreach (@_) { print $_, "|\n"; } } use vars qw($u_init %u_last $u_cnt); $u_init = 0; %u_last = (); sub _u { my $module = shift; if (defined($module) and $module ne '') { $module = "Tk/".ucfirst($module).".pm" unless $module =~ /^Tk/; print " --- Loading $module ---\n"; require "$module"; print $@ if $@; } else { %u_last = () if defined $module; $u_cnt = 0; foreach (sort keys %INC) { next if exists $u_last{$_}; $u_cnt++; $u_last{$_} = 1; #next if m,^/, and m,\.ix$,; # Ignore autoloader files #next if m,\.ix$,; # Ignore autoloader files if (length($_) < 20 ) { printf "%-20s -> %s\n", $_, $INC{$_}; } else { print "$_ -> $INC{$_}\n"; } } print STDERR "No modules loaded since last 'u' command (or startup)\n" unless $u_cnt; } } sub _d { require Data::Dumper; local $Data::Dumper::Deparse; $Data::Dumper::Deparse = 1; print Data::Dumper::Dumper(@_); } sub _h { print <<'EOT'; ? or h print this message d or x arg,... calls Data::Dumper::Dumper p arg,... print args, each on a line and "|\n" o $w /regexp/ print options of widget matching regexp o $w [opt ...] print (all) options of widget u xxx xxx = string : load Tk::Xxx = '' : list all modules loaded = undef : list modules loaded since last u call (or after ptksh startup) Press (the "up arrow" key) for command history Press to leave command history window Type "exit" to quit (saves history) Type \ for continuation of command to following line EOT } # Substitute our special commands into the command line sub PtkshCommand { $_ = shift; foreach ($_) { last if s/^\?\s*$/Tk::ptksh::_h /; last if s/^h\s*$/Tk::ptksh::_h /; last if s/^u(\s+|$)/Tk::ptksh::_u /; last if s/^[dx]\s+/Tk::ptksh::_d /; last if s/^u\s+(\S+)/Tk::ptksh::_u('$1')/; last if s/^p\s+(.*)$/Tk::ptksh::_p $1;/; last if s/^o\s+(\S+)\s*?$/Tk::ptksh::_o $1;/; last if s/^o\s+(\S+)\s*,?\s+(.*)?$/Tk::ptksh::_o $1, '$2';/; } %u_last = %INC unless $u_init++; # print STDERR "Command is: $_\n"; $_; } ### ### Save History -- use Data::Dumper to preserve multiline commands ### END { if ($HISTFILE) { # because this is probably perl -c if $HISTFILE is not set $#hist-- if $hist[-1] =~ /^(q$|x$|\s*exit\b)/; # chop off the exit command @hist = @hist[($#hist-$HISTSAVE)..($#hist)] if $#hist > $HISTSAVE; if( open HIST, ">$HISTFILE" ) { while ($_ = shift(@hist)) { s/\n/\\\n/mg; print HIST "$_\n"; } close HIST; } else { print STDERR "Error: Unable to open history file '$HISTFILE'\n"; } } } 1; # just in case we decide to be "use"'able in the future. Tk-804.031/Funcs.doc000644 001750 001750 00000012456 11400162250 014633 0ustar00eserteeserte000000 000000 From michael@santafe.edu Fri Mar 3 07:06:55 1995 Return-Path: Date: Fri, 3 Mar 95 00:03:19 MST From: michael@santafe.edu (Michael I Angerman) Message-Id: <9503030703.AA00785@sfi.santafe.edu> To: nTk@franz.ww.tu-berlin.de Cc: Nick.Ing-Simmons@tiuk.ti.com Cc: perl5-porters@africa.nicoh.com Cc: john@wpi.edu Cc: michael@santafe.edu Subject: Documentation on tkGlue.c P-From: michael@santafe.edu (Michael I Angerman) This is a complete listing of all the functions found in tkGlue.c as of version Tk-a13.tar.gz tkGlue.c is a very important file in the Tk distribution and so I thought I would begin to document this file since currently there are very few comments. I think one should consider possibly breaking up tkGlue.c into several files possibly based on the organization below. Any way, this documentation may be valuable to someone who has never looked at tkGlue.c before and wants to get an initial idea of what functions are located in this file. Enjoy perusing, Michael I Angerman The Santa Fe Institute 1399 Hyde Park Road Santa Fe, New Mexico 87501 michael@santafe.edu 505-984-8800 <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< Cut Here >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> Functions Based on Tcl ---------------------- Tcl_AddErrorInfo(interp, message) Tcl_AppendArg(interp, arg) Tcl_AppendElement(interp, string) Tcl_AppendResult(interp, va_alist) Tcl_ArgResult(interp, sv) Tcl_CallWhenDeleted(interp, proc, clientData) Tcl_CallbackResult(interp, sv) Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc) Tcl_DeleteInterp(interp) Tcl_DoubleResults(interp, count, append, va_alist) Tcl_GetBoolean(interp, sv, boolPtr) Tcl_GetDouble(interp, sv, doublePtr) Tcl_GetInt(interp, sv, intPtr) Tcl_GetOpenFile(interp, string, doWrite, checkUsage, filePtr) Tcl_GetResult(interp) Tcl_GetVar(interp, varName, flags) Tcl_GetVar2(interp, sv, part2, flags) Tcl_IntResults(interp, count, append, va_alist) Tcl_Merge(argc, args) Tcl_Panic(char *fmt,...) Tcl_PosixError(interp) Tcl_RegExpCompile(interp, string) Tcl_RegExpExec(interp, re, string, start) Tcl_RegExpRange(re, index, startPtr, endPtr) Tcl_ResetResult(interp) Tcl_SetResult(interp, string, freeProc) Tcl_SetVar(interp, varName, newValue, flags) Tcl_SetVar2(interp, sv, part2, newValue, flags) Tcl_SprintfResult(Tcl_Interp * interp, char *fmt,...) Tcl_SprintfResult(interp, fmt, va_alist) Tcl_TildeSubst(interp, name, bufferPtr) Tcl_TraceVar(interp, varName, flags, proc, clientData) Tcl_TraceVar2(interp, sv, part2, flags, tkproc, clientData) Tcl_UntraceVar(interp, varName, flags, proc, clientData) Tcl_UntraceVar2(interp, sv, part2, flags, tkproc, clientData) Functions Based on Tk --------------------- Tk_AppendImage(interp, name) Tk_AppendWidget(interp, tkwin) Tk_BackgroundError(interp) Tk_ChangeScreen(interp, dispName, screenIndex) Tk_CreateImage(interp, cmdName, proc, clientData, deleteProc, typePtr) Tk_CreateWidget(interp, tkwin, proc, clientData, deleteProc) Tk_DeleteWidget(interp, tkwin) Tk_ImageResult(interp, name) Tk_MainWindow(interp) Tk_WidgetResult(interp, tkwin) Functions Based on Lang ----------------------- LangAllocVec(n) LangBadFile(fd) LangCallbackArg(sv) LangCatArg(out, sv, refs) LangClientMessage(interp, tkwin, event) LangCloseHandler(interp, arg, f, proc) LangCmpCallback(a, b) LangCopyArg(sv) LangCopyCallback(sv) LangDeadWindow(interp, tkwin) LangDoCallback(interp, sv, result, argc, va_alist) LangEval(interp, cmd, global) LangEventCallback(interp, sv, event, keySym) LangEventHook(flags) LangExit(value) LangFindVar(interp, tkwin, name) LangFreeArg(sv, freeProc) LangFreeCallback(sv) LangFreeVar(sv) LangFreeVec(count, p) LangMakeCallback(sv) LangMergeString(argc, args) LangMethodCall(interp, sv, method, result, argc, va_alist) LangNull(sv) LangPrint(sv) LangRestoreResult(interp, old) LangSaveResult(interp) LangSaveVar(interp,sv,vp,type) LangSetArg(sp, arg) LangSetDefault(sp, s) LangSetDouble(sp, v) LangSetImage(interp, argp, name) LangSetInt(sp, v) LangSetString(sp, s) LangSetSv(sp, arg) LangSetWidget(interp, argp, tkwin) LangString(sv) LangStringMatch(string, match) LangVarArg(sv) Lang_GetErrorCode(interp) Lang_GetErrorInfo(interp) Lang_SetErrorCode(interp, code) Lang_SplitList(interp, sv, argcPtr, argvPtr, freeProc) Other Function Definitions -------------------------- CopyAv(dst, src) FindAv(interp, who, create, key) FindHv(interp, who, create, key) InterpHv(interp) NameFromCv(cv) ResultAv(interp, who, create) Blessed(package, sv) Boot_Glue CallCallback(sv, flags) Call_Tk(info, items, args) Check_Eval(interp) Decrement(SV * sv, char *who) DumpStack _((void)) Dump_vec(who, count, data) EnterSubCommands(package, va_alist) EnterWidgetMethods(package, va_alist) EventToSv(ix,obj) GetWindow(sv) HandleBgErrors(clientData) ImageRef(interp, path) Increment(SV * sv, char *who) MakeReference(sv) Perl_GeomLostSlave(clientData,tkwin) Perl_GeomRequest(clientData,tkwin) Perl_Trace(ix, sv) PushCallbackArgs(interp, svp ,obj) PushVarArgs(ap,argc) SelGetProc(clientData,interp,portion,numItems,format,type,tkwin) TkToMainWindow(tkwin) TkToWidget(tkwin,pinterp) WidgetRef(interp, path) WindowCommand(sv, hv_ptr) XS(BindClientMessage) XS(DoWhenIdle) XS(FreeAbstract) XS(ManageGeometry) XS(SelectionGet) XS(XEventInfo) XS(XStoBind) XS(XStoSubCmd) XS(XStoTk) XS(XStoWidget) do_watch(void) handle_generic(clientData, eventPtr) handle_idle(clientData) SetTclResult(interp,count) Tk-804.031/perlfiles000644 001750 001750 00000001122 11400162150 014761 0ustar00eserteeserte000000 000000 package Perlfiles; use File::Find; @wanted = (); sub perlscript { my ($file) = @_; open(SCRIPT,"<$file") || die "Cannot open $file:$!"; my $line =