1 | @rem = '--*-Perl-*--
|
---|
2 | @echo off
|
---|
3 | if "%OS%" == "Windows_NT" goto WinNT
|
---|
4 | perl -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
|
---|
5 | goto endofperl
|
---|
6 | :WinNT
|
---|
7 | perl -x -S %0 %*
|
---|
8 | if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl
|
---|
9 | if %errorlevel% == 9009 echo You do not have Perl in your PATH.
|
---|
10 | if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
|
---|
11 | goto endofperl
|
---|
12 | @rem ';
|
---|
13 | #!perl
|
---|
14 | #line 15
|
---|
15 | eval 'exec c:\shaoqunWu\perl\bin\perl.exe -S $0 ${1+"$@"}'
|
---|
16 | if $running_under_some_shell;
|
---|
17 |
|
---|
18 | =head1 NAME
|
---|
19 |
|
---|
20 | pl2pm - Rough tool to translate Perl4 .pl files to Perl5 .pm modules.
|
---|
21 |
|
---|
22 | =head1 SYNOPSIS
|
---|
23 |
|
---|
24 | B<pl2pm> F<files>
|
---|
25 |
|
---|
26 | =head1 DESCRIPTION
|
---|
27 |
|
---|
28 | B<pl2pm> is a tool to aid in the conversion of Perl4-style .pl
|
---|
29 | library files to Perl5-style library modules. Usually, your old .pl
|
---|
30 | file will still work fine and you should only use this tool if you
|
---|
31 | plan to update your library to use some of the newer Perl 5 features,
|
---|
32 | such as AutoLoading.
|
---|
33 |
|
---|
34 | =head1 LIMITATIONS
|
---|
35 |
|
---|
36 | It's just a first step, but it's usually a good first step.
|
---|
37 |
|
---|
38 | =head1 AUTHOR
|
---|
39 |
|
---|
40 | Larry Wall <[email protected]>
|
---|
41 |
|
---|
42 | =cut
|
---|
43 |
|
---|
44 | use strict;
|
---|
45 | use warnings;
|
---|
46 |
|
---|
47 | my %keyword = ();
|
---|
48 |
|
---|
49 | while (<DATA>) {
|
---|
50 | chomp;
|
---|
51 | $keyword{$_} = 1;
|
---|
52 | }
|
---|
53 |
|
---|
54 | local $/;
|
---|
55 |
|
---|
56 | while (<>) {
|
---|
57 | my $newname = $ARGV;
|
---|
58 | $newname =~ s/\.pl$/.pm/ || next;
|
---|
59 | $newname =~ s#(.*/)?(\w+)#$1\u$2#;
|
---|
60 | if (-f $newname) {
|
---|
61 | warn "Won't overwrite existing $newname\n";
|
---|
62 | next;
|
---|
63 | }
|
---|
64 | my $oldpack = $2;
|
---|
65 | my $newpack = "\u$2";
|
---|
66 | my @export = ();
|
---|
67 |
|
---|
68 | s/\bstd(in|out|err)\b/\U$&/g;
|
---|
69 | s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
|
---|
70 | if (/sub\s+\w+'/) {
|
---|
71 | @export = m/sub\s+\w+'(\w+)/g;
|
---|
72 | s/(sub\s+)main'(\w+)/$1$2/g;
|
---|
73 | }
|
---|
74 | else {
|
---|
75 | @export = m/sub\s+([A-Za-z]\w*)/g;
|
---|
76 | }
|
---|
77 | my @export_ok = grep($keyword{$_}, @export);
|
---|
78 | @export = grep(!$keyword{$_}, @export);
|
---|
79 |
|
---|
80 | my %export = ();
|
---|
81 | @export{@export} = (1) x @export;
|
---|
82 |
|
---|
83 | s/(^\s*);#/$1#/g;
|
---|
84 | s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
|
---|
85 | s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
|
---|
86 | s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg;
|
---|
87 | s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg;
|
---|
88 | if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
|
---|
89 | s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
|
---|
90 | s/\$\[\s*\+\s*//g;
|
---|
91 | s/\s*\+\s*\$\[//g;
|
---|
92 | s/\$\[/0/g;
|
---|
93 | }
|
---|
94 | s/open\s+(\w+)/open($1)/g;
|
---|
95 |
|
---|
96 | my $export_ok = '';
|
---|
97 | my $carp ='';
|
---|
98 |
|
---|
99 |
|
---|
100 | if (s/\bdie\b/croak/g) {
|
---|
101 | $carp = "use Carp;\n";
|
---|
102 | s/croak "([^"]*)\\n"/croak "$1"/g;
|
---|
103 | }
|
---|
104 |
|
---|
105 | if (@export_ok) {
|
---|
106 | $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
|
---|
107 | }
|
---|
108 |
|
---|
109 | if ( open(PM, ">$newname") ) {
|
---|
110 | print PM <<"END";
|
---|
111 | package $newpack;
|
---|
112 | use 5.006;
|
---|
113 | require Exporter;
|
---|
114 | $carp
|
---|
115 | \@ISA = qw(Exporter);
|
---|
116 | \@EXPORT = qw(@export);
|
---|
117 | $export_ok
|
---|
118 | $_
|
---|
119 | END
|
---|
120 | }
|
---|
121 | else {
|
---|
122 | warn "Can't create $newname: $!\n";
|
---|
123 | }
|
---|
124 | }
|
---|
125 |
|
---|
126 | sub xlate {
|
---|
127 | my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;
|
---|
128 |
|
---|
129 | my $xlated ;
|
---|
130 | if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
|
---|
131 | $xlated = "${pack}'$ident";
|
---|
132 | }
|
---|
133 | elsif ($pack eq '' || $pack eq 'main') {
|
---|
134 | if ($export->{$ident}) {
|
---|
135 | $xlated = "$prefix$ident";
|
---|
136 | }
|
---|
137 | else {
|
---|
138 | $xlated = "$prefix${pack}::$ident";
|
---|
139 | }
|
---|
140 | }
|
---|
141 | elsif ($pack eq $oldpack) {
|
---|
142 | $xlated = "$prefix${newpack}::$ident";
|
---|
143 | }
|
---|
144 | else {
|
---|
145 | $xlated = "$prefix${pack}::$ident";
|
---|
146 | }
|
---|
147 |
|
---|
148 | return $xlated;
|
---|
149 | }
|
---|
150 | __END__
|
---|
151 | AUTOLOAD
|
---|
152 | BEGIN
|
---|
153 | CORE
|
---|
154 | DESTROY
|
---|
155 | END
|
---|
156 | INIT
|
---|
157 | CHECK
|
---|
158 | abs
|
---|
159 | accept
|
---|
160 | alarm
|
---|
161 | and
|
---|
162 | atan2
|
---|
163 | bind
|
---|
164 | binmode
|
---|
165 | bless
|
---|
166 | caller
|
---|
167 | chdir
|
---|
168 | chmod
|
---|
169 | chomp
|
---|
170 | chop
|
---|
171 | chown
|
---|
172 | chr
|
---|
173 | chroot
|
---|
174 | close
|
---|
175 | closedir
|
---|
176 | cmp
|
---|
177 | connect
|
---|
178 | continue
|
---|
179 | cos
|
---|
180 | crypt
|
---|
181 | dbmclose
|
---|
182 | dbmopen
|
---|
183 | defined
|
---|
184 | delete
|
---|
185 | die
|
---|
186 | do
|
---|
187 | dump
|
---|
188 | each
|
---|
189 | else
|
---|
190 | elsif
|
---|
191 | endgrent
|
---|
192 | endhostent
|
---|
193 | endnetent
|
---|
194 | endprotoent
|
---|
195 | endpwent
|
---|
196 | endservent
|
---|
197 | eof
|
---|
198 | eq
|
---|
199 | eval
|
---|
200 | exec
|
---|
201 | exists
|
---|
202 | exit
|
---|
203 | exp
|
---|
204 | fcntl
|
---|
205 | fileno
|
---|
206 | flock
|
---|
207 | for
|
---|
208 | foreach
|
---|
209 | fork
|
---|
210 | format
|
---|
211 | formline
|
---|
212 | ge
|
---|
213 | getc
|
---|
214 | getgrent
|
---|
215 | getgrgid
|
---|
216 | getgrnam
|
---|
217 | gethostbyaddr
|
---|
218 | gethostbyname
|
---|
219 | gethostent
|
---|
220 | getlogin
|
---|
221 | getnetbyaddr
|
---|
222 | getnetbyname
|
---|
223 | getnetent
|
---|
224 | getpeername
|
---|
225 | getpgrp
|
---|
226 | getppid
|
---|
227 | getpriority
|
---|
228 | getprotobyname
|
---|
229 | getprotobynumber
|
---|
230 | getprotoent
|
---|
231 | getpwent
|
---|
232 | getpwnam
|
---|
233 | getpwuid
|
---|
234 | getservbyname
|
---|
235 | getservbyport
|
---|
236 | getservent
|
---|
237 | getsockname
|
---|
238 | getsockopt
|
---|
239 | glob
|
---|
240 | gmtime
|
---|
241 | goto
|
---|
242 | grep
|
---|
243 | gt
|
---|
244 | hex
|
---|
245 | if
|
---|
246 | index
|
---|
247 | int
|
---|
248 | ioctl
|
---|
249 | join
|
---|
250 | keys
|
---|
251 | kill
|
---|
252 | last
|
---|
253 | lc
|
---|
254 | lcfirst
|
---|
255 | le
|
---|
256 | length
|
---|
257 | link
|
---|
258 | listen
|
---|
259 | local
|
---|
260 | localtime
|
---|
261 | lock
|
---|
262 | log
|
---|
263 | lstat
|
---|
264 | lt
|
---|
265 | m
|
---|
266 | map
|
---|
267 | mkdir
|
---|
268 | msgctl
|
---|
269 | msgget
|
---|
270 | msgrcv
|
---|
271 | msgsnd
|
---|
272 | my
|
---|
273 | ne
|
---|
274 | next
|
---|
275 | no
|
---|
276 | not
|
---|
277 | oct
|
---|
278 | open
|
---|
279 | opendir
|
---|
280 | or
|
---|
281 | ord
|
---|
282 | our
|
---|
283 | pack
|
---|
284 | package
|
---|
285 | pipe
|
---|
286 | pop
|
---|
287 | pos
|
---|
288 | print
|
---|
289 | printf
|
---|
290 | prototype
|
---|
291 | push
|
---|
292 | q
|
---|
293 | qq
|
---|
294 | qr
|
---|
295 | quotemeta
|
---|
296 | qw
|
---|
297 | qx
|
---|
298 | rand
|
---|
299 | read
|
---|
300 | readdir
|
---|
301 | readline
|
---|
302 | readlink
|
---|
303 | readpipe
|
---|
304 | recv
|
---|
305 | redo
|
---|
306 | ref
|
---|
307 | rename
|
---|
308 | require
|
---|
309 | reset
|
---|
310 | return
|
---|
311 | reverse
|
---|
312 | rewinddir
|
---|
313 | rindex
|
---|
314 | rmdir
|
---|
315 | s
|
---|
316 | scalar
|
---|
317 | seek
|
---|
318 | seekdir
|
---|
319 | select
|
---|
320 | semctl
|
---|
321 | semget
|
---|
322 | semop
|
---|
323 | send
|
---|
324 | setgrent
|
---|
325 | sethostent
|
---|
326 | setnetent
|
---|
327 | setpgrp
|
---|
328 | setpriority
|
---|
329 | setprotoent
|
---|
330 | setpwent
|
---|
331 | setservent
|
---|
332 | setsockopt
|
---|
333 | shift
|
---|
334 | shmctl
|
---|
335 | shmget
|
---|
336 | shmread
|
---|
337 | shmwrite
|
---|
338 | shutdown
|
---|
339 | sin
|
---|
340 | sleep
|
---|
341 | socket
|
---|
342 | socketpair
|
---|
343 | sort
|
---|
344 | splice
|
---|
345 | split
|
---|
346 | sprintf
|
---|
347 | sqrt
|
---|
348 | srand
|
---|
349 | stat
|
---|
350 | study
|
---|
351 | sub
|
---|
352 | substr
|
---|
353 | symlink
|
---|
354 | syscall
|
---|
355 | sysopen
|
---|
356 | sysread
|
---|
357 | sysseek
|
---|
358 | system
|
---|
359 | syswrite
|
---|
360 | tell
|
---|
361 | telldir
|
---|
362 | tie
|
---|
363 | tied
|
---|
364 | time
|
---|
365 | times
|
---|
366 | tr
|
---|
367 | truncate
|
---|
368 | uc
|
---|
369 | ucfirst
|
---|
370 | umask
|
---|
371 | undef
|
---|
372 | unless
|
---|
373 | unlink
|
---|
374 | unpack
|
---|
375 | unshift
|
---|
376 | untie
|
---|
377 | until
|
---|
378 | use
|
---|
379 | utime
|
---|
380 | values
|
---|
381 | vec
|
---|
382 | wait
|
---|
383 | waitpid
|
---|
384 | wantarray
|
---|
385 | warn
|
---|
386 | while
|
---|
387 | write
|
---|
388 | x
|
---|
389 | xor
|
---|
390 | y
|
---|
391 |
|
---|
392 | __END__
|
---|
393 | :endofperl
|
---|