Tcl-1.05/0000755552332700244210000000000012734526732012607 5ustar konovvDomain UsersTcl-1.05/Changes0000644552332700244210000001166112734525454014107 0ustar konovvDomain UsersRevision history for Perl extension Tcl. 1.05 2016-06-28 - typo bug on Delete code ref - jmcveigh, jhobbs changes to Tcl.xs 1.04 2016-03-xx - not seeking tkkit.dll - some NpLoadLibrary adj 1.03 2016-02-20 - many cleanup: Tcl::call now much smaller and does not tracks widgets anymore; $Tcl::STACK_TRACE, %widget_refs, sub wcall, etc - proper disposal of CODE REFs when they are no more needed on tcl side. - new test t/disposal-subs.t - Tcl::call processes 'after' differently - use direct object syntax for calls to 'new' - fixed minor typos in POD - removed superfluous Solaris check in Makefile.PL - add Travis-CI configuration 1.02 2011-02-11 - fix export_to_tcl and test 1.01 2011-02-10 - export_to_tcl convenience sub 1.00 2010-11-23 - 1.0 release 0.99 2010-11-02 - more 'stubs' platform binaries - hashes also treated specially in $interp->call(...) 0.98 2009-11-24 - moved to git - Add flag to CreateCommand to suppress useless first 3 args - documentation - better tkkit.dll support - Makefile.PL has better support for AIX, Solaris, Windows 64, darwin 0.97 2008-09-07 - --usestubs default on linux - Makefile.PL should exit with status 0 on error 0.95 2007-06-07 - configuration cygwin help from Jerry D. Hedden 0.91 2006-11-13 --usestubs is no by default 0.90 2006-11-11 - more Darwin support - move 'new' method to Tcl.pm - replace DynaLoader with XSLoader, Tcl is no more ISA-DynaLoader - removed bogus insecure do"$Tcl::config::tcl_pm_path/Tcl.cfg" 0.89 23-may-2006 - Binary stub archives for various platforms to allow building the Tcl module without any Tcl distribution on the system. - misc OS shared libraries loading improvements 0.88 23-aug-2005 - documentation - moveable distributions - implement & document - TODO file removal - more OS support in Makefile.PL - some code modification in Tcl bridge - more tests 0.87 02-feb-2005 - automatic cleanup on widget deletion 0.85 31-dec-2004 - Makefile.PL makes --usestubs the default - minor test fixes for portability 0.84 13-sept-2004 - Tcl.pm changes to be more perlTk compatible - Makefile.PL contains few more OS-dependent processing 0.81 09-may-2004 - some Tcl.xs improvements, Makefile.PL now requires Tcl/Tk version 8.4 (Jeff Hobbs) 0.80 03-may-2004 - many Tcl.xs improvements from Jeff Hobbs, Gisle Aas (better handling for numbers, Unicode) - changes for event variables and in Tcl::Ev - ::perl::Eval proc in Tcl to eval in Perl - references to Perl objects now created in Tcl in ::perl namespace 0.77 17-apr-2004 - quick fix of 1=>1.0 problem - add wcall wrapper to Tcl.pm 0.76 17-apr-2004 - many improvements in Tcl.pm, Tcl.xs from Jeff Hobbs - many improvements in Tcl.pm, Tcl.xs from Gisle Aas - more tests by Jeff Hobbs, Gisle Aas - subclassing is more correct with respect to Tcl::Tk module - Makefile.PL and ceMakefile.PL now integrated to one file - General cleaning of code, more comments - Tcl-800 currently not supported, only recent versions 0.75 28-mar-2004, Vadim Konovalov - ARRAY REF are processed in $interp->call(...) for perlTk compat - replace undef with '' in $interp->call(...) 0.72 20-aug-2003, Vadim Konovalov - now widget object become replaced to widget path in arguments to 'call' - better error handling and diagnostic for calls to Tcl/Tk - now returning undef from handler subroutine do not causes an error in Tcl side. Instead, some error traping should be invented 0.71 03-jul-2003, Vadim Konovalov - support Tcl version 8.0.x 0.7 02-jul-2003, Vadim Konovalov - Some possible coredumps were fixed (but not completely, hence FIXME warning in Tcl.xs) - some fixes from Slaven Rezic, (FreeBSD support and some more) - perl-5.005 support (FreeBSD has this version after installation) 0.6 08-jun-2003, Vadim Konovalov - now Tcl 'is-a' Tcl::Tk - improved access method for TCL Events (%y, %y and so on) - WinCE support - few BUGs fixed 0.5 25-may-2003, Vadim Konovalov - 'linux' and 'cygwin' supported 0.4 19-may-2003, Vadim Konovalov - changed version system and added module VERSION variable - compatibility changes to support modern versions of Perl and Tcl (perl-5.6.0, perl-5.8.0, tcl-8.4.2) - call to Tcl_FindExecutable, as long as Tcl now requires this (otherwise Tcl dumps core, as RTFS-ing of Tcl shows) - XS function "Tcl::call" renamed to "Tcl::icall" and "Tcl::call" implemented in Tcl.pm and now contains more complex logic. - sub create_tcl_sub and ev_sub were added, they could be used to create event fields-aware subroutines - added 'tclcfg.tcl' to output tcl configuration, used from Makefile.PL - Makefile.PL changed to be more consistent - use strict; Tcl-b3 11-mar-2001, Andrew Brown - minor update for compatability with perl 5.6.0 by Andrew Brown Tcl-b2 1997, Malcolm Beattie - Created entire module. Tcl-1.05/Makefile.PL0000644552332700244210000002123612734525120014553 0ustar konovvDomain Users#!perl -w # before running this script make sure you have 'tclsh' in your path, # and this 'tcl' distribution is required one. # FreeBSD users may want to modify name of tcl interpreter (this is # $tclsh variable below) as long as 'tclsh' does not work in their case use strict; use Getopt::Long qw(GetOptions); use ExtUtils::MakeMaker; use Config; my $tclsh = 'tclsh'; my $tclconfig; my $buildspec; my $usestubs = ($^O eq 'MSWin32' ? 0 : 1); my $libpath; my $incpath; my $defs = ""; my $buildtype = ""; my @extraargs; my $arch; my $stub = "tclstub8.4"; # These need updating as more platforms are added to tcl-core/ area if ($^O eq "aix") { $arch = "aix"; } elsif ($^O eq "MSWin32") { $stub = "tclstub84"; $arch = "win32-x86" if ($Config{archname} =~ /-x86-/); $arch = "win32-x64" if ($Config{archname} =~ /-x64-/); } elsif ($^O eq "darwin") { $arch = "darwin-universal"; } elsif ($^O eq "solaris") { $arch = "$^O-x86" if ($Config{archname} =~ /86/); $arch = "$^O-sparc" if ($Config{archname} =~ /sun4/); } elsif ($^O eq "aix") { $arch = "$^O"; } elsif ($^O eq "hpux") { $arch = "$^O-ia64" if ($Config{archname} =~ /ia64/i); $arch = "$^O-parisc" if ($Config{archname} =~ /pa-risc/i); } elsif ($^O eq "linux") { $arch = "$^O-i686" if ($Config{archname} =~ /i\d86/); $arch = "$^O-ia64" if ($Config{archname} =~ /ia64/i); $arch = "$^O-x86_64" if ($Config{archname} =~ /x86_64/); } elsif ($^O eq "cygwin") { $tclconfig = '/usr/lib/tclConfig.sh'; } sub _die ($) { # now CPAN smokers report FAIL if Makefile.PL dies, it # should exit with status 0 my $err = shift; warn $err; exit 0; } GetOptions("tclsh=s", \$tclsh, # Use this tclsh executable as a # base to find the lib info needed "tclconfig=s", \$tclconfig, # Use the specified Tcl config file # instead of basing the values on # the tclsh exe found "buildspec", \$buildspec, # Used with --tclconfig, use the # build (instead of install) values # for determining lib info "usestubs!", \$usestubs, # we want to use the Tcl stubs # mechanism by default "library=s", \$libpath, # Use this specific Tcl library "include=s", \$incpath, # Use this specific include path "define=s", \$defs, # Use this specific set of defines ) || _die <] [--tclconfig ] [--buildspec] [--nousestubs] [...] or for expert compilation: perl --library=-l/path/to/tcl(stub).a --include=-I/path/to/tcl/include --define="-DLIB_RUNTIME_DIR=... -DTCL_LIB_FILE=..." EOT if ($usestubs) { $defs .= " -DUSE_TCL_STUBS"; $buildtype = "stub"; } # If using stubs, we will set the LIB_RUNTIME_DIR and TCL_LIB_FILE # to point to the install location as the default dll to load. if (defined($libpath) && defined($incpath)) { # do nothing - set on command line } elsif (!defined($tclconfig) && defined($arch) && $usestubs) { $incpath = "-Itcl-core/include"; $libpath = "-Ltcl-core/$arch -l$stub"; if ($^O eq 'darwin') { # OS X also requires the Carbon framework by default $libpath .= " -framework Carbon"; } } elsif ($tclconfig || $^O eq 'darwin') { unless ($tclconfig) { open(TCLSH, "$tclsh tclcfg.tcl |") or _die "error starting tclsh: $!\n"; my $tclcfg = join '', ; close(TCLSH); my %tclcfg = $tclcfg =~ /^([^=]+)=(.*?)\n/gm; $tclconfig = $tclcfg{'tclConfig.sh'}; } _die "Tcl config file '$tclconfig' not found\n" unless (-f $tclconfig); # Retrieve all info based on tclConfig.sh my $variant = ($usestubs ? "_STUB" : ""); $variant = "_BUILD$variant" if $buildspec; my $libspecvar = "TCL${variant}_LIB_SPEC"; my %tclcfg; process_tclconfig($tclconfig, \%tclcfg); _die "Tcl requires Tcl v8.4 or greater, found '$tclcfg{TCL_VERSION}'\n" unless (defined $tclcfg{'TCL_VERSION'} && $tclcfg{'TCL_VERSION'} >= 8.4); $libpath = $tclcfg{$libspecvar}; $incpath = $tclcfg{'TCL_INCLUDE_SPEC'}; if ($usestubs) { if ($^O eq 'MSWin32') { $defs .= " -DLIB_RUNTIME_DIR=\\\"$tclcfg{'TCL_EXEC_PREFIX'}/bin\\\""; $defs .= " -DTCL_LIB_FILE=\\\"$tclcfg{'TCL_DLL_FILE'}\\\""; } elsif ($^O eq 'darwin' && $tclcfg{'TCL_STUB_LIB_PATH'} =~ /\.framework/ ) { (my $fmk = $tclcfg{'TCL_STUB_LIB_PATH'}) =~ s/(?<=\.framework).*//; $defs .= " -DLIB_RUNTIME_DIR=\\\"$fmk\\\""; $defs .= " -DTCL_LIB_FILE=\\\"$tclcfg{'TCL_LIB_FILE'}\\\""; @extraargs = (dynamic_lib => {OTHERLDFLAGS => "-framework Carbon"}); } else { $defs .= " -DLIB_RUNTIME_DIR=\\\"$tclcfg{'TCL_EXEC_PREFIX'}/lib\\\""; $defs .= " -DTCL_LIB_FILE=\\\"$tclcfg{'TCL_LIB_FILE'}\\\""; } } } else { open(TCLSH, "$tclsh tclcfg.tcl |") or _die "error starting tclsh: $!\n"; my $tclcfg = join '', ; close(TCLSH); print $tclcfg; my %tclcfg = $tclcfg =~ /^([^=]+)=(.*?)\n/gm; # This is to allow propagation of this value to sub-Makefile.PLs $ENV{'TCLSH_PROG'} = $tclsh; if (0 && -f $tclcfg{'tclConfig.sh'}) { # Retrieve all info based on tclConfig.sh # Don't do this unless the user passes --tclconfig process_tclconfig($tclcfg{'tclConfig.sh'}, \%tclcfg); # libpath/incpath vars need to be set here if used ... } else { my $tclver = $tclcfg{tcl_version}; # currently version must be 8.4+ my ($vmaj,$vmin) = ($tclver =~ /^(\d+)\.(\d+)/); _die "Tcl requires Tcl v8.4 or greater, found '$vmaj.$vmin'\n" if ($vmaj < 8 || ($vmaj == 8 && $vmin < 4)); if ($tclcfg{tcl_library} =~ /^(.*)[\\\/]lib[\\\/]/) { $libpath = "-L$1/lib"; $incpath = "-I$1/include"; $defs .= " -DLIB_RUNTIME_DIR=\\\"$1/lib\\\"" if $usestubs; } if ($^O eq 'MSWin32') { $tclver=~s/\.//; $defs .= " -DTCL_LIB_FILE=\\\"tcl$tclver.dll\\\"" if $usestubs; } elsif ($^O eq 'freebsd') { $tclver=~s/\.//; $tclsh=~/([\d.]+)$/ and $incpath .= " -I/usr/local/include/tcl$1"; $defs .= " -DTCL_LIB_FILE=\\\"libtcl$tclver.so\\\"" if $usestubs; } elsif ($^O eq 'hpux') { #$tclver = ''; $defs .= " -DTCL_LIB_FILE=\\\"libtcl$tclver.sl\\\"" if $usestubs; } else { #$tclver = ''; $defs .= " -DTCL_LIB_FILE=\\\"libtcl$tclver.so\\\"" if $usestubs; } $libpath .= " -ltcl$buildtype$tclver"; } } print "LIBS = $libpath\n"; print "INC = $incpath\n"; print "DEFINE = $defs\n"; if ($^O eq 'darwin') { # darwin has a broken ranlib that requires you to run it anytime # you copy an archive file, so ensure ours it up-to-date system("ranlib tcl-core/$arch/libtclstub8.4.a"); system("git update-index --assume-unchanged tcl-core/$arch/libtclstub8.4.a") if -d ".git"; if ($libpath =~ /-framework/) { # Frameworks require slightly different compile options @extraargs = (dynamic_lib => {OTHERLDFLAGS => $libpath}); $libpath = ""; } } #print <<"#EOS"; WriteMakefile( NAME => "Tcl", VERSION_FROM => 'Tcl.pm', LICENSE => 'perl', MIN_PERL_VERSION => '5.006', ABSTRACT_FROM => 'Tcl.pm', META_MERGE => { resources => { repository => 'http://github.com/gisle/tcl.pm', MailingList => 'mailto:tcltk@perl.org', } }, LIBS => ["$libpath"], INC => "$incpath", DEFINE => $defs, @extraargs, ); #EOS sub process_tclconfig { # Process a tclConfig.sh file for build info my $tclconfig = shift; my $hashref = shift; open(TCLSH, $tclconfig) or _die "error opening file '$tclconfig': $!\n"; print "Using config data in $tclconfig\n"; my $tclcfg = join '', ; close(TCLSH); %$hashref = $tclcfg =~ /^(\w+)=['"]?(.*?)["']?\n/gm; for my $k (keys %$hashref) { # Handle sh subs like ${TCL_DBGX} $hashref->{$k} =~ s/\$\{(\w+)\}/(exists $hashref->{$1} ? $hashref->{$1} : $&)/eg; # Handle any cygdrive-style paths $hashref->{$k} =~ s,/cygdrive/(\w)/,$1:/,ig; } } sub MY::libscan { my($self, $path) =@_; return '' if $path =~ /\.pl$/i; return $path; } BEGIN { # compatibility with older versions of MakeMaker my $developer = -f ".git"; my %mm_req = ( LICENCE => 6.31, META_MERGE => 6.45, META_ADD => 6.45, MIN_PERL_VERSION => 6.48, ); undef(*WriteMakefile); *WriteMakefile = sub { my %arg = @_; for (keys %mm_req) { unless (eval { ExtUtils::MakeMaker->VERSION($mm_req{$_}) }) { warn "$_ $@" if $developer; delete $arg{$_}; } } ExtUtils::MakeMaker::WriteMakefile(%arg); }; } Tcl-1.05/MANIFEST0000755552332700244210000000260012734526732013741 0ustar konovvDomain UsersChanges Makefile.PL Tcl extension makefile writer MANIFEST This list of files README Introduction to the Tcl extension Tcl.pm Tcl extension module Tcl.xs Tcl extension implementation t/call.t See the 'call' and 'icall' methods t/constants.t See if constants and flags are set up properly t/createcmd.t See if command creation works t/eval.t See if Eval-ish things work t/info.t See if Tcl info command works t/result.t See if Tcl result protocol works t/subclass.t See if we can subclass Tcl t/trace.t See if variable tarcing works t/unicode.t some unicode tests t/var.t See if access to/from Tcl variables works t/export_to_tcl.t test convenience sub export_to_tcl t/disposal-subs.t check if code refs destroyed and removed from tcl typemap Tcl extension types tclcfg.tcl Tcl script to discover TCL installation options tcl-core/aix/libtclstub8.4.a tcl-core/darwin-universal/libtclstub8.4.a tcl-core/hpux-ia64/libtclstub8.4.a tcl-core/hpux-parisc/libtclstub8.4.a tcl-core/include/tcl.h tcl-core/include/tclDecls.h tcl-core/include/tclPlatDecls.h tcl-core/linux-i686/libtclstub8.4.a tcl-core/linux-ia64/libtclstub8.4.a tcl-core/linux-x86_64/libtclstub8.4.a tcl-core/solaris-sparc/libtclstub8.4.a tcl-core/solaris-x86/libtclstub8.4.a tcl-core/win32-x86/tclstub84.lib tcl-core/win32-x64/tclstub84.lib META.yml Module meta-data (added by MakeMaker) Tcl-1.05/META.yml0000644552332700244210000000113212734526732014055 0ustar konovvDomain Users--- #YAML:1.0 name: Tcl version: 1.05 abstract: Tcl extension module for Perl author: [] license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: perl: 5.006 resources: MailingList: mailto:tcltk@perl.org repository: http://github.com/gisle/tcl.pm no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Tcl-1.05/README0000644552332700244210000000207512734525120013461 0ustar konovvDomain UsersNAME Tcl extension module for Perl5 DESCRIPTION The Tcl extension provides a small but complete interface into libtcl and any other Tcl-based library. It lets you create Tcl interpreters (as perl5 objects), bind in commands to them (either perl subroutines or C functions dynamically loaded with the DynaLoader extension) and execute Tcl code in those interpreters. There is a Tcl::Tk extension (not to be confused with "native" perl5 Perl/Tk extension) distributed separately which provides a raw but complete interface to the whole of libtk via this Tcl extension. Build in the usual way for a perl extension: 1. Tweak Makefile.PL is necessary only if your Tcl include files could not be found automatically by Makefile.PL script. Normally you just make sure you have right tcl in your path at a moment of running Makefile.PL script. 2. perl Makefile.PL make make test make install See License, Authors sections in Tcl.pm, or with 'perldoc Tcl' - once it is installed - to have acknowledged on this type of information, if needed. Tcl-1.05/t/0000755552332700244210000000000012734526730013050 5ustar konovvDomain UsersTcl-1.05/t/call.t0000644552332700244210000000243312734525120014142 0ustar konovvDomain Users# call.t # # Tests for the 'call' and 'icall' functions. # use Tcl; $| = 1; print "1..15\n"; my $i = Tcl->new; my (@res, $res, $a, $b); $res = $i->call('set', 'var', "ok 1"); print "$res\n"; $res = $i->icall('set', 'var', "ok 2"); print "$res\n"; @res = $i->call('set', 'var', ['ok', '3']); print STDOUT join(' ', @res), "\n"; @res = $i->icall('set', 'var', ['ok', '4']); print STDOUT join(' ', @res), "\n"; ($a, $b) = $i->call('list', '5', 'ok'); print "$b $a\n"; ($a, $b) = $i->icall('list', '6', 'ok'); print "$b $a\n"; $i->call("puts", "ok 7"); $i->icall("puts", "ok 8"); $a = $i->call("list", 1, $i->call("list", 2, 3), 4); print "not " unless @$a == 4 && $a->[1] == 2 && $a eq "1 2 3 4"; print "ok 9\n"; $a = $i->call("list", 1, scalar($i->call("list", 2, 3)), 4); print "not " unless @$a == 3 && $a->[1][0] == 2 && $a eq "1 {2 3} 4"; print "ok 10\n"; my $v = 1; $i->call("after", 250, sub { print "ok 11\n"; $v++; }); $i->call("vwait", \$v); print "not " unless $v == 2; print "ok 12\n"; $i->call("eval", <<'EOT'); proc f1 {h v} { upvar $h arr puts "ok $arr(ok)" set arr(foo) 14 incr $v } EOT my %h = (foo => 1, bar => 2, ok => 13); $i->call("after", 250, "f1", \%h, \$v); $i->call("vwait", \$v); print "ok $h{foo}\n"; print "not " unless $v == 3; print "ok 15\n"; Tcl-1.05/t/constants.t0000644552332700244210000000103012734525120015233 0ustar konovvDomain Users#!perl -w use strict; use Test qw(plan ok); plan tests => 3; use Tcl; # These tests are bit lame, as they depend on the actual values, # but at least it verifies that the constants are set up. ok(Tcl::OK, 0); ok(Tcl::ERROR, 1); ok(Tcl::GLOBAL_ONLY | Tcl::NAMESPACE_ONLY | Tcl::APPEND_VALUE | Tcl::LIST_ELEMENT | Tcl::TRACE_READS | Tcl::TRACE_WRITES | Tcl::TRACE_UNSETS | Tcl::TRACE_DESTROYED | Tcl::INTERP_DESTROYED | Tcl::LEAVE_ERR_MSG | Tcl::TRACE_ARRAY, 0xBFF); Tcl-1.05/t/createcmd.t0000644552332700244210000000120412734525120015151 0ustar konovvDomain Usersuse Tcl; $| = 1; # 5.8.0 has an order destroy issue that prevents proper Tcl finalization my $tests = $] == 5.008 ? 3 : 4; print "1..$tests\n"; sub foo { my($clientdata, $interp, @args) = @_; print "$clientdata->{OK} $args[1]\n"; } sub foogone { my($clientdata) = @_; print "$clientdata->{OK} 3\n"; } sub bar { "ok 2" } sub bargone { print "ok $_[0]\n"; } $i = Tcl->new; $i->CreateCommand("foo", \&foo, {OK => "ok"}, \&foogone); $i->CreateCommand("bar", \&bar, 4, \&bargone); $i->Eval("foo 1"); $i->Eval("puts [bar]"); $i->DeleteCommand("foo"); # final destructor of $i triggers destructor for Tcl proc bar (!5.8.0) Tcl-1.05/t/disposal-subs.t0000644552332700244210000000217112734525120016016 0ustar konovvDomain Users# see how CODE REFs are created and then freed use Tcl; $| = 1; print "1..2\n"; my $int = Tcl->new; $int->call('after', 1000, sub {"foo, bar, fluffy\n";}); my $q = 0; for (1 .. 1000) { my $r = 'aaa'; $int->call('after', 1000, sub {"*";}); $int->call('after', 1000, sub {$r++;"$r#";}); $int->call('if', 1000, sub { $r++; $q++; }); } $int->icall('after', 3000, 'set var fafafa'); $int->icall('vwait', 'var'); # will wait for 3 seconds # we have a number of commands created in Tcl, '::perl' package, # but they must have been disposed. my @p1 = $int->icall('info', 'commands', '::perl::*'); print STDERR "[[@p1; $r]]\n"; print +($#p1>10?"not ":""), "ok 1\n"; for (1 .. 1000) { my $r = 'aaa'; $int->call('after', 1000, sub {"*";}); $int->call('after', 1000, sub {$r++;"$r#";}); $int->call('if', 1000, sub { $r++; $q++; }); } $int->icall('after', 300, 'set var fafafa'); $int->icall('vwait', 'var'); # will wait for 0.3 seconds; will still have procs my @p2 = $int->icall('info', 'commands', '::perl::*'); print +($#p2<10?"not ":""), "ok 2\n"; # now we finish and procs destroyed on cleanup Tcl-1.05/t/eval.t0000644552332700244210000000042512734525120014155 0ustar konovvDomain Usersuse Tcl; $| = 1; print "1..5\n"; $i = Tcl->new; $i->Eval(q(puts "ok 1")); ($a, $b) = $i->Eval(q(list 2 ok)); print "$b $a\n"; eval { $i->Eval(q(error "ok 3\n")) }; print $@; $i->call("puts", "ok 4"); $i->EvalFileHandle(\*DATA); __END__ set foo ok set bar 5 puts "$foo $bar" Tcl-1.05/t/export_to_tcl.t0000644552332700244210000000131612734525120016113 0ustar konovvDomain Users# tests convenience sub export_to_tcl use Test; BEGIN {plan tests=>4} use Tcl; my $int = Tcl->new; $tcl::foo = $tcl::foo = 'qwerty'; my $x = "some perl scalar var"; $int->export_to_tcl(subs_from=>'tcl',vars_from=>'tcl'); $int->export_to_tcl(subs=>{lala=>sub{"ok"}}, namespace=>''); $int->export_to_tcl(vars=>{foo1=>\$x}, namespace=>''); # this should croak: #$int->export_to_tcl(vars=>{foo=>$x}, namespace=>''); $int->export_to_tcl(subs_from=>''); # this will bind sub named sub1 below sub sub1 {"sub1 its me"} sub tcl::sub2 {"sub2 its me"} ok($int->call('perl::sub1'),"sub1 its me"); ok($int->call('lala'),"ok"); ok($int->Eval('set perl::foo'),'qwerty'); ok($int->call('set','foo1'),'some perl scalar var'); Tcl-1.05/t/info.t0000644552332700244210000000121212734525120014154 0ustar konovvDomain Users#!perl -w use strict; use Test qw(plan ok); plan tests => 6; use Tcl; use File::Spec::Functions; my $tcl = Tcl->new; ok($tcl); if ($^O eq 'cygwin') { my $cpath = $tcl->Eval("info nameofexecutable"); $cpath = `cygpath -u '$cpath'`; chomp($cpath); ok($cpath, canonpath($^X)); } else { ok(canonpath($tcl->Eval("info nameofexecutable")), canonpath($^X)); } ok($tcl->Eval("info exists tcl_platform"), 1); my $tclversion = $tcl->Eval("info tclversion"); ok($tclversion =~ /^8\.\d+$/); ok(substr($tcl->Eval("info patchlevel"), 0, length($tclversion)), $tclversion); ok(length($tcl->Eval("info patchlevel")) > length($tclversion)); Tcl-1.05/t/result.t0000644552332700244210000000206612734525120014547 0ustar konovvDomain Usersuse Tcl; $| = 1; print "1..5\n"; sub foo { my $interp = $_[1]; $i->SetResult("ok 2"); return undef; } $i = Tcl->new; $i->Eval('expr 10 + 30'); print $i->result == 40 ? "ok 1\n" : "not ok 1\n"; $i->CreateCommand("foo", \&foo); # previously it was assumed that perl when subroutine returns undef it is # treated as an exception. This is very uncomfortable from, say, handlers, # where undef could be returned if a user is not aware os return value. # As long as this was not documented, let's change this, so following test # should always return "ok 2" $i->Eval('if {[catch foo res]} {puts $res} else {puts "ok 2"}'); $i->ResetResult(); @qlist = qw(a{b g\h j{{k} l}m{ \}n); foreach (@qlist) { $i->AppendElement($_); } if ($i->result eq 'a\{b {g\h} j\{\{k\} l\}m\{ {\}n}') { print "ok 3\n"; } else { print "not ok 3\n"; } @qlistout = $i->SplitList($i->result); if ("@qlistout" eq "@qlist") { print "ok 4\n"; } else { print "not ok 4\n"; } if ($i->SplitList('bad { format')) { print "not ok 5\n"; } else { print "ok 5\n"; } Tcl-1.05/t/subclass.t0000644552332700244210000000050412734525120015043 0ustar konovvDomain Users#!perl -w use strict; use Test qw(plan ok); plan tests => 4; { package MyTcl; require Tcl; @MyTcl::ISA = qw(Tcl); sub eval { my $self = shift; $self->Eval(@_); } } my $tcl = MyTcl->new; ok(ref($tcl), "MyTcl"); ok($tcl->isa("Tcl")); ok($tcl->eval("set var 42"), 42); ok($tcl->eval("set var"), 42); Tcl-1.05/t/trace.t0000644552332700244210000000064212734525120014325 0ustar konovvDomain Usersuse Tcl; $| = 1; print "1..2\n"; $i = Tcl->new; tie $perlscalar, Tcl::Var, $i, "tclscalar"; tie %perlhash, Tcl::Var, $i, "tclhash"; $i->Eval('set tclscalar ok; set tclhash(key) 1'); printf "%s %s\n", $perlscalar, $perlhash{"key"}; $perlscalar = "newvalue"; $perlhash{"newkey"} = 2; $i->Eval(<<'EOT'); if {($tclscalar == "newvalue") && ($tclhash(newkey) == 2)} { puts "ok 2" } else { puts "not ok 2" } EOT Tcl-1.05/t/unicode.t0000644552332700244210000000535212734525120014660 0ustar konovvDomain Users#!perl -w # Test the transfer of null and various unicode data through assorted APIs. # The \x{2030} is the permille sign. # # On Unix this progam shows different wrong behaviour depending # on what kind of locale it runs under. use strict; use Test qw(plan ok); plan tests => 6; use Tcl; my $int = Tcl->new; my $str = "This is a string\n"; $str .= "This is a string containing NUL (\0) and some other controls (\a\r)\n"; $str .= "\0 \x{2030}\n"; $str .= "[\0 \x{2030}]\n"; $str .= "bytes: " . join("", map chr, 0 .. 255) . "\n"; $str .= "uni: " . join("", map chr, 0 .. 300) . "\n"; my $output = <<"EOT"; This is a string This is a string containing NUL (\0) and some other controls (\a\r) \0 \x{2030} [\0 \x{2030}] bytes: \0\1\2\3\4\5\6\a\b\t \13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\x7F\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF uni: \0\1\2\3\4\5\6\a\b\t \13\f\r\16\17\20\21\22\23\24\25\26\27\30\31\32\e\34\35\36\37 !\"#\$%&'()*+,-./0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\x7F\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F\x90\x91\x92\x93\x94\x95\x96\x97\x98\x99\x9A\x9B\x9C\x9D\x9E\x9F\xA0\xA1\xA2\xA3\xA4\xA5\xA6\xA7\xA8\xA9\xAA\xAB\xAC\xAD\xAE\xAF\xB0\xB1\xB2\xB3\xB4\xB5\xB6\xB7\xB8\xB9\xBA\xBB\xBC\xBD\xBE\xBF\xC0\xC1\xC2\xC3\xC4\xC5\xC6\xC7\xC8\xC9\xCA\xCB\xCC\xCD\xCE\xCF\xD0\xD1\xD2\xD3\xD4\xD5\xD6\xD7\xD8\xD9\xDA\xDB\xDC\xDD\xDE\xDF\xE0\xE1\xE2\xE3\xE4\xE5\xE6\xE7\xE8\xE9\xEA\xEB\xEC\xED\xEE\xEF\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF\x{100}\x{101}\x{102}\x{103}\x{104}\x{105}\x{106}\x{107}\x{108}\x{109}\x{10A}\x{10B}\x{10C}\x{10D}\x{10E}\x{10F}\x{110}\x{111}\x{112}\x{113}\x{114}\x{115}\x{116}\x{117}\x{118}\x{119}\x{11A}\x{11B}\x{11C}\x{11D}\x{11E}\x{11F}\x{120}\x{121}\x{122}\x{123}\x{124}\x{125}\x{126}\x{127}\x{128}\x{129}\x{12A}\x{12B}\x{12C} EOT my $res = $int->SetVar("unitest", $str); ok($res, $output); $res = $int->Eval("append unitest \"\\0\\1\\2\\n\""); $output .= "\0\1\2\n"; ok($int->result, $output); ok($res, $output); ok($int->GetVar("unitest"), $output); $res = $int->AppendResult("", "\0", "\x{2030}"); $output .= "\0\x{2030}"; ok($res, $output); ok($int->result, $output); Tcl-1.05/t/var.t0000644552332700244210000000243412734525120014020 0ustar konovvDomain Usersuse Tcl; $| = 1; print "1..8\n"; sub foo { my $interp = $_[1]; my $glob = $interp->GetVar("bar", Tcl::GLOBAL_ONLY); my $loc = $interp->GetVar("bar"); print "$glob $loc\n"; $interp->Eval('puts $four', Tcl::EVAL_GLOBAL); } $i = Tcl->new; $i->SetVar("foo", "ok 1"); $i->Eval('puts $foo'); $i->Eval('set foo "ok 2\n"'); print $i->GetVar("foo"); $i->CreateCommand("foo", \&foo); $i->Eval(<<'EOT'); set bar ok set four "ok 4" proc baz {} { set bar 3 set four "not ok 4" foo } baz EOT $i->Eval('set a(OK) ok; set a(five) 5'); $ok = $i->GetVar2("a", "OK"); $five = $i->GetVar2("a", "five"); print "$ok $five\n"; print defined($i->GetVar("nonesuch")) ? "not ok 6\n" : "ok 6\n"; # some Unicode tests if ($]>=5.006 && $i->GetVar("tcl_version")>=8.1) { $i->SetVar("univar","\x{abcd}\x{1234}"); if ($i->GetVar("univar") ne "\x{abcd}\x{1234}") { print "not "; } print "ok 7 # Unicode persistence during [SG]etVar\n"; my $r; tie $r, Tcl::Var, $i, "perl_r"; $r = "\x{abcd}\x{1234}"; if ($r ne "\x{abcd}\x{1234}") { print "not "; } print "ok 8 # Unicode persistence for tied variable\n"; binmode(STDOUT, ":utf8") if $] >= 5.008; print "# $r\n"; } else { for (7..8) {print "ok $_ # skipped: not Unicode-aware Perl or Tcl\n";} } Tcl-1.05/Tcl.pm0000644552332700244210000007076712734526661013711 0ustar konovvDomain Userspackage Tcl; $Tcl::VERSION = '1.05'; =head1 NAME Tcl - Tcl extension module for Perl =head1 SYNOPSIS use Tcl; $interp = Tcl->new; $interp->Eval('puts "Hello world"'); =head1 DESCRIPTION The Tcl extension module gives access to the Tcl library with functionality and interface similar to the C functions of Tcl. In other words, you can =over =item * create Tcl interpreters The Tcl interpreters so created are Perl objects whose destructors delete the interpreters cleanly when appropriate. =item * execute Tcl code in an interpreter The code can come from strings, files or Perl filehandles. =item * bind in new Tcl procedures The new procedures can be either C code (with addresses presumably obtained using I and I) or Perl subroutines (by name, reference or as anonymous subs). The (optional) deleteProc callback in the latter case is another perl subroutine which is called when the command is explicitly deleted by name or else when the destructor for the interpreter object is explicitly or implicitly called. =item * Manipulate the result field of a Tcl interpreter =item * Set and get values of variables in a Tcl interpreter =item * Tie perl variables to variables in a Tcl interpreter The variables can be either scalars or hashes. =back =head2 Methods in class Tcl To create a new Tcl interpreter, use $interp = Tcl->new; The following methods and routines can then be used on the Perl object returned (the object argument omitted in each case). =over =item $interp->Init () Invoke I on the interpreter. =item $interp->CreateSlave (NAME, SAFE) Invoke I on the interpeter. Name is arbitrary. The safe variable, if true, creates a safe sandbox interpreter. See: http://www.tcl.tk/software/plugin/safetcl.html http://www.tcl.tk/man/tcl8.4/TclCmd/safe.htm This command returns a new interpreter. =item $interp->Eval (STRING, FLAGS) Evaluate script STRING in the interpreter. If the script returns successfully (TCL_OK) then the Perl return value corresponds to Tcl interpreter's result otherwise a I exception is raised with the $@ variable corresponding to Tcl's interpreter result object. In each case, I means that if the method is called in scalar context then the string result is returned but if the method is called in list context then the result is split as a Tcl list and returned as a Perl list. The FLAGS field is optional and can be a bitwise OR of the constants Tcl::EVAL_GLOBAL or Tcl::EVAL_DIRECT. =item $interp->GlobalEval (STRING) REMOVED. Evalulate script STRING at global level. Call I(STRING, Tcl::EVAL_GLOBAL) instead. =item $interp->EvalFile (FILENAME) Evaluate the contents of the file with name FILENAME. Otherwise, the same as I() above. =item $interp->EvalFileHandle (FILEHANDLE) Evaluate the contents of the Perl filehandle FILEHANDLE. Otherwise, the same as I() above. Useful when using the filehandle DATA to tack on a Tcl script following an __END__ token. =item $interp->call (PROC, ARG, ...) Looks up procedure PROC in the interpreter and invokes it using Tcl's eval semantics that does command tracing and will use the ::unknown (AUTOLOAD) mechanism. The arguments (ARG, ...) are not passed through the Tcl parser. For example, spaces embedded in any ARG will not cause it to be split into two Tcl arguments before being passed to PROC. Before invoking procedure PROC special processing is performed on ARG list: 1. All subroutine references within ARG will be substituted with Tcl name which is responsible to invoke this subroutine. This Tcl name will be created using CreateCommand subroutine (see below). 2. All references to scalars will be substituted with names of Tcl variables transformed appropriately. These first two items allows one to write and expect it to work properly such code as: my $r = 'aaaa'; button(".d", -textvariable => \$r, -command=>sub {$r++}); 3. All references to hashes will be substituted with names of Tcl array variables transformed appropriately. 4. As a special case, there is a mechanism to deal with Tk's special event variables (they are mentioned as '%x', '%y' and so on throughout Tcl). When creating a subroutine reference that uses such variables, you must declare the desired variables using Tcl::Ev as the first argument to the subroutine. Example: sub textPaste { my ($x,$y,$w) = @_; widget($w)->insert("\@$x,$y", $interp->Eval('selection get')); } $widget->bind('<2>', [\&textPaste, Tcl::Ev('%x', '%y'), $widget] ); =item $interp->return_ref (NAME) returns a reference corresponding to NAME, which was associated during previously called C<< $interpnt->call(...) >> preprocessing. As a typical example this could be variable associated with a widget. =item $interp->delete_ref (NAME) deletes and returns a reference corresponding to NAME, which was associated during previously called C<< $interpnt->call(...) >> preprocessing. =item $interp->icall (PROC, ARG, ...) Looks up procedure PROC in the interpreter and invokes it using Tcl's eval semantics that does command tracing and will use the ::unknown (AUTOLOAD) mechanism. The arguments (ARG, ...) are not passed through the Tcl parser. For example, spaces embedded in any ARG will not cause it to be split into two Tcl arguments before being passed to PROC. This is the lower-level procedure that the 'call' method uses. Arguments are converted efficiently from Perl SVs to Tcl_Objs. A Perl AV array becomes a Tcl_ListObj, an SvIV becomes a Tcl_IntObj, etc. The reverse conversion is done to the result. =item $interp->invoke (PROC, ARG, ...) Looks up procedure PROC in the interpreter and invokes it directly with arguments (ARG, ...) without passing through the Tcl parser. For example, spaces embedded in any ARG will not cause it to be split into two Tcl arguments before being passed to PROC. This differs from icall/call in that it directly invokes the command name without allowing for command tracing or making use of Tcl's unknown (AUTOLOAD) mechanism. If the command does not already exist in the interpreter, and error will be thrown. Arguments are converted efficiently from Perl SVs to Tcl_Objs. A Perl AV array becomes a Tcl_ListObj, an SvIV becomes a Tcl_IntObj, etc. The reverse conversion is done to the result. =item Tcl::Ev (FIELD, ...) Used to declare %-substitution variables of interest to a subroutine callback. FIELD is expected to be of the form "%#" where # is a single character, and multiple fields may be specified. Returns a blessed object that the 'call' method will recognize when it is passed as the first argument to a subroutine in a callback. See description of 'call' method for details. =item $interp->result () Returns the current Tcl interpreter result. List v. scalar context is handled as in I() above. =item $interp->CreateCommand (CMDNAME, CMDPROC, CLIENTDATA, DELETEPROC, FLAGS) Binds a new procedure named CMDNAME into the interpreter. The CLIENTDATA and DELETEPROC arguments are optional. There are two cases: (1) CMDPROC is the address of a C function (presumably obtained using I and I. In this case CLIENTDATA and DELETEPROC are taken to be raw data of the ClientData and deleteProc field presumably obtained in a similar way. (2) CMDPROC is a Perl subroutine (either a sub name, a sub reference or an anonymous sub). In this case CLIENTDATA can be any perl scalar (e.g. a ref to some other data) and DELETEPROC must be a perl sub too. When CMDNAME is invoked in the Tcl interpreter, the arguments passed to the Perl sub CMDPROC are (CLIENTDATA, INTERP, LIST) where INTERP is a Perl object for the Tcl interpreter which called out and LIST is a Perl list of the arguments CMDNAME was called with. If the 1-bit of FLAGS is set then the 3 first arguments on the call to CMDPROC are suppressed. As usual in Tcl, the first element of the list is CMDNAME itself. When CMDNAME is deleted from the interpreter (either explicitly with I or because the destructor for the interpreter object is called), it is passed the single argument CLIENTDATA. =item $interp->DeleteCommand (CMDNAME) Deletes command CMDNAME from the interpreter. If the command was created with a DELETEPROC (see I above), then it is invoked at this point. When a Tcl interpreter object is destroyed either explicitly or implicitly, an implicit I happens on all its currently registered commands. =item $interp->SetResult (STRING) Sets Tcl interpreter result to STRING. =item $interp->AppendResult (LIST) Appends each element of LIST to Tcl's interpreter result object. =item $interp->AppendElement (STRING) Appends STRING to Tcl interpreter result object as an extra Tcl list element. =item $interp->ResetResult () Resets Tcl interpreter result. =item $interp->SplitList (STRING) Splits STRING as a Tcl list. Returns a Perl list or the empty list if there was an error (i.e. STRING was not a properly formed Tcl list). In the latter case, the error message is left in Tcl's interpreter result object. =item $interp->SetVar (VARNAME, VALUE, FLAGS) The FLAGS field is optional. Sets Tcl variable VARNAME in the interpreter to VALUE. The FLAGS argument is the usual Tcl one and can be a bitwise OR of the constants Tcl::GLOBAL_ONLY, Tcl::LEAVE_ERR_MSG, Tcl::APPEND_VALUE, Tcl::LIST_ELEMENT. =item $interp->SetVar2 (VARNAME1, VARNAME2, VALUE, FLAGS) Sets the element VARNAME1(VARNAME2) of a Tcl array to VALUE. The optional argument FLAGS behaves as in I above. =item $interp->GetVar (VARNAME, FLAGS) Returns the value of Tcl variable VARNAME. The optional argument FLAGS behaves as in I above. =item $interp->GetVar2 (VARNAME1, VARNAME2, FLAGS) Returns the value of the element VARNAME1(VARNAME2) of a Tcl array. The optional argument FLAGS behaves as in I above. =item $interp->UnsetVar (VARNAME, FLAGS) Unsets Tcl variable VARNAME. The optional argument FLAGS behaves as in I above. =item $interp->UnsetVar2 (VARNAME1, VARNAME2, FLAGS) Unsets the element VARNAME1(VARNAME2) of a Tcl array. The optional argument FLAGS behaves as in I above. =back =head2 Linking Perl and Tcl variables You can I a Perl variable (scalar or hash) into class Tcl::Var so that changes to a Tcl variable automatically "change" the value of the Perl variable. In fact, as usual with Perl tied variables, its current value is just fetched from the Tcl variable when needed and setting the Perl variable triggers the setting of the Tcl variable. To tie a Perl scalar I<$scalar> to the Tcl variable I in interpreter I<$interp> with optional flags I<$flags> (see I above), use tie $scalar, "Tcl::Var", $interp, "tclscalar", $flags; Omit the I<$flags> argument if not wanted. To tie a Perl hash I<%hash> to the Tcl array variable I in interpreter I<$interp> with optional flags I<$flags> (see I above), use tie %hash, "Tcl::Var", $interp, "array", $flags; Omit the I<$flags> argument if not wanted. Any alteration to Perl variable I<$hash{"key"}> affects the Tcl variable I and I. =head2 Accessing Perl from within Tcl After creation of Tcl interpreter, in addition to evaluation of Tcl/Tk commands within Perl, other way round also instantiated. Within a special namespace C< ::perl > following objects are created: ::perl::Eval So it is possible to use Perl objects from within Tcl. =head2 Moving Tcl/Tk around with Tcl.pm NOTE: explanations below is for developers managing Tcl/Tk installations itself, users should skip this section. In order to create Tcl/Tk application with this module, you need to make sure that Tcl/Tk is available within visibility of this module. There are many ways to achieve this, varying on ease of starting things up and providing flexible moveable archived files. Following list enumerates them, in order of increased possibility to change location. =over =item * First method Install Tcl/Tk first, then install Perl module Tcl, so installed Tcl/Tk will be used. This is most normal approach, and no care of Tcl/Tk distribution is taken on Perl side (this is done on Tcl/Tk side) =item * Second method Copy installed Tcl/Tk binaries to some location, then install Perl module Tcl with a special action to make Tcl.pm know of this location. This approach makes sure that only chosen Tcl installation is used. =item * Third method During compiling Tcl Perl module, Tcl/Tk could be statically linked into module's shared library and all other files zipped into a single archive, so each file extracted when needed. To link Tcl/Tk binaries, prepare their libraries and then instruct Makefile.PL to use these libraries in a link stage. (TODO provide better detailed description) =back =cut use strict; our $DL_PATH; unless (defined $DL_PATH) { $DL_PATH = $ENV{PERL_TCL_DL_PATH} || $ENV{PERL_TCL_DLL} || ""; } =ignore sub Tcl::seek_tkkit { # print STDERR "wohaaa!\n"; unless ($DL_PATH) { require Config; for my $inc (@INC) { my $tkkit = "$inc/auto/Tcl/tkkit.$Config::Config{so}"; if (-f $tkkit) { $DL_PATH = $tkkit; last; } } } } =cut seek_tkkit() if defined &seek_tkkit; my $path; if ($^O eq 'darwin') { # Darwin 7.9 (OS X 10.3) requires the path of the executable be prepended # for #! scripts to operate properly (avoids RegisterProcess error). require Config; unless (grep { $_ eq $Config::Config{binexp} } split $Config::Config{path_sep}, $ENV{PATH}) { $path = join $Config::Config{path_sep}, $Config::Config{binexp}, $ENV{PATH}; } } require XSLoader; { local $ENV{PATH} = $path if $path; XSLoader::load('Tcl', $Tcl::VERSION); } sub new { my $int = _new(@_); return $int; } END { Tcl::_Finalize(); } # %anon_refs keeps track of anonymous subroutines and scalar/array/hash # references which are created on the fly for tcl/tk interchange # at a step when 'call' interpreter method prepares its arguments for # tcl/tk call, which is invoked by 'icall' interpreter method # (this argument transformation is done with "CreateCommand" method for # subs and with 'tie' for other) my %anon_refs; # (TODO -- find out how to check for refcounting and proper releasing of # resources) # Subroutine "call" preprocess the arguments for special cases # and then calls "icall" (implemented in Tcl.xs), which invokes # the command in Tcl. sub call { my $interp = shift; my @args = @_; my $current_r = join ' ', grep {defined} grep {!ref} @args; my @codes; # Process arguments looking for special cases for (my $argcnt=0; $argcnt<=$#args; $argcnt++) { my $arg = $args[$argcnt]; my $ref = ref($arg); next unless $ref; if ($ref eq 'CODE' || $ref eq 'Tcl::Code') { # We have been passed something like \&subroutine # Create a proc in Tcl that invokes this subroutine (no args) $args[$argcnt] = $interp->create_tcl_sub($arg, undef, undef, $current_r); push @codes, $anon_refs{$current_r}; # push CODE also only to keep it from early disposal } elsif ($ref eq 'SCALAR') { # We have been passed something like \$scalar # Create a tied variable between Tcl and Perl. # stringify scalar ref, create in ::perl namespace on Tcl side # This will be SCALAR(0xXXXXXX) - leave it to become part of a # Tcl array. my $nm = "::perl::$arg"; unless (exists $anon_refs{$nm}) { $anon_refs{$nm} = $arg; my $s = $$arg; tie $$arg, 'Tcl::Var', $interp, $nm; $s = '' unless defined $s; $$arg = $s; } $args[$argcnt] = $nm; # ... and substitute its name } elsif ($ref eq 'HASH') { # We have been passed something like \%hash # Create a tied variable between Tcl and Perl. # stringify hash ref, create in ::perl namespace on Tcl side # This will be HASH(0xXXXXXX) - leave it to become part of a # Tcl array. my $nm = $arg; $nm =~ s/\W/_/g; # remove () from stringified name $nm = "::perl::$nm"; unless (exists $anon_refs{$nm}) { $anon_refs{$nm} = $arg; my %s = %$arg; tie %$arg, 'Tcl::Var', $interp, $nm; %$arg = %s; } $args[$argcnt] = $nm; # ... and substitute its name } elsif ($ref eq 'ARRAY' && ref($arg->[0]) eq 'CODE') { # We have been passed something like [\&subroutine, $arg1, ...] # Create a proc in Tcl that invokes this subroutine with args my $events; # Look for Tcl::Ev objects as the first arg - these must be # passed through for Tcl to evaluate. Used primarily for %-subs # This could check for any arg ref being Tcl::Ev obj, but it # currently doesn't. if ($#$arg >= 1 && ref($arg->[1]) eq 'Tcl::Ev') { $events = splice(@$arg, 1, 1); } $args[$argcnt] = $interp->create_tcl_sub(sub { $arg->[0]->(@_, @$arg[1..$#$arg]); }, $events, undef, $current_r); push @codes, $anon_refs{$current_r}; } elsif ($ref eq 'REF' and ref($$arg) eq 'SCALAR') { # this is a very special shortcut: if we see construct like \\"xy" # then place proper Tcl::Ev(...) for easier access my $events = [map {"%$_"} split '', $$$arg]; if (ref($args[$argcnt+1]) eq 'ARRAY' && ref($args[$argcnt+1]->[0]) eq 'CODE') { $arg = $args[$argcnt+1]; $args[$argcnt] = $interp->create_tcl_sub(sub { $arg->[0]->(@_, @$arg[1..$#$arg]); }, $events, undef, $current_r); push @codes, $anon_refs{$current_r}; } elsif (ref($args[$argcnt+1]) eq 'CODE') { $args[$argcnt] = $interp->create_tcl_sub($args[$argcnt+1],$events, undef, $current_r); push @codes, $anon_refs{$current_r}; } else { warn "not CODE/ARRAY expected after description of event fields"; } splice @args, $argcnt+1, 1; } } if ($#codes>-1 and $args[0] eq 'after') { if ($args[1] =~ /^\d+$/) { my $id = $interp->icall(@args); #print STDERR "rebind for $interp;$id\n"; # in 'after' methods, disposal of CODE REFs based on 'after' id # i.e based on return value of tcl call $anon_refs{"$interp;$id"} = \@codes; delete $anon_refs{$current_r}; # plan deleting that entry, hence Tcl command during Tcl::Code::DESTROY # TODO - this +1000 is wrong... should $interp->invoke('after',$args[1]+1000, "perl::Eval {Tcl::_code_dispose('$interp;$id')}"); return $id; } elsif ($args[1] eq 'idle') { # no planned CODE REF disposal, just do as is return $interp->icall(@args); } # if we're here - user does something wrong, but there is nothing we worry about } # Done with special var processing. The only processing that icall # will do with the args is efficient conversion of SV to Tcl_Obj. # A SvIV will become a Tcl_IntObj, ARRAY refs will become Tcl_ListObjs, # and so on. The return result from icall will do the opposite, # converting a Tcl_Obj to an SV. # we need just this: # return $interp->icall(@args); # a bit of complications only to allow stack trace, i.e. in case of errors # user will get error pointing to his program and not in this module. # and also 'after' tcl method makes bit harder if (wantarray) { my @res; eval { @res = $interp->icall(@args); }; if ($@) { require Carp; Carp::croak ("Tcl error '$@' while invoking array result call:\n" . "\t\"@args\""); } return @res; } else { my $res; eval { $res = $interp->icall(@args); }; if ($@) { require Carp; Carp::croak ("Tcl error '$@' while invoking scalar result call:\n" . "\t\"@args\""); } return $res; } } # create_tcl_sub will create TCL sub that will invoke perl CODE ref # If $events variable is specified then special processing will be # performed to provide needed '%' variables. # If $tclname is specified then procedure will have namely that name, # otherwise it will have machine-readable name. # Returns tcl script suitable for using in tcl events. sub create_tcl_sub { my ($interp,$sub,$events,$tclname, $rname) = @_; unless ($tclname) { # stringify sub, becomes "CODE(0x######)" in ::perl namespace $tclname = "::perl::$sub"; } #print STDERR "...=$rname\n"; $interp->CreateCommand($tclname, $sub, undef, undef, 1); # following line a bit more tricky than it seems to. # because the whole intent of the %anon_refs hash is to have refcount # of (possibly) anonymous sub that is happen to be passed, # and, if passed for the same widget but arguments are same - then # previous instance will be overwriten, and sub will be destroyed due # to reference count, and Tcl method will also be destroyed during # Tcl::Code::DESTROY $anon_refs{$rname} = bless [\$sub, $interp], 'Tcl::Code'; if ($events) { # Add any %-substitutions to callback $tclname = "$tclname " . join(' ', @{$events}); } return $tclname; } sub _code_dispose { my $k = shift; #print STDERR "_code_dispose $k\n"; #my $int = $anon_refs{$k}->[0]->[1]; #my @r = $int->Eval("after info $id"); # why do not work? #print STDERR "r=@r\n"; delete $anon_refs{$k}; } sub Ev { my @events = @_; return bless \@events, "Tcl::Ev"; } package Tcl::Code; # only purpose is to track CODE REFs passed to 'call' method # (often these are anon subs) # so to bless it to this package and then catch deleting it, so # to do cleaning up sub DESTROY { my $rsub = $_[0]->[0]; my $interp = $_[0]->[1]; my $tclname = "::perl::$$rsub"; #print STDERR "CODE::DESTROY[[@_]] $tclname\n"; $interp->DeleteCommand($tclname) if defined $interp; } package Tcl::List; use overload '""' => \&as_string, fallback => 1; package Tcl::Var; sub TIESCALAR { my $class = shift; my @objdata = @_; unless (@_ == 2 || @_ == 3) { require Carp; Carp::croak('Usage: tie $s, Tcl::Var, $interp, $varname [, $flags]'); }; bless \@objdata, $class; } sub TIEHASH { my $class = shift; my @objdata = @_; unless (@_ == 2 || @_ == 3) { require Carp; Carp::croak('Usage: tie %hash, Tcl::Var, $interp, $varname [, $flags]'); } bless \@objdata, $class; } my %arraystates; sub FIRSTKEY { my $obj = shift; die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" unless @{$obj} == 2 || @{$obj} == 3; my ($interp, $varname, $flags) = @$obj; $arraystates{$varname} = $interp->invoke("array","startsearch",$varname); my $r = $interp->invoke("array","nextelement",$varname,$arraystates{$varname}); if ($r eq '') { delete $arraystates{$varname}; return undef; } return $r; } sub NEXTKEY { my $obj = shift; die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" unless @{$obj} == 2 || @{$obj} == 3; my ($interp, $varname, $flags) = @$obj; my $r = $interp->invoke("array","nextelement",$varname,$arraystates{$varname}); if ($r eq '') { delete $arraystates{$varname}; return undef; } return $r; } sub CLEAR { my $obj = shift; die "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" unless @{$obj} == 2 || @{$obj} == 3; my ($interp, $varname, $flags) = @$obj; $interp->invoke("array", "unset", "$varname"); #$interp->invoke("array", "set", "$varname", ""); } sub DELETE { my $obj = shift; unless (@{$obj} == 2 || @{$obj} == 3) { require Carp; Carp::croak("STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)"); } my ($interp, $varname, $flags) = @{$obj}; my ($str1) = @_; $interp->invoke("unset", "$varname($str1)"); # protect strings? } sub UNTIE { my $ref = shift; #print STDERR "UNTIE:$ref(@_)\n"; } sub DESTROY { my $ref = shift; delete $anon_refs{$ref->[1]}; } # This is the perl equiv to the C version, for reference # #sub STORE { # my $obj = shift; # croak "STORE Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" # unless @{$obj} == 2 || @{$obj} == 3; # my ($interp, $varname, $flags) = @{$obj}; # my ($str1, $str2) = @_; # if ($str2) { # $interp->SetVar2($varname, $str1, $str2, $flags); # } else { # $interp->SetVar($varname, $str1, $flags || 0); # } #} # #sub FETCH { # my $obj = shift; # croak "FETCH Usage: objdata @{$obj} $#{$obj}, not 2 or 3 (@_)" # unless @{$obj} == 2 || @{$obj} == 3; # my ($interp, $varname, $flags) = @{$obj}; # my $key = shift; # if ($key) { # return $interp->GetVar2($varname, $key, $flags || 0); # } else { # return $interp->GetVar($varname, $flags || 0); # } #} package Tcl; =head1 Other Tcl interpreter methods =over 2 =item export_to_tcl method An interpreter method, export_to_tcl, is used to expose a number of perl subroutines and variables all at once into tcl/tk. B takes a hash as arguments, which represents named parameters, with following allowed values: =over 4 =item B => '...' tcl namespace, where commands and variables are to be created, defaults to 'perl'. If '' is specified - then global namespace is used. A possible '::' at end is stripped. =item B => { ... } anonymous hash of subs to be created in Tcl, in the form /tcl name/ => /code ref/ =item B => { ... } anonymous hash of vars to be created in Tcl, in the form /tcl name/ => /code ref/ =item B => '...' a name of Perl namespace, from where all existing subroutines will be searched and Tcl command will be created for each of them. =item B => '...' a name of Perl namespace, from where all existing variables will be searched, and each such variable will be tied to Tcl. =back An example: use strict; use Tcl; my $int = Tcl->new; $tcl::foo = 'qwerty'; $int->export_to_tcl(subs_from=>'tcl',vars_from=>'tcl'); $int->Eval(<<'EOS'); package require Tk button .b1 -text {a fluffy button} -command perl::fluffy_sub button .b2 -text {a foo button} -command perl::foo entry .e -textvariable perl::foo pack .b1 .b2 .e focus .b2 tkwait window . EOS sub tcl::fluffy_sub { print "Hi, I am a fluffy sub\n"; } sub tcl::foo { print "Hi, I am foo\n"; $tcl::foo++; } =cut sub export_to_tcl { my $int = shift; my %args = @_; # name of Tcl package to hold tcl commands bound to perl subroutines my $tcl_namespace = (exists $args{namespace} ? $args{namespace} : 'perl::'); $tcl_namespace=~s/(?:::)?$/::/; # a batch of perl subroutines which tcl counterparts should be created my $subs = $args{subs} || {}; # a batch of perl variables which tcl counterparts should be created my $vars = $args{vars} || {}; # TBD: # only => \@list_of_names # argument to be able to limit the names to export to Tcl. if (exists $args{subs_from}) { # name of Perl package, which subroutines would be bound to tcl commands my $subs_from = $args{subs_from}; $subs_from =~ s/::$//; no strict 'refs'; for my $name (keys %{"$subs_from\::"}) { #print STDERR "$name;\n"; if (defined &{"$subs_from\::$name"}) { if (exists $subs->{$name}) { next; } #print STDERR "binding sub '$name'\n"; $int->CreateCommand("$tcl_namespace$name", \&{"$subs_from\::$name"}, undef, undef, 1); } } } if (exists $args{vars_from}) { # name of Perl package, which subroutines would be bound to tcl commands my $vars_from = $args{vars_from}; $vars_from =~ s/::$//; no strict 'refs'; for my $name (keys %{"$vars_from\::"}) { #print STDERR "$name;\n"; if (defined ${"$vars_from\::$name"}) { if (exists $vars->{$name}) { next; } #print STDERR "binding var '$name' in '$tcl_namespace'\n"; local $_ = ${"$vars_from\::$name"}; tie ${"$vars_from\::$name"}, 'Tcl::Var', $int, "$tcl_namespace$name"; ${"$vars_from\::$name"} = $_; } if (0) { # array, hash - no need to do anything. # (or should we?) } } } for my $subname (keys %$subs) { #print STDERR "binding2 sub '$subname'\n"; $int->CreateCommand("$tcl_namespace$subname",$subs->{$subname}, undef, undef, 1); } for my $varname (keys %$vars) { #print STDERR "binding2 var '$varname'\n"; unless (ref($vars->{$varname})) { require 'Carp.pm'; Carp::croak("should pass var ref as variable bind parameter"); } local $_ = ${$vars->{$varname}}; tie ${$vars->{$varname}}, 'Tcl::Var', $int, "$tcl_namespace$varname"; ${$vars->{$varname}} = $_; } } =item B extra convenience sub, binds to tcl all subs and vars from perl B namespace =back =cut sub export_tcl_namespace { my $int = shift; $int->export_to_tcl(subs_from=>'tcl', vars_from=>'tcl'); } =head1 AUTHORS Malcolm Beattie, 23 Oct 1994 Vadim Konovalov, 19 May 2003 Jeff Hobbs, jeff (a) activestate . com, 22 Mar 2004 Gisle Aas, gisle (a) activestate . com, 14 Apr 2004 Special thanks for contributions to Jan Dubois, Slaven Rezic, Paul Cochrane. =head1 COPYRIGHT This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut 1; Tcl-1.05/Tcl.xs0000644552332700244210000012706712734525120013710 0ustar konovvDomain Users/* * Tcl.xs -- * * This file contains XS code for the Perl's Tcl bridge module. * * Copyright (c) 1994-1997, Malcolm Beattie * Copyright (c) 2003-2004, Vadim Konovalov * Copyright (c) 2004 ActiveState Corp., a division of Sophos PLC * */ #define PERL_NO_GET_CONTEXT /* we want efficiency */ #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifndef DEBUG_REFCOUNTS #define DEBUG_REFCOUNTS 0 #endif /* * Until we update for 8.4 CONST-ness */ #define USE_NON_CONST /* * Both Perl and Tcl use these macros */ #undef STRINGIFY #undef JOIN #include #ifdef USE_TCL_STUBS /* * If we use the Tcl stubs mechanism, this provides us Tcl version * and direct dll independence, but we must force the loading of * the dll ourselves based on a set of heuristics in NpLoadLibrary. */ #ifndef TCL_LIB_FILE # ifdef WIN32 # define TCL_LIB_FILE "tcl84.dll" # elif defined(__APPLE__) # define TCL_LIB_FILE "Tcl" # elif defined(__hpux) # define TCL_LIB_FILE "libtcl8.4.sl" # else # define TCL_LIB_FILE "libtcl8.4.so" # endif #endif /* * Default directory in which to look for Tcl/Tk libraries. The * symbol is defined by Makefile. */ #ifndef LIB_RUNTIME_DIR # define LIB_RUNTIME_DIR "." #endif static char defaultLibraryDir[sizeof(LIB_RUNTIME_DIR)+200] = LIB_RUNTIME_DIR; #if defined(WIN32) #ifndef HMODULE #define HMODULE void * #endif #define WIN32_LEAN_AND_MEAN #include #undef WIN32_LEAN_AND_MEAN #define dlopen(libname, flags) LoadLibrary(libname) #define dlclose(path) ((void *) FreeLibrary((HMODULE) path)) #define DLSYM(handle, symbol, type, proc) \ (proc = (type) GetProcAddress((HINSTANCE) handle, symbol)) #define snprintf _snprintf #elif defined(__APPLE__) #include static short DOMAINS[] = { kUserDomain, kLocalDomain, kNetworkDomain, kSystemDomain }; static const int DOMAINS_LEN = sizeof(DOMAINS)/sizeof(DOMAINS[0]); #elif defined(__hpux) /* HPUX requires shl_* routines */ #include #define HMODULE shl_t #define dlopen(libname, flags) shl_load(libname, \ BIND_DEFERRED|BIND_VERBOSE|DYNAMIC_PATH, 0L) #define dlclose(path) shl_unload((shl_t) path) #define DLSYM(handle, symbol, type, proc) \ if (shl_findsym(&handle, symbol, (short) TYPE_PROCEDURE, \ (void *) &proc) != 0) { proc = NULL; } #endif #ifndef HMODULE #include #define HMODULE void * #define DLSYM(handle, symbol, type, proc) \ (proc = (type) dlsym(handle, symbol)) #endif #ifndef MAX_PATH #define MAX_PATH 1024 #endif /* * Tcl library handle */ static HMODULE tclHandle = NULL; static Tcl_Interp *g_Interp = NULL; static int (* tclKit_AppInit)(Tcl_Interp *) = NULL; #else /* * !USE_TCL_STUBS */ static int (* tclKit_AppInit)(Tcl_Interp *) = Tcl_Init; #if defined(HAVE_TKINIT) && defined(WIN32) HANDLE _hinst = 0; BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, LPVOID reserved) { _hinst = hInst; return TRUE; } #endif #endif typedef Tcl_Interp *Tcl; typedef AV *Tcl__Var; #ifdef HAVE_TKINIT EXTERN char * TclSetPreInitScript (char * string); void TclpInitLibraryPath(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); EXTERN void TkWinSetHINSTANCE (HINSTANCE hInstance); #endif #ifdef HAVE_BLTINIT extern Tcl_PackageInitProc Blt_Init, Blt_SafeInit; #endif /* * Variables denoting the Tcl object types defined in the core. * These may not exist - guard against NULL result. */ static Tcl_ObjType *tclBooleanTypePtr = NULL; static Tcl_ObjType *tclByteArrayTypePtr = NULL; static Tcl_ObjType *tclDoubleTypePtr = NULL; static Tcl_ObjType *tclIntTypePtr = NULL; static Tcl_ObjType *tclListTypePtr = NULL; static Tcl_ObjType *tclStringTypePtr = NULL; static Tcl_ObjType *tclWideIntTypePtr = NULL; /* * This tells us whether Tcl is in a "callable" state. Set to 1 in BOOT * and 0 in Tcl__Finalize (END). Once finalized, we should not make any * more calls to Tcl_* APIs. * hvInterps is a hash that records all live interps, so that we can * force their deletion before the finalization. */ static int initialized = 0; static HV *hvInterps = NULL; /* * FUNCTIONS */ #ifdef USE_TCL_STUBS /* *---------------------------------------------------------------------- * * NpLoadLibrary -- * * * Results: * Stores the handle of the library found in tclHandle and the * name it successfully loaded from in dllFilename (if dllFilenameSize is != 0). * * Side effects: * Loads the library - user needs to dlclose it.. * *---------------------------------------------------------------------- */ static int NpLoadLibrary(pTHX_ HMODULE *tclHandle, char *dllFilename, int dllFilenameSize) { char *dl_path, libname[MAX_PATH]; HMODULE handle = (HMODULE) NULL; /* * Try a user-supplied Tcl dll to start with. * If the var is supplied, force this to be correct or error out. */ dl_path = SvPV_nolen(get_sv("Tcl::DL_PATH", TRUE)); if (dl_path && *dl_path) { handle = dlopen(dl_path, RTLD_NOW | RTLD_GLOBAL); if (handle) { memcpy(libname, dl_path, MAX_PATH); } else { #if !defined(WIN32) && !defined(__hpux) char *error = dlerror(); if (error != NULL) { warn("%s",error); } #endif warn("NpLoadLibrary: could not find Tcl library at '%s'", dl_path); return TCL_ERROR; } } #ifdef __APPLE__ if (!handle) { OSErr oserr; FSRef ref; int i; for (i = 0; i < DOMAINS_LEN; i++) { oserr = FSFindFolder(DOMAINS[i], kFrameworksFolderType, kDontCreateFolder, &ref); if (oserr != noErr) { continue; } oserr = FSRefMakePath(&ref, (UInt8*)libname, sizeof(libname)); if (oserr != noErr) { continue; } /* * This should really just try loading Tcl.framework/Tcl, but will * fail if the user has requested an alternate TCL_LIB_FILE. */ strcat(libname, "/Tcl.framework/" TCL_LIB_FILE); /* printf("Try \"%s\"\n", libname); */ handle = dlopen(libname, RTLD_NOW | RTLD_GLOBAL); if (handle) { break; } } } #endif if (!handle) { if (strlen(TCL_LIB_FILE) < 3) { warn("Invalid base Tcl library filename provided: '%s'", TCL_LIB_FILE); return TCL_ERROR; } /* Try based on full path. */ snprintf(libname, MAX_PATH-1, "%s/%s", defaultLibraryDir, TCL_LIB_FILE); handle = dlopen(libname, RTLD_NOW | RTLD_GLOBAL); if (!handle) { /* Try based on anywhere in the path. */ strcpy(libname, TCL_LIB_FILE); handle = dlopen(libname, RTLD_NOW | RTLD_GLOBAL); } if (!handle) { /* Try different versions anywhere in the path. */ char *pos = strstr(libname, "tcl8")+4; if (*pos == '.') { pos++; } *pos = '9'; /* count down from '8' to '4', and then to '0', it is also ok*/ while (!handle && (--*pos >= '0')) { handle = dlopen(libname, RTLD_NOW | RTLD_GLOBAL); } if (!handle) { warn("failed all posible tcl vers 8.x from 9 down to 0"); return TCL_ERROR; } } } #ifdef WIN32 if (!handle) { char path[MAX_PATH], vers[MAX_PATH]; DWORD result, size = MAX_PATH; HKEY regKey; #define TCL_REG_DIR_KEY "Software\\ActiveState\\ActiveTcl" result = RegOpenKeyEx(HKEY_LOCAL_MACHINE, TCL_REG_DIR_KEY, 0, KEY_READ, ®Key); if (result != ERROR_SUCCESS) { warn("Could not access registry \"HKLM\\%s\"\n", TCL_REG_DIR_KEY); result = RegOpenKeyEx(HKEY_CURRENT_USER, TCL_REG_DIR_KEY, 0, KEY_READ, ®Key); if (result != ERROR_SUCCESS) { warn("Could not access registry \"HKCU\\%s\"\n", TCL_REG_DIR_KEY); return TCL_ERROR; } } result = RegQueryValueEx(regKey, "CurrentVersion", NULL, NULL, vers, &size); RegCloseKey(regKey); if (result != ERROR_SUCCESS) { warn("Could not access registry \"%s\" CurrentVersion\n", TCL_REG_DIR_KEY); return TCL_ERROR; } snprintf(path, MAX_PATH-1, "%s\\%s", TCL_REG_DIR_KEY, vers); result = RegOpenKeyEx(HKEY_LOCAL_MACHINE, path, 0, KEY_READ, ®Key); if (result != ERROR_SUCCESS) { warn("Could not access registry \"%s\"\n", path); return TCL_ERROR; } size = MAX_PATH; result = RegQueryValueEx(regKey, NULL, NULL, NULL, path, &size); RegCloseKey(regKey); if (result != ERROR_SUCCESS) { warn("Could not access registry \"%s\" Default\n", TCL_REG_DIR_KEY); return TCL_ERROR; } warn("Found current Tcl installation at \"%s\"\n", path); snprintf(libname, MAX_PATH-1, "%s\\bin\\%s", path, TCL_LIB_FILE); handle = dlopen(libname, RTLD_NOW | RTLD_GLOBAL); } #endif if (!handle) { warn("NpLoadLibrary: could not find Tcl dll\n"); return TCL_ERROR; } *tclHandle = handle; if (dllFilenameSize > 0) { memcpy(dllFilename, libname, dllFilenameSize); } return TCL_OK; } /* *---------------------------------------------------------------------- * * NpInitialize -- * * Create the main interpreter. * * Results: * TCL_OK or TCL_ERROR - whether succeeded or not * * Side effects: * Will panic if called twice. (Must call DestroyMainInterp in between) * *---------------------------------------------------------------------- */ static int NpInitialize(pTHX_ SV *X) { static Tcl_Interp * (* createInterp)() = NULL; static void (* findExecutable)(char *) = NULL; /* * We want the Tcl_InitStubs func static to ourselves - before Tcl * is loaded dyanmically and possibly changes it. */ static CONST char *(*initstubs)(Tcl_Interp *, CONST char *, int) = Tcl_InitStubs; char dllFilename[MAX_PATH]; dllFilename[0] = '\0'; #ifdef USE_TCL_STUBS /* * Determine the libname and version number dynamically */ if (tclHandle == NULL) { /* * First see if some other part didn't already load Tcl. */ DLSYM(tclHandle, "Tcl_CreateInterp", Tcl_Interp * (*)(), createInterp); if (createInterp == NULL) { if (NpLoadLibrary(aTHX_ &tclHandle, dllFilename, MAX_PATH) != TCL_OK) { warn("Failed to load Tcl dll!"); return TCL_ERROR; } } DLSYM(tclHandle, "Tcl_CreateInterp", Tcl_Interp * (*)(), createInterp); if (createInterp == NULL) { #if !defined(WIN32) && !defined(__hpux) char *error = dlerror(); if (error != NULL) { warn("%s",error); } #endif return TCL_ERROR; } DLSYM(tclHandle, "Tcl_FindExecutable", void (*)(char *), findExecutable); DLSYM(tclHandle, "TclKit_AppInit", int (*)(Tcl_Interp *), tclKit_AppInit); } #else createInterp = Tcl_CreateInterp; findExecutable = Tcl_FindExecutable; #endif #ifdef WIN32 if (dllFilename[0] == '\0') { GetModuleFileNameA((HINSTANCE) tclHandle, dllFilename, MAX_PATH); } findExecutable(dllFilename); #else findExecutable(X && SvPOK(X) ? SvPV_nolen(X) : NULL); #endif g_Interp = createInterp(); if (g_Interp == (Tcl_Interp *) NULL) { warn("Failed to create main Tcl interpreter!"); return TCL_ERROR; } /* * Until Tcl_InitStubs is called, we cannot make any Tcl/Tk API * calls without grabbing them by symbol out of the dll. * This will be Tcl_PkgRequire for non-stubs builds. */ if (initstubs(g_Interp, "8.4", 0) == NULL) { warn("Failed to initialize Tcl stubs!"); return TCL_ERROR; } /* * If we didn't find TclKit_AppInit, then this is a regular Tcl * installation, so invoke Tcl_Init. * Otherwise, we need to set the kit path to indicate we want to * use the dll as our base kit. */ if (tclKit_AppInit == NULL) { tclKit_AppInit = Tcl_Init; } else { char * (* tclKit_SetKitPath)(char *) = NULL; /* * We need to see if this has TclKit_SetKitPath. This is in * special base kit dlls that have embedded data in the dll. */ if (dllFilename[0] != '\0') { DLSYM(tclHandle, "TclKit_SetKitPath", char * (*)(char *), tclKit_SetKitPath); if (tclKit_SetKitPath != NULL) { /* * XXX: Need to figure out how to populate dllFilename if * NpLoadLibrary didn't do it for us on Unix. */ tclKit_SetKitPath(dllFilename); } } } if (tclKit_AppInit(g_Interp) != TCL_OK) { CONST84 char *msg = Tcl_GetVar(g_Interp, "errorInfo", TCL_GLOBAL_ONLY); warn("Failed to initialize Tcl with %s:\n%s", (tclKit_AppInit == Tcl_Init) ? "Tcl_Init" : "TclKit_AppInit", msg); return TCL_ERROR; } /* * Hold on to the interp handle until finalize, as special * kit-based interps require the first initialized interp to * remain alive. */ return TCL_OK; } #endif #if DEBUG_REFCOUNTS static void check_refcounts(Tcl_Obj *objPtr) { int rc = objPtr->refCount; if (rc != 1) { fprintf(stderr, "objPtr %p refcount %d\n", objPtr, rc); fflush(stderr); } if (objPtr->typePtr == tclListTypePtr) { int objc, i; Tcl_Obj **objv; Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); for (i = 0; i < objc; i++) { check_refcounts(objv[i]); } } } #endif static int has_highbit(CONST char *s, int len) { CONST char *e = s + len; while (s < e) { if (*s++ & 0x80) return 1; } return 0; } static SV * SvFromTclObj(pTHX_ Tcl_Obj *objPtr) { SV *sv; int len; char *str; if (objPtr == NULL) { /* * Use newSV(0) instead of &PL_sv_undef as it may be stored in an AV. * It also provides symmetry with the other newSV* calls below. * This SV will also be mortalized later. */ sv = newSV(0); } else if (objPtr->typePtr == tclIntTypePtr) { sv = newSViv(objPtr->internalRep.longValue); } else if (objPtr->typePtr == tclDoubleTypePtr) { sv = newSVnv(objPtr->internalRep.doubleValue); } else if (objPtr->typePtr == tclBooleanTypePtr) { /* * Booleans can originate as words (yes/true/...), so if there is a * string rep, use it instead. We could check if the first byte * isdigit(). No need to check utf-8 as the all valid boolean words * are ascii-7. */ if (objPtr->typePtr == NULL) { sv = newSVsv(boolSV(objPtr->internalRep.longValue != 0)); } else { str = Tcl_GetStringFromObj(objPtr, &len); sv = newSVpvn(str, len); } } else if (objPtr->typePtr == tclByteArrayTypePtr) { str = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); sv = newSVpvn(str, len); } else if (objPtr->typePtr == tclListTypePtr) { /* * tclListTypePtr should become an AV. * This code needs to reconcile with G_ context in prepare_Tcl_result * and user's expectations of how data will be passed in. The key is * that a stringified-list and pure-list should be operable in the * same way in Perl. * * We have to watch for "empty" lists, which could equate to the * empty string. Tcl's literal object sharing means that "" could * be typed as a list, although we don't want to see it that way. * Just treat empty list objects as an empty (not undef) SV. */ int objc; Tcl_Obj **objv; Tcl_ListObjGetElements(NULL, objPtr, &objc, &objv); if (objc) { int i; AV *av = newAV(); for (i = 0; i < objc; i++) { av_push(av, SvFromTclObj(aTHX_ objv[i])); } sv = sv_bless(newRV_noinc((SV *) av), gv_stashpv("Tcl::List", 1)); } else { sv = newSVpvn("", 0); } } /* tclStringTypePtr is true unicode */ /* tclWideIntTypePtr is 64-bit int */ else { str = Tcl_GetStringFromObj(objPtr, &len); sv = newSVpvn(str, len); /* should turn on, but let's check this first for efficiency */ if (len && has_highbit(str, len)) { /* * Tcl can encode NULL as overlong utf-8 \300\200 (\xC0\x80). * Tcl itself doesn't require this, but some extensions do when * they pass the string data to native C APIs (like strlen). * Tk is the most notable case for this (calling out to native UI * toolkit APIs that don't take counted strings). * s/\300\200/\0/g */ char *nul_start; STRLEN len; char *s = SvPV(sv, len); char *end = s + len; while ((nul_start = memchr(s, '\300', len))) { if (nul_start + 1 < end && nul_start[1] == '\200') { /* found it */ nul_start[0] = '\0'; memmove(nul_start + 1, nul_start + 2, end - (nul_start + 2)); len--; end--; *end = '\0'; SvCUR_set(sv, SvCUR(sv) - 1); } len -= (nul_start + 1) - s; s = nul_start + 1; } SvUTF8_on(sv); } } return sv; } /* * Create a Tcl_Obj from a Perl SV. * Return Tcl_Obj with refcount = 0. Caller should call Tcl_IncrRefCount * or pass of to function that does (manage object lifetime). */ static Tcl_Obj * TclObjFromSv(pTHX_ SV *sv) { Tcl_Obj *objPtr = NULL; if (SvGMAGICAL(sv)) mg_get(sv); if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV && (!SvOBJECT(SvRV(sv)) || sv_isa(sv, "Tcl::List"))) { /* * Recurse into ARRAYs, turning them into Tcl list Objs */ SV **svp; AV *av = (AV *) SvRV(sv); I32 avlen = av_len(av); int i; objPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); for (i = 0; i <= avlen; i++) { svp = av_fetch(av, i, FALSE); if (svp == NULL) { /* watch for sparse arrays - translate as empty element */ /* XXX: Is this handling refcount on NewObj right? */ Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewObj()); } else { if ((AV *) SvRV(*svp) == av) { /* XXX: Is this a proper check for cyclical reference? */ croak("cyclical array reference found"); abort(); } Tcl_ListObjAppendElement(NULL, objPtr, TclObjFromSv(aTHX_ sv_mortalcopy(*svp))); } } } else if (SvPOK(sv)) { STRLEN length; char *str = SvPV(sv, length); /* * Tcl's "String" object expects utf-8 strings. If we aren't sure * that we have a utf-8 data, pass it as a Tcl ByteArray (C char*). * * XXX Possible optimization opportunity here. Tcl will actually * XXX accept and handle most latin-1 char sequences correctly, but * XXX not blocks of truly binary data. This code is 100% correct, * XXX but could be tweaked to improve performance. */ if (SvUTF8(sv)) { /* * Tcl allows NULL to be encoded overlong as \300\200 (\xC0\x80). * Tcl itself doesn't require this, but some extensions do when * they pass the string data to native C APIs (like strlen). * Tk is the most notable case for this (calling out to native UI * toolkit APIs that don't take counted strings). */ if (memchr(str, '\0', length)) { /* ($sv_copy = $sv) =~ s/\0/\300\200/g */ SV *sv_copy = sv_mortalcopy(sv); STRLEN len; char *s = SvPV(sv_copy, len); char *nul; while ((nul = memchr(s, '\0', len))) { STRLEN i = nul - SvPVX(sv_copy); s = SvGROW(sv_copy, SvCUR(sv_copy) + 2); nul = s + i; memmove(nul + 2, nul + 1, SvEND(sv_copy) - (nul + 1)); nul[0] = '\300'; nul[1] = '\200'; SvCUR_set(sv_copy, SvCUR(sv_copy) + 1); s = nul + 2; len = SvEND(sv_copy) - s; } str = SvPV(sv_copy, length); } objPtr = Tcl_NewStringObj(str, length); } else { objPtr = Tcl_NewByteArrayObj((unsigned char *)str, length); } } else if (SvNOK(sv)) { double dval = SvNV(sv); int ival; /* * Perl does math with doubles by default, so 0 + 1 == 1.0. * Check for int-equiv doubles and make those ints. * XXX This check possibly only necessary for <=5.6.x */ if (((double)(ival = SvIV(sv)) == dval)) { objPtr = Tcl_NewIntObj(ival); } else { objPtr = Tcl_NewDoubleObj(dval); } } else if (SvIOK(sv)) { objPtr = Tcl_NewIntObj(SvIV(sv)); } else { /* * Catch-all * XXX: Should we recurse other REFs, or better to stringify them? */ STRLEN length; char *str = SvPV(sv, length); /* * Tcl's "String" object expects utf-8 strings. If we aren't sure * that we have a utf-8 data, pass it as a Tcl ByteArray (C char*). */ if (SvUTF8(sv)) { /* * Should we consider overlong NULL encoding for Tcl here? */ objPtr = Tcl_NewStringObj(str, length); } else { objPtr = Tcl_NewByteArrayObj((unsigned char *) str, length); } } return objPtr; } int Tcl_EvalInPerl(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { dTHX; /* fetch context */ dSP; I32 count; SV *sv; int rc; /* * This is the command created in Tcl to eval stuff in Perl */ if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); } ENTER; SAVETMPS; PUSHMARK(sp); PUTBACK; count = perl_eval_sv(sv_2mortal(SvFromTclObj(aTHX_ objv[1])), G_EVAL|G_SCALAR); SPAGAIN; if (SvTRUE(ERRSV)) { Tcl_SetResult(interp, SvPV_nolen(ERRSV), TCL_VOLATILE); POPs; /* pop the undef off the stack */ rc = TCL_ERROR; } else { if (count != 1) { croak("Perl sub bound to Tcl proc returned %d args, expected 1", count); } sv = POPs; /* pop the undef off the stack */ if (SvOK(sv)) { Tcl_Obj *objPtr = TclObjFromSv(aTHX_ sv); /* Tcl_SetObjResult will incr refcount */ Tcl_SetObjResult(interp, objPtr); } rc = TCL_OK; } PUTBACK; /* * If the routine returned undef, it indicates that it has done the * SetResult itself and that we should return TCL_ERROR */ FREETMPS; LEAVE; return rc; } int Tcl_PerlCallWrapper(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { dTHX; /* fetch context */ dSP; AV *av = (AV *) clientData; I32 count; SV *sv; int flag; int rc; /* * av = [$perlsub, $realclientdata, $interp, $deleteProc] * (where $deleteProc is optional but we don't need it here anyway) */ if (AvFILL(av) != 3 && AvFILL(av) != 4) croak("bad clientdata argument passed to Tcl_PerlCallWrapper"); flag = SvIV(*av_fetch(av, 3, FALSE)); ENTER; SAVETMPS; PUSHMARK(sp); if (flag & 1) { if (objc) { objc--; objv++; EXTEND(sp, objc); } } else { EXTEND(sp, objc + 2); /* * Place clientData and original interp on the stack, then the * Tcl object invoke list, including the command name. Users * who only want the args from Tcl can splice off the first 3 args */ PUSHs(sv_mortalcopy(*av_fetch(av, 1, FALSE))); PUSHs(sv_mortalcopy(*av_fetch(av, 2, FALSE))); } while (objc--) { PUSHs(sv_2mortal(SvFromTclObj(aTHX_ *objv++))); } PUTBACK; count = perl_call_sv(*av_fetch(av, 0, FALSE), G_EVAL|G_SCALAR); SPAGAIN; if (SvTRUE(ERRSV)) { Tcl_SetResult(interp, SvPV_nolen(ERRSV), TCL_VOLATILE); POPs; /* pop the undef off the stack */ rc = TCL_ERROR; } else { if (count != 1) { croak("Perl sub bound to Tcl proc returned %d args, expected 1", count); } sv = POPs; /* pop the undef off the stack */ if (SvOK(sv)) { Tcl_Obj *objPtr = TclObjFromSv(aTHX_ sv); /* Tcl_SetObjResult will incr refcount */ Tcl_SetObjResult(interp, objPtr); } rc = TCL_OK; } PUTBACK; /* * If the routine returned undef, it indicates that it has done the * SetResult itself and that we should return TCL_ERROR */ FREETMPS; LEAVE; return rc; } void Tcl_PerlCallDeleteProc(ClientData clientData) { dTHX; /* fetch context */ AV *av = (AV *) clientData; /* * av = [$perlsub, $realclientdata, $interp, $deleteProc] * (where $deleteProc is optional but we don't need it here anyway) */ if (AvFILL(av) == 4) { dSP; PUSHMARK(sp); EXTEND(sp, 1); PUSHs(sv_mortalcopy(*av_fetch(av, 1, FALSE))); PUTBACK; (void) perl_call_sv(*av_fetch(av, 4, FALSE), G_SCALAR|G_DISCARD); } else if (AvFILL(av) != 3) { croak("bad clientdata argument passed to Tcl_PerlCallDeleteProc"); } SvREFCNT_dec(av); } void prepare_Tcl_result(pTHX_ Tcl interp, char *caller) { dSP; Tcl_Obj *objPtr, **objv; int gimme, objc, i; objPtr = Tcl_GetObjResult(interp); gimme = GIMME_V; if (gimme == G_SCALAR) { /* * This checks Tcl_Obj type. XPUSH not needed because we * are called when there is enough space on the stack. */ PUSHs(sv_2mortal(SvFromTclObj(aTHX_ objPtr))); } else if (gimme == G_ARRAY) { if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { croak("%s called in list context did not return a valid Tcl list", caller); } if (objc) { EXTEND(sp, objc); for (i = 0; i < objc; i++) { /* * This checks Tcl_Obj type */ PUSHs(sv_2mortal(SvFromTclObj(aTHX_ objv[i]))); } } } else { /* G_VOID context - ignore result */ } PUTBACK; return; } char * var_trace(ClientData clientData, Tcl_Interp *interp, char *name1, char *name2, int flags) { dTHX; /* fetch context */ if (flags & TCL_TRACE_READS) { warn("TCL_TRACE_READS\n"); } else if (flags & TCL_TRACE_WRITES) { warn("TCL_TRACE_WRITES\n"); } else if (flags & TCL_TRACE_ARRAY) { warn("TCL_TRACE_ARRAY\n"); } else if (flags & TCL_TRACE_UNSETS) { warn("TCL_TRACE_UNSETS\n"); } return 0; } MODULE = Tcl PACKAGE = Tcl PREFIX = Tcl_ SV * Tcl__new(class = "Tcl") char * class CODE: RETVAL = newSV(0); /* * We might consider Tcl_Preserve/Tcl_Release of the interp. */ if (initialized) { Tcl interp = Tcl_CreateInterp(); Tcl_CreateObjCommand(interp, "::perl::Eval", Tcl_EvalInPerl, (ClientData) NULL, NULL); /* * Add to the global hash of live interps. */ if (hvInterps) { (void) hv_store(hvInterps, (const char *) &interp, sizeof(Tcl), &PL_sv_undef, 0); } sv_setref_pv(RETVAL, class, (void*)interp); } OUTPUT: RETVAL SV * Tcl_CreateSlave(master,name,safe) Tcl master char * name int safe CODE: RETVAL = newSV(0); /* * We might consider Tcl_Preserve/Tcl_Release of the interp. */ if (initialized) { Tcl interp = Tcl_CreateSlave(master,name,safe); /* * Add to the global hash of live interps. */ if (hvInterps) { (void) hv_store(hvInterps, (const char *) &interp, sizeof(Tcl), &PL_sv_undef, 0); } /* Create lets us set a class, should we do this too? */ sv_setref_pv(RETVAL, "Tcl", (void*)interp); } OUTPUT: RETVAL SV * Tcl_result(interp) Tcl interp CODE: if (initialized) { RETVAL = SvFromTclObj(aTHX_ Tcl_GetObjResult(interp)); } else { RETVAL = &PL_sv_undef; } OUTPUT: RETVAL void Tcl_Eval(interp, script, flags = 0) Tcl interp SV * script int flags SV * interpsv = ST(0); STRLEN length = NO_INIT char *cscript = NO_INIT PPCODE: if (!initialized) { return; } (void) sv_2mortal(SvREFCNT_inc(interpsv)); PUTBACK; Tcl_ResetResult(interp); /* sv_mortalcopy here prevents stringifying script - necessary ?? */ cscript = SvPV(sv_mortalcopy(script), length); if (Tcl_EvalEx(interp, cscript, length, flags) != TCL_OK) { croak(Tcl_GetStringResult(interp)); } prepare_Tcl_result(aTHX_ interp, "Tcl::Eval"); SPAGAIN; #ifdef HAVE_TKINIT char* Tcl_SetPreInitScript(script) char * script CODE: if (!initialized) { return; } RETVAL = TclSetPreInitScript(script); OUTPUT: RETVAL void TclpInitLibraryPath(path) char * path PPCODE: int lengthPtr=0; Tcl_Encoding encodingPtr; if (!initialized) { return; } /* interface to TclpInitLibraryPath changed between 8.4.x and 8.5.x */ TclpInitLibraryPath(&path, &lengthPtr, &encodingPtr); void Tcl_SetDefaultEncodingDir(script) char * script PPCODE: if (!initialized) { return; } Tcl_SetDefaultEncodingDir(script); char* Tcl_GetDefaultEncodingDir(void) CODE: if (!initialized) { return; } RETVAL = Tcl_GetDefaultEncodingDir(); OUTPUT: RETVAL void* Tcl_GetEncoding(interp, enc) Tcl interp char *enc PPCODE: if (!initialized) { return; } Tcl_GetEncoding(interp,enc); #endif /* HAVE_TKINIT */ void Tcl_EvalFile(interp, filename) Tcl interp char * filename SV * interpsv = ST(0); PPCODE: if (!initialized) { return; } (void) sv_2mortal(SvREFCNT_inc(interpsv)); PUTBACK; Tcl_ResetResult(interp); if (Tcl_EvalFile(interp, filename) != TCL_OK) { croak(Tcl_GetStringResult(interp)); } prepare_Tcl_result(aTHX_ interp, "Tcl::EvalFile"); SPAGAIN; void Tcl_EvalFileHandle(interp, handle) Tcl interp PerlIO* handle int append = 0; SV * interpsv = ST(0); SV * sv = sv_newmortal(); char * s = NO_INIT PPCODE: if (!initialized) { return; } (void) sv_2mortal(SvREFCNT_inc(interpsv)); PUTBACK; while ((s = sv_gets(sv, handle, append))) { if (!Tcl_CommandComplete(s)) append = 1; else { Tcl_ResetResult(interp); if (Tcl_Eval(interp, s) != TCL_OK) croak(Tcl_GetStringResult(interp)); append = 0; } } if (append) croak("unexpected end of file in Tcl::EvalFileHandle"); prepare_Tcl_result(aTHX_ interp, "Tcl::EvalFileHandle"); SPAGAIN; void Tcl_invoke(interp, sv, ...) Tcl interp SV * sv PPCODE: { /* * 'Tcl::invoke' invokes the command directly, avoiding * command tracing and the ::unknown mechanism. */ #define NUM_OBJS 16 Tcl_Obj *baseobjv[NUM_OBJS]; Tcl_Obj **objv = baseobjv; char *cmdName; int objc, i, result; STRLEN length; Tcl_CmdInfo cmdinfo; if (!initialized) { return; } objv = baseobjv; objc = items-1; if (objc > NUM_OBJS) { New(666, objv, objc, Tcl_Obj *); } SP += items; PUTBACK; /* Verify first arg is a Tcl command */ cmdName = SvPV(sv, length); if (!Tcl_GetCommandInfo(interp, cmdName, &cmdinfo)) { croak("Tcl procedure '%s' not found", cmdName); } if (cmdinfo.objProc && cmdinfo.isNativeObjectProc) { /* * We might want to check that this isn't * TclInvokeStringCommand, which just means we waste time * making Tcl_Obj's. * * Emulate TclInvokeObjectCommand (from Tcl), namely create the * object argument array "objv" before calling right procedure */ objv[0] = Tcl_NewStringObj(cmdName, length); Tcl_IncrRefCount(objv[0]); for (i = 1; i < objc; i++) { /* * Use efficient Sv to Tcl_Obj conversion. * This returns Tcl_Obj with refcount 1. * This can cause recursive calls if we have tied vars. */ objv[i] = TclObjFromSv(aTHX_ sv_mortalcopy(ST(i+1))); Tcl_IncrRefCount(objv[i]); } SP -= items; PUTBACK; /* * Result interp result and invoke the command's object-based * Tcl_ObjCmdProc. */ #if DEBUG_REFCOUNTS for (i = 1; i < objc; i++) { check_refcounts(objv[i]); } #endif Tcl_ResetResult(interp); result = (*cmdinfo.objProc)(cmdinfo.objClientData, interp, objc, objv); /* * Decrement ref count for first arg, others decr'd below */ Tcl_DecrRefCount(objv[0]); } else { /* * we have cmdinfo.objProc==0 * prepare string arguments into argv (1st is already done) * and call found procedure */ char *baseargv[NUM_OBJS]; char **argv = baseargv; if (objc > NUM_OBJS) { New(666, argv, objc, char *); } argv[0] = cmdName; for (i = 1; i < objc; i++) { /* * We need the inefficient round-trip through Tcl_Obj to * ensure that we are listify-ing correctly. * This can cause recursive calls if we have tied vars. */ objv[i] = TclObjFromSv(aTHX_ sv_mortalcopy(ST(i+1))); Tcl_IncrRefCount(objv[i]); argv[i] = Tcl_GetString(objv[i]); } SP -= items; PUTBACK; /* * Result interp result and invoke the command's string-based * procedure. */ #if DEBUG_REFCOUNTS for (i = 1; i < objc; i++) { check_refcounts(objv[i]); } #endif Tcl_ResetResult(interp); result = (*cmdinfo.proc)(cmdinfo.clientData, interp, objc, argv); if (argv != baseargv) { Safefree(argv); } } /* * Decrement the ref counts for the argument objects created above */ for (i = 1; i < objc; i++) { Tcl_DecrRefCount(objv[i]); } if (result != TCL_OK) { croak(Tcl_GetStringResult(interp)); } prepare_Tcl_result(aTHX_ interp, "Tcl::invoke"); if (objv != baseobjv) { Safefree(objv); } SPAGAIN; #undef NUM_OBJS } void Tcl_icall(interp, sv, ...) Tcl interp SV * sv PPCODE: { /* * 'Tcl::icall' passes the args to Tcl to invoke. It will do * command tracing and call ::unknown mechanism for unrecognized * commands. */ #define NUM_OBJS 16 Tcl_Obj *baseobjv[NUM_OBJS]; Tcl_Obj **objv = baseobjv; int objc, i, result; if (!initialized) { return; } objc = items-1; if (objc > NUM_OBJS) { New(666, objv, objc, Tcl_Obj *); } SP += items; PUTBACK; for (i = 0; i < objc; i++) { /* * Use efficient Sv to Tcl_Obj conversion. * This returns Tcl_Obj with refcount 1. * This can cause recursive calls if we have tied vars. */ objv[i] = TclObjFromSv(aTHX_ sv_mortalcopy(ST(i+1))); Tcl_IncrRefCount(objv[i]); } SP -= items; PUTBACK; /* * Reset current result and invoke using Tcl_EvalObjv. * This will trigger command traces and handle async signals. */ #if DEBUG_REFCOUNTS for (i = 1; i < objc; i++) { check_refcounts(objv[i]); } #endif Tcl_ResetResult(interp); result = Tcl_EvalObjv(interp, objc, objv, 0); /* * Decrement the ref counts for the argument objects created above */ for (i = 0; i < objc; i++) { Tcl_DecrRefCount(objv[i]); } if (result != TCL_OK) { croak(Tcl_GetStringResult(interp)); } prepare_Tcl_result(aTHX_ interp, "Tcl::icall"); if (objv != baseobjv) { Safefree(objv); } SPAGAIN; #undef NUM_OBJS } void Tcl_DESTROY(interp) Tcl interp CODE: if (initialized) { Tcl_DeleteInterp(interp); /* * Remove from the global hash of live interps. */ if (hvInterps) { (void) hv_delete(hvInterps, (const char *) interp, sizeof(Tcl), G_DISCARD); } } void Tcl__Finalize(interp=NULL) Tcl interp CODE: /* * This should be called from the END block - when we no * longer plan to use Tcl *AT ALL*. */ if (!initialized) { return; } if (hvInterps) { /* * Delete all the global hash of live interps. */ HE *he; hv_iterinit(hvInterps); he = hv_iternext(hvInterps); while (he) { I32 len; interp = *((Tcl *) hv_iterkey(he, &len)); Tcl_DeleteInterp(interp); he = hv_iternext(hvInterps); } hv_undef(hvInterps); hvInterps = NULL; } #ifdef USE_TCL_STUBS if (g_Interp) { Tcl_DeleteInterp(g_Interp); g_Interp = NULL; } #endif initialized = 0; Tcl_Finalize(); #ifdef USE_TCL_STUBS if (tclHandle) { dlclose(tclHandle); tclHandle = NULL; } #endif void Tcl_Init(interp) Tcl interp CODE: if (!initialized) { return; } if (tclKit_AppInit(interp) != TCL_OK) { croak(Tcl_GetStringResult(interp)); } #ifdef HAVE_DDEINIT void Dde_Init(interp) Tcl interp CODE: Dde_Init(interp); #endif #ifdef HAVE_TKINIT void Tk_Init(interp) Tcl interp CODE: Tk_Init(interp); #endif #ifdef HAVE_TIXINIT void Tix_Init(interp) Tcl interp CODE: Tix_Init(interp); #endif #ifdef HAVE_BLTINIT void Blt_Init(interp) Tcl interp CODE: Blt_Init(interp); void Blt_StaticPackage(interp) Tcl interp PPCODE: Tcl_StaticPackage(interp, "BLT", Blt_Init, Blt_SafeInit); #endif #ifdef HAVE_MEMCHANINIT void Memchan_Init(interp) Tcl interp CODE: Memchan_Init(interp); #endif #ifdef HAVE_TRFINIT void Trf_Init(interp) Tcl interp CODE: Trf_Init(interp); #endif #ifdef HAVE_VFSINIT void Vfs_Init(interp) Tcl interp CODE: Vfs_Init(interp); #endif int Tcl_DoOneEvent(interp, flags) Tcl interp int flags CODE: RETVAL = initialized ? Tcl_DoOneEvent(flags) : 0; OUTPUT: RETVAL void Tcl_CreateCommand(interp,cmdName,cmdProc,clientData=&PL_sv_undef,deleteProc=&PL_sv_undef,flags=0) Tcl interp char * cmdName SV * cmdProc SV * clientData SV * deleteProc int flags CODE: if (!initialized) { return; } if (SvIOK(cmdProc)) Tcl_CreateCommand(interp, cmdName, (Tcl_CmdProc *) SvIV(cmdProc), INT2PTR(ClientData, SvIV(clientData)), NULL); else { AV *av = (AV *) SvREFCNT_inc((SV *) newAV()); av_store(av, 0, newSVsv(cmdProc)); av_store(av, 1, newSVsv(clientData)); av_store(av, 2, newSVsv(ST(0))); av_store(av, 3, newSViv(flags)); if (SvOK(deleteProc)) { av_store(av, 4, newSVsv(deleteProc)); } Tcl_CreateObjCommand(interp, cmdName, Tcl_PerlCallWrapper, (ClientData) av, Tcl_PerlCallDeleteProc); } ST(0) = &PL_sv_yes; XSRETURN(1); void Tcl_SetResult(interp, sv) Tcl interp SV * sv CODE: if (!initialized) { return; } { Tcl_Obj *objPtr = TclObjFromSv(aTHX_ sv); /* Tcl_SetObjResult will incr refcount */ Tcl_SetObjResult(interp, objPtr); ST(0) = ST(1); XSRETURN(1); } void Tcl_AppendElement(interp, str) Tcl interp char * str void Tcl_ResetResult(interp) Tcl interp SV * Tcl_AppendResult(interp, ...) Tcl interp int i = NO_INIT CODE: if (initialized) { Tcl_Obj *objPtr = Tcl_GetObjResult(interp); for (i = 1; i < items; i++) { Tcl_AppendObjToObj(objPtr, TclObjFromSv(aTHX_ ST(i))); } RETVAL = SvFromTclObj(aTHX_ objPtr); } else { RETVAL = &PL_sv_undef; } OUTPUT: RETVAL SV * Tcl_DeleteCommand(interp, cmdName) Tcl interp char * cmdName CODE: RETVAL = boolSV(initialized ? Tcl_DeleteCommand(interp, cmdName) == TCL_OK:TRUE); OUTPUT: RETVAL void Tcl_SplitList(interp, str) Tcl interp char * str int argc = NO_INIT char ** argv = NO_INIT char ** tofree = NO_INIT PPCODE: if (Tcl_SplitList(interp, str, &argc, &argv) == TCL_OK) { tofree = argv; EXTEND(sp, argc); while (argc--) PUSHs(sv_2mortal(newSVpv(*argv++, 0))); ckfree((char *) tofree); } SV * Tcl_SetVar(interp, varname, value, flags = 0) Tcl interp char * varname SV * value int flags CODE: RETVAL = SvFromTclObj(aTHX_ Tcl_SetVar2Ex(interp, varname, NULL, TclObjFromSv(aTHX_ value), flags)); OUTPUT: RETVAL SV * Tcl_SetVar2(interp, varname1, varname2, value, flags = 0) Tcl interp char * varname1 char * varname2 SV * value int flags CODE: RETVAL = SvFromTclObj(aTHX_ Tcl_SetVar2Ex(interp, varname1, varname2, TclObjFromSv(aTHX_ value), flags)); OUTPUT: RETVAL SV * Tcl_GetVar(interp, varname, flags = 0) Tcl interp char * varname int flags CODE: RETVAL = SvFromTclObj(aTHX_ Tcl_GetVar2Ex(interp, varname, NULL, flags)); OUTPUT: RETVAL SV * Tcl_GetVar2(interp, varname1, varname2, flags = 0) Tcl interp char * varname1 char * varname2 int flags CODE: RETVAL = SvFromTclObj(aTHX_ Tcl_GetVar2Ex(interp, varname1, varname2, flags)); OUTPUT: RETVAL SV * Tcl_UnsetVar(interp, varname, flags = 0) Tcl interp char * varname int flags CODE: RETVAL = boolSV(Tcl_UnsetVar2(interp, varname, NULL, flags) == TCL_OK); OUTPUT: RETVAL SV * Tcl_UnsetVar2(interp, varname1, varname2, flags = 0) Tcl interp char * varname1 char * varname2 int flags CODE: RETVAL = boolSV(Tcl_UnsetVar2(interp, varname1, varname2, flags) == TCL_OK); OUTPUT: RETVAL MODULE = Tcl PACKAGE = Tcl::List SV* as_string(SV* sv,...) PREINIT: Tcl_Obj* objPtr; int len; char *str; CODE: objPtr = TclObjFromSv(aTHX_ sv); Tcl_IncrRefCount(objPtr); str = Tcl_GetStringFromObj(objPtr, &len); RETVAL = newSVpvn(str, len); /* should turn on, but let's check this first for efficiency */ if (len && has_highbit(str, len)) { SvUTF8_on(RETVAL); } Tcl_DecrRefCount(objPtr); OUTPUT: RETVAL MODULE = Tcl PACKAGE = Tcl::Var SV * FETCH(av, key = NULL) Tcl::Var av char * key SV * sv = NO_INIT Tcl interp = NO_INIT char * varname1 = NO_INIT int flags = 0; CODE: /* * This handles both hash and scalar fetches. The blessed object * passed in is [$interp, $varname, $flags] ($flags optional). */ if (!initialized) { return; } if (AvFILL(av) != 1 && AvFILL(av) != 2) { croak("bad object passed to Tcl::Var::FETCH"); } sv = *av_fetch(av, 0, FALSE); if (sv_derived_from(sv, "Tcl")) { IV tmp = SvIV((SV *) SvRV(sv)); interp = INT2PTR(Tcl, tmp); } else { croak("bad object passed to Tcl::Var::FETCH"); } if (AvFILL(av) == 2) { flags = (int) SvIV(*av_fetch(av, 2, FALSE)); } varname1 = SvPV_nolen(*av_fetch(av, 1, FALSE)); RETVAL = SvFromTclObj(aTHX_ Tcl_GetVar2Ex(interp, varname1, key, flags)); OUTPUT: RETVAL void STORE(av, sv1, sv2 = NULL) Tcl::Var av SV * sv1 SV * sv2 SV * sv = NO_INIT Tcl interp = NO_INIT char * varname1 = NO_INIT Tcl_Obj * objPtr = NO_INIT int flags = 0; CODE: /* * This handles both hash and scalar stores. The blessed object * passed in is [$interp, $varname, $flags] ($flags optional). */ if (!initialized) { return; } if (AvFILL(av) != 1 && AvFILL(av) != 2) croak("bad object passed to Tcl::Var::STORE"); sv = *av_fetch(av, 0, FALSE); if (sv_derived_from(sv, "Tcl")) { IV tmp = SvIV((SV *) SvRV(sv)); interp = INT2PTR(Tcl, tmp); } else croak("bad object passed to Tcl::Var::STORE"); if (AvFILL(av) == 2) { flags = (int) SvIV(*av_fetch(av, 2, FALSE)); } varname1 = SvPV_nolen(*av_fetch(av, 1, FALSE)); /* * HASH: sv1 == key, sv2 == value * SCALAR: sv1 == value, sv2 NULL * Tcl_SetVar2Ex will incr refcount */ if (sv2) { objPtr = TclObjFromSv(aTHX_ sv2); Tcl_SetVar2Ex(interp, varname1, SvPV_nolen(sv1), objPtr, flags); } else { objPtr = TclObjFromSv(aTHX_ sv1); Tcl_SetVar2Ex(interp, varname1, NULL, objPtr, flags); } MODULE = Tcl PACKAGE = Tcl BOOT: { SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */ #ifdef USE_TCL_STUBS if (NpInitialize(aTHX_ x) == TCL_ERROR) { croak("Unable to initialize Tcl"); } #else /* Ideally this would be passed the dll instance location. */ Tcl_FindExecutable(x && SvPOK(x) ? SvPV_nolen(x) : NULL); #if defined(HAVE_TKINIT) && defined(WIN32) /* HAVE_TKINIT means we're linking Tk statically with tcl.dll * so we need to perform same initialization as in * tk/win/tkWin32Dll.c * (unless all this goes statically into perl.dll; in this case * handle to perl.dll should be substituted TODO) * -- VKON */ TkWinSetHINSTANCE(_hinst); #endif #endif initialized = 1; hvInterps = newHV(); } tclBooleanTypePtr = Tcl_GetObjType("boolean"); tclByteArrayTypePtr = Tcl_GetObjType("bytearray"); tclDoubleTypePtr = Tcl_GetObjType("double"); tclIntTypePtr = Tcl_GetObjType("int"); tclListTypePtr = Tcl_GetObjType("list"); tclStringTypePtr = Tcl_GetObjType("string"); tclWideIntTypePtr = Tcl_GetObjType("wideInt"); /* set up constant subs */ { HV *stash = gv_stashpvn("Tcl", 3, TRUE); newCONSTSUB(stash, "OK", newSViv(TCL_OK)); newCONSTSUB(stash, "ERROR", newSViv(TCL_ERROR)); newCONSTSUB(stash, "RETURN", newSViv(TCL_RETURN)); newCONSTSUB(stash, "BREAK", newSViv(TCL_BREAK)); newCONSTSUB(stash, "CONTINUE", newSViv(TCL_CONTINUE)); newCONSTSUB(stash, "GLOBAL_ONLY", newSViv(TCL_GLOBAL_ONLY)); newCONSTSUB(stash, "NAMESPACE_ONLY", newSViv(TCL_NAMESPACE_ONLY)); newCONSTSUB(stash, "APPEND_VALUE", newSViv(TCL_APPEND_VALUE)); newCONSTSUB(stash, "LIST_ELEMENT", newSViv(TCL_LIST_ELEMENT)); newCONSTSUB(stash, "TRACE_READS", newSViv(TCL_TRACE_READS)); newCONSTSUB(stash, "TRACE_WRITES", newSViv(TCL_TRACE_WRITES)); newCONSTSUB(stash, "TRACE_UNSETS", newSViv(TCL_TRACE_UNSETS)); newCONSTSUB(stash, "TRACE_DESTROYED", newSViv(TCL_TRACE_DESTROYED)); newCONSTSUB(stash, "INTERP_DESTROYED", newSViv(TCL_INTERP_DESTROYED)); newCONSTSUB(stash, "LEAVE_ERR_MSG", newSViv(TCL_LEAVE_ERR_MSG)); newCONSTSUB(stash, "TRACE_ARRAY", newSViv(TCL_TRACE_ARRAY)); newCONSTSUB(stash, "LINK_INT", newSViv(TCL_LINK_INT)); newCONSTSUB(stash, "LINK_DOUBLE", newSViv(TCL_LINK_DOUBLE)); newCONSTSUB(stash, "LINK_BOOLEAN", newSViv(TCL_LINK_BOOLEAN)); newCONSTSUB(stash, "LINK_STRING", newSViv(TCL_LINK_STRING)); newCONSTSUB(stash, "LINK_READ_ONLY", newSViv(TCL_LINK_READ_ONLY)); newCONSTSUB(stash, "WINDOW_EVENTS", newSViv(TCL_WINDOW_EVENTS)); newCONSTSUB(stash, "FILE_EVENTS", newSViv(TCL_FILE_EVENTS)); newCONSTSUB(stash, "TIMER_EVENTS", newSViv(TCL_TIMER_EVENTS)); newCONSTSUB(stash, "IDLE_EVENTS", newSViv(TCL_IDLE_EVENTS)); newCONSTSUB(stash, "ALL_EVENTS", newSViv(TCL_ALL_EVENTS)); newCONSTSUB(stash, "DONT_WAIT", newSViv(TCL_DONT_WAIT)); newCONSTSUB(stash, "EVAL_GLOBAL", newSViv(TCL_EVAL_GLOBAL)); newCONSTSUB(stash, "EVAL_DIRECT", newSViv(TCL_EVAL_DIRECT)); } Tcl-1.05/tclcfg.tcl0000644552332700244210000000066712734525121014555 0ustar konovvDomain Usersputs "tclsh=[info nameofexecutable]" set libdir [info library] set dirs [list \ [file dirname $libdir] \ [file dirname [file dirname $libdir]] \ [file join [file dirname [file dirname [info nameofexe]]] lib] \ ] foreach dir $dirs { if {[file exists [file join $dir tclConfig.sh]]} { puts "tclConfig.sh=[file join $dir tclConfig.sh]" break } } puts "tcl_library=$libdir" puts "tcl_version=$tcl_version" Tcl-1.05/typemap0000644552332700244210000000006012734525121014174 0ustar konovvDomain UsersTcl T_PTROBJ Tcl::Var T_AVREF PerlIO * T_INOUT