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