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