| 1 | #!/usr/local/bin/perl -w |
| 2 | |
| 3 | use Carp; |
| 4 | |
| 5 | my $verbose = 0; |
| 6 | |
| 7 | $SIG{'__WARN__'} = sub { print STDERR $_; Carp::confess(shift) }; |
| 8 | |
| 9 | $src = shift; |
| 10 | $dst = shift; |
| 11 | |
| 12 | die "Usage: $0 <src> <dst> \n" unless (defined $src and defined $dst); |
| 13 | |
| 14 | chmod(0666, $dst); |
| 15 | unlink($dst); |
| 16 | open(DST,">$dst") || die "Cannot open $dst;$!"; |
| 17 | select(DST); |
| 18 | |
| 19 | my $copyright; |
| 20 | |
| 21 | @ARGV = ($src); |
| 22 | |
| 23 | undef $undone; |
| 24 | |
| 25 | sub getline |
| 26 | { |
| 27 | local $_; |
| 28 | if (defined $undone) |
| 29 | { |
| 30 | $_ = $undone; |
| 31 | undef $undone; |
| 32 | } |
| 33 | else |
| 34 | { |
| 35 | $_ = <>; |
| 36 | } |
| 37 | return $_; |
| 38 | } |
| 39 | |
| 40 | sub int_results |
| 41 | {my $fmt = shift; |
| 42 | my $type = shift; |
| 43 | my @fmt = split(/\s+/,$fmt); |
| 44 | my $cnt = @fmt; |
| 45 | # print STDERR "'$fmt' => $cnt\n"; |
| 46 | return "Tcl_${type}Results(interp,$cnt,0"; |
| 47 | } |
| 48 | |
| 49 | sub result |
| 50 | {my ($interp,$value,$tail) = @_; |
| 51 | my $line = &getline; |
| 52 | my $kind = "TCL_STATIC"; |
| 53 | if (defined $line) |
| 54 | { |
| 55 | if ($line =~ /^\s*$interp\s*->\s*freeProc\s*=\s*(.*)\s*;\s*$/) |
| 56 | { |
| 57 | $kind = $1; |
| 58 | } |
| 59 | else |
| 60 | { |
| 61 | $undone = $line if (defined $line); |
| 62 | } |
| 63 | } |
| 64 | return "Tcl_SetResult($interp,$value,$kind)$tail"; |
| 65 | } |
| 66 | |
| 67 | sub complete |
| 68 | { |
| 69 | my $tail = ""; |
| 70 | until (/;/) |
| 71 | { |
| 72 | my $line = &getline; |
| 73 | last unless defined($line); |
| 74 | s/\s*$//; |
| 75 | $line =~ s/^\s*//; |
| 76 | $_ .= " " . $line; |
| 77 | $tail .= "\n"; |
| 78 | } |
| 79 | $_ .= $tail; |
| 80 | } |
| 81 | |
| 82 | |
| 83 | |
| 84 | PROCESS: |
| 85 | while ($_ = &getline) |
| 86 | { |
| 87 | s/^\s*#\s*include\s*[<"]tcl\.h[">]\s*$/#include "Lang.h"\n/; |
| 88 | |
| 89 | s/^\s*#\s*include\s*<((tk|tkInt|tkPort|tix|tixInt)\.h)>\s*$/#include "$1"\n/; |
| 90 | |
| 91 | next if (/^\s*extern.*\bpanic\s*\(/); |
| 92 | |
| 93 | s/\(char\s*\*\)\s*NULL\b/ NULL/g; |
| 94 | |
| 95 | if (/if\s*\(\(c == '.'\)\s*$/) |
| 96 | { |
| 97 | my $line = &getline; |
| 98 | if (defined($line)) |
| 99 | { |
| 100 | s/\s*$//; |
| 101 | $line =~ s/^\s*//; |
| 102 | $_ .= " " . $line . "\n"; |
| 103 | } |
| 104 | } |
| 105 | |
| 106 | if (/Tcl_DeleteCommandFromToken/) |
| 107 | { |
| 108 | if (/Tcl_DeleteCommandFromToken[^;{]*$/) |
| 109 | { |
| 110 | &complete; |
| 111 | redo PROCESS; |
| 112 | } |
| 113 | s/Tcl_DeleteCommandFromToken(.*imageCmd)/Lang_DeleteObject$1/; |
| 114 | s/Tcl_DeleteCommandFromToken(.*widgetCmd)/Lang_DeleteWidget$1/; |
| 115 | } |
| 116 | |
| 117 | if (/Tcl_(Create|Delete)Command/) |
| 118 | { |
| 119 | if (/Tcl_(Create|Delete)Command[^;{]*$/) |
| 120 | { |
| 121 | &complete; |
| 122 | redo PROCESS; |
| 123 | } |
| 124 | s/Tcl_CreateCommand\s*\(\s*((\w+->)*interp)\s*,\s*Tk_PathName\s*\(([^\)]+)\)/Lang_CreateWidget($1,$3/; |
| 125 | s/Tcl_DeleteCommand\s*\(\s*((\w+->)*(\w+\.)?interp)\s*,\s*Tcl_GetCommandName\s*\([^,]+,\s*([^\)]+->(\w+\.style|image)Cmd)\)/Lang_DeleteObject($1,$4/; |
| 126 | s/Tcl_DeleteCommand\s*\(\s*((\w+->)*(\w+\.)?interp)\s*,\s*Tcl_GetCommandName\s*\([^,]+,\s*([^\)]+->widgetCmd)\)/Lang_DeleteWidget($1,$4/; |
| 127 | } |
| 128 | |
| 129 | if (/\bargv\w*\b/) |
| 130 | { |
| 131 | if (/\bargv\w*\s*\[([^[]*)\]\s*=[^=][^;{]*$/) |
| 132 | { |
| 133 | &complete; |
| 134 | redo PROCESS; |
| 135 | } |
| 136 | if (/\bchar\b.*\bargv\w*\b/) |
| 137 | { |
| 138 | # convert char *argv[] to char **argv |
| 139 | s/char\s*\*\s*\bargv\s*\[\s*\]/char **argv/; |
| 140 | # convert char **argv to Tcl_Obj **objv |
| 141 | s/char\s*\*\*\s*\bargv\b/Tcl_Obj **objv/; |
| 142 | # convert char *argv[n] to Tcl_Obj **objv = LangAllocVec(n) |
| 143 | s/char\s*\*\s*\bargv\s*\[\s*([^[]+)\]/Tcl_Obj **objv = LangAllocVec($1)/; |
| 144 | } |
| 145 | else |
| 146 | { |
| 147 | s/([^*])\*(argv\w*(\[[^[]*\])?)/${1}${2}[0]/g; |
| 148 | } |
| 149 | s/\bargv\s*\[([^[]*)\]\s*=([^=].*);\s*$/LangSetString(objv+$1,$2);\n/; |
| 150 | s/\bargv\s*\[([^[]*)\]\+\+/objv[$1] = LangStringArg(LangString(objv[$1])+1)/; |
| 151 | s/\bargv\s*\[([^[]*)\]\+([0-9])/LangStringArg(LangString(objv[$1])+$2)/; |
| 152 | if (/Tcl_Get(Boolean|Int|Double)/ || /Tk_Get(Cursor)/) |
| 153 | { |
| 154 | s/\bargv(\w*)\b/objv$1/g; |
| 155 | } |
| 156 | s/\bargv\s*(\[[^[]*\])/LangString(objv$1)/g; |
| 157 | if (/\bargv\b/) |
| 158 | { |
| 159 | warn "Leak: $_" if ($verbose && !/\bargv\s*\)/); |
| 160 | s/\bargv\b/objv/; |
| 161 | } |
| 162 | } |
| 163 | if (/->\s*result\b/) |
| 164 | { |
| 165 | s/\s*->\s*result\b/->result/g; |
| 166 | |
| 167 | s/\bsprintf\s*\(\s*interp->result\s*,\s*"((\s*%d)+)"/&int_results($1,"Int")/e; |
| 168 | |
| 169 | s/\bsprintf\s*\(\s*interp->result\s*,\s*"((\s*%g)+)"/&int_results($1,"Double")/e; |
| 170 | |
| 171 | s/\bsprintf\s*\(\s*interp->result\b/Tcl_SprintfResult(interp/; |
| 172 | if (/\binterp->result\s*=[^;]*$/) |
| 173 | { |
| 174 | &complete; |
| 175 | redo PROCESS; |
| 176 | } |
| 177 | s/\b((\w+\s*->\s*)*interp)->result\s*=([^;]*);/&result($1,$3,";")/e; |
| 178 | s/\b((\w+\s*->\s*)*interp)->result\s*=(.*);\s*$/&result($1,$3,";\n")/e; |
| 179 | s/\b((\w+\s*->\s*)*interp)->result/Tcl_GetResult($1)/; |
| 180 | } |
| 181 | |
| 182 | if (/\bTcl_SetResult\s*\(/) |
| 183 | { |
| 184 | if (/Tcl_SetResult\s*\([^;{]*$/) |
| 185 | { |
| 186 | &complete; |
| 187 | redo PROCESS; |
| 188 | } |
| 189 | s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*"(\d+)",\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1, Tcl_NewIntObj($3))/; |
| 190 | s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*Tk_PathName\(([^)]+)\),\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1,LangWidgetObj($1,$3))/; |
| 191 | s/Tcl_SetResult\s*\(\s*((\w+->)*interp),\s*((\w+->)*\w+)->pathName\s*,\s*TCL_STATIC\s*\)/Tcl_SetObjResult($1,LangWidgetObj($1,(Tk_Window)($3)))/; |
| 192 | die $_ if /(Tk_PathName|->pathName)/; |
| 193 | } |
| 194 | # 1 2 3 4 5 6 |
| 195 | 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; |
| 196 | s/\(c == '(.)'\)\s*&&\s*\(strcmp\(([^,]+),\s*("-\1[^"]*")\s*\)\s*==\s*0\)/(c == '$1') && LangCmpOpt($3,$2,0) == 0/g; |
| 197 | |
| 198 | if (defined($copyright) && !/^\s\*\s*Copyright/) |
| 199 | { |
| 200 | print $copyright; |
| 201 | undef $copyright; |
| 202 | } |
| 203 | |
| 204 | s/[^\S\n]+$//; |
| 205 | print; |
| 206 | |
| 207 | if (0 && /^((\s\*)\s*)Copyright/) |
| 208 | { |
| 209 | $copyright = "$2\n$1Modifications Copyright (c) 1994-2000 Nick Ing-Simmons\n"; |
| 210 | } |
| 211 | } |
| 212 | |
| 213 | select(STDOUT); |
| 214 | close(DST); |
| 215 | |
| 216 | chmod(0444,$dst); |
| 217 | |
| 218 | exit 0; |