summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/pTk/Tcl-pTk
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/pTk/Tcl-pTk')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Tk/pTk/Tcl-pTk260
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;
+