Commit | Line | Data |
---|---|---|
86530b38 AT |
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; |