diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/pTk/Tcl-pTk')
| -rwxr-xr-x | Master/tlpkg/tlperl/lib/Tk/pTk/Tcl-pTk | 260 |
1 files changed, 260 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/pTk/Tcl-pTk b/Master/tlpkg/tlperl/lib/Tk/pTk/Tcl-pTk new file mode 100755 index 00000000000..cc72e16b6c5 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/Tk/pTk/Tcl-pTk @@ -0,0 +1,260 @@ +#!/usr/local/bin/perl -w +use open IO => ':bytes'; # Avoid UTF-8 issues with some perl5.8.0 (RedHat) +use Carp; +my $verbose = 0; + +$SIG{'__WARN__'} = sub { print STDERR $_; Carp::confess(shift) }; + +$src = shift; +$dst = shift; + +die "Usage: $0 <src> <dst> \n" unless (defined $src and defined $dst); + +chmod(0666, $dst); +chmod(0666, "$dst~"); +unlink($dst); +open(DST,">$dst~") || die "Cannot open $dst~: $!"; +select(DST); + +my $copyright; + +@ARGV = ($src); + +undef $undone; + +sub getline +{ + local $_; + if (defined $undone) + { + $_ = $undone; + undef $undone; + } + else + { + $_ = <>; + } + return $_; +} + +sub int_results +{my $fmt = shift; + my $type = shift; + my @fmt = split(/\s+/,$fmt); + my $cnt = @fmt; + # print STDERR "'$fmt' => $cnt\n"; + return "Tcl_${type}Results(interp,$cnt,0"; +} + +sub result +{my ($interp,$value,$tail) = @_; + my $line = &getline; + my $kind = "TCL_STATIC"; + if (defined $line) + { + if ($line =~ /^\s*$interp\s*->\s*freeProc\s*=\s*(.*)\s*;\s*$/) + { + $kind = $1; + } + else + { + $undone = $line if (defined $line); + } + } + return "Tcl_SetResult($interp,$value,$kind)$tail"; +} + +sub complete +{ + my $tail = ""; + until (/;/) + { + my $line = &getline; + last unless defined($line); + s/\s*$//; + $line =~ s/^\s*//; + $_ .= " " . $line; + $tail .= "\n"; + } + $_ .= $tail; +} + +#use Carp; +#$SIG{'INT'} = sub { Carp::confess($_) }; + + +PROCESS: +while ($_ = &getline) + { + s/^\s*#\s*include\s*[<"]tcl\.h[">]\s*$/#include "Lang.h"\n/; + + s/^\s*#\s*include\s*<((tk|tkInt|tkPort|tix|tixInt)\.h)>\s*$/#include "$1"\n/; + + next if (/^\s*extern.*\bpanic\s*\(/); + + s/\(char\s*\*\)\s*NULL\b/ NULL/g; + + if (/^#(define|ifn?def|endif)\b/) + { + print; + while (/\\$/) + { + $_ = &getline; + print; + } + next; + } + + if (m#^ */\*# && !m#\*/#) + { + print; + while (!m#\*/#) + { + $_ = &getline; + print; + } + next; + } + + s/tclStubs\.t(\w+)/TkeventVptr->V_T$1/; + + s/\bpanic\b/Tcl_Panic/g; + + s/\b(\w+Ptr)->internalRep\./TclObjInternal($1)->/g; + + s/(\w+bjPtr)->typePtr\s*=\s*(.*);/TclObjSetType($1,$2);/g; + + s/\b(\w*bjPtr)->typePtr\b/TclObjGetType($1)/g; + + if (/if\s*\(\(c == '.'\)\s*$/) + { + my $line = &getline; + if (defined($line)) + { + s/\s*$//; + $line =~ s/^\s*//; + $_ .= " " . $line . "\n"; + } + } + + if (/Tcl_DeleteCommandFromToken/) + { + if (/Tcl_DeleteCommandFromToken[^;{]*$/) + { + &complete; + redo PROCESS; + } + s/Tcl_DeleteCommandFromToken(.*imageCmd)/Lang_DeleteObject$1/; + s/Tcl_DeleteCommandFromToken(.*widgetCmd)/Lang_DeleteWidget$1/; + } + + if (/Tcl_(Create|Delete)Command/) + { + if (/Tcl_(Create|Delete)Command[^;{]*$/) + { + &complete; + redo PROCESS; + } + s/Tcl_CreateCommand\s*\(\s*((\w+->)*interp)\s*,\s*Tk_PathName\s*\(([^\)]+)\)/Lang_CreateWidget($1,$3/; + s/Tcl_DeleteCommand\s*\(\s*((\w+->)*(\w+\.)?interp)\s*,\s*Tcl_GetCommandName\s*\([^,]+,\s*([^\)]+->(\w+\.style|image)Cmd)\)/Lang_DeleteObject($1,$4/; + s/Tcl_DeleteCommand\s*\(\s*((\w+->)*(\w+\.)?interp)\s*,\s*Tcl_GetCommandName\s*\([^,]+,\s*([^\)]+->widgetCmd)\)/Lang_DeleteWidget($1,$4/; + } + + s/\(char \*\*\)\s*objv\b/objv/g; + +# s/Tcl_Obj\s+\*(CONST\s+)?objv\b/Tcl_Obj *objv/; + if (/\bargv\w*\b/) + { + if (/\bargv\w*\s*\[([^[]*)\]\s*=[^=][^;{]*$/) + { + &complete; + redo PROCESS; + } + s/Tcl_Obj\s+\*(CONST\s+)?argv\b/Tcl_Obj *objv/; + if (/\bchar\b.*\bargv\w*\b/) + { + # convert char *argv[] to char **argv + s/char\s*\*\s*\bargv\s*\[\s*\]/char **argv/; + # convert char **argv to Tcl_Obj **objv + s/(CONST\s+)?char\s*\*\*\s*\bargv\b/Tcl_Obj *CONST *objv/; + # convert char *argv[n] to Tcl_Obj **objv = LangAllocVec(n) + s/char\s*\*\s*\bargv\s*\[\s*([^[]+)\]/Tcl_Obj **objv = LangAllocVec($1)/; + } + else + { + s/([^*])\*(argv\w*(\[[^[]*\])?)/${1}${2}[0]/g; + } + s/\(Tcl_Obj\s\*\)\s*argv\b/objv/g; + s/\bargv\s*\[([^[]*)\]\s*=([^=].*);\s*$/LangSetString(objv+$1,$2);\n/; + s/\bargv\s*\[([^[]*)\]\+\+/objv[$1] = Tcl_NewStringObj(Tcl_GetString(objv[$1])+1,-1)/; + s/\bargv\s*\[([^[]*)\]\+([0-9])/Tcl_NewStringObj(Tcl_GetString(objv[$1])+$2,-1)/; + if (/Tcl_Get(Boolean|Int|Double)/ || /Tk_Get(Cursor)/) + { + s/\bargv(\w*)\b/objv$1/g; + } + s/\bargv\s*(\[[^[]*\])/Tcl_GetString(objv$1)/g; + if (/\bargv\b/) + { + warn "Leak: $_" if ($verbose && !/\bargv\s*\)/); + s/\bargv\b/objv/; + } + } + if (/->\s*result\b/) + { + s/\s*->\s*result\b/->result/g; + + s/\bsprintf\s*\(\s*interp->result\s*,\s*"((\s*%d)+)"/&int_results($1,"Int")/e; + + s/\bsprintf\s*\(\s*interp->result\s*,\s*"((\s*%g)+)"/&int_results($1,"Double")/e; + + s/\bsprintf\s*\(\s*interp->result\b/Tcl_SprintfResult(interp/; + if (/\binterp->result\s*=[^;]*$/) + { + &complete; + redo PROCESS; + } + s/\b((\w+\s*->\s*)*interp)->result\s*=([^;]*);/&result($1,$3,";")/e; + s/\b((\w+\s*->\s*)*interp)->result\s*=(.*);\s*$/&result($1,$3,";\n")/e; + s/\b((\w+\s*->\s*)*interp)->result/Tcl_GetResult($1)/; + } + + if (/\bTcl_SetResult\s*\(/) + { + if (/Tcl_SetResult\s*\([^;{]*$/) + { + &complete; + redo PROCESS; + } + s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*"(\d+)",\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1, Tcl_NewIntObj($3))/; + s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*Tk_PathName\(([^)]+)\),\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1,LangWidgetObj($1,$3))/; + s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*((\w+->)*\w+)->pathName\s*,\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1,LangWidgetObj($1,(Tk_Window)($3)))/; + die $_ if /(Tk_PathName|->pathName)/; + } +# 1 2 3 4 5 6 + s/\(c == '(.)'\)\s*&&\s*(\(?)\(strncmp\(([^,]+),\s*("-\1[^"]*"),\s*(\w+|strlen\(\3\))\s*\)\s*==\s*0\)(\)?)/(c == '$1') && $2 LangCmpOpt($4,$3,$5) == 0 $6/g; + s/\(c == '(.)'\)\s*&&\s*\(strcmp\(([^,]+),\s*("-\1[^"]*")\s*\)\s*==\s*0\)/(c == '$1') && LangCmpOpt($3,$2,0) == 0/g; + + if (defined($copyright) && !/^\s\*\s*Copyright/) + { + print $copyright; + undef $copyright; + } + + s/[^\S\n]+$//; + print; + + if (0 && /^((\s\*)\s*)Copyright/) + { + $copyright = "$2\n$1Modifications Copyright (c) 1994-2003 Nick Ing-Simmons\n"; + } + } + +select(STDOUT); +close(DST) or die "While writing to $dst~: $!"; + +rename "$dst~", $dst or die "Could not rename $dst~ to $dst: $!"; + +chmod(0444,$dst); + +exit 0; + |