This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add UNITCHECK to the list of keywords in pl2pm
[perl5.git] / utils / pl2pm.PL
CommitLineData
8d3e0ca6 1#!/usr/local/bin/perl
f50fdf03
PP
2
3use Config;
4use File::Basename qw(&basename &dirname);
8a5546a1 5use Cwd;
f50fdf03
PP
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
PP
17chdir dirname($0);
18$file = basename($0, '.PL');
774d564b 19$file .= '.com' if $^O eq 'VMS';
f50fdf03
PP
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
PP
29$Config{startperl}
30 eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
31 if \$running_under_some_shell;
f50fdf03
PP
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
PP
61
62=cut
a0d0e21e 63
cb7e02c5
JS
64use strict;
65use warnings;
66
67my %keyword = ();
68
a0d0e21e 69while (<DATA>) {
cb7e02c5 70 chomp;
a0d0e21e
LW
71 $keyword{$_} = 1;
72}
73
cb7e02c5
JS
74local $/;
75
a0d0e21e 76while (<>) {
cb7e02c5 77 my $newname = $ARGV;
a0d0e21e
LW
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
JS
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
JS
90 if (/sub\s+\w+'/) {
91 @export = m/sub\s+\w+'(\w+)/g;
a0d0e21e
LW
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
JS
99
100 my %export = ();
a0d0e21e 101 @export{@export} = (1) x @export;
cb7e02c5 102
a0d0e21e
LW
103 s/(^\s*);#/$1#/g;
104 s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
105 s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
cb7e02c5
JS
106 s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg;
107 s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg;
a0d0e21e
LW
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
JS
116 my $export_ok = '';
117 my $carp ='';
118
119
a0d0e21e
LW
120 if (s/\bdie\b/croak/g) {
121 $carp = "use Carp;\n";
122 s/croak "([^"]*)\\n"/croak "$1"/g;
123 }
cb7e02c5 124
a0d0e21e
LW
125 if (@export_ok) {
126 $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
127 }
a0d0e21e 128
cb7e02c5
JS
129 if ( open(PM, ">$newname") ) {
130 print PM <<"END";
a0d0e21e 131package $newpack;
3b825e41 132use 5.006;
a0d0e21e
LW
133require Exporter;
134$carp
135\@ISA = qw(Exporter);
136\@EXPORT = qw(@export);
137$export_ok
138$_
139END
cb7e02c5
JS
140 }
141 else {
142 warn "Can't create $newname: $!\n";
143 }
a0d0e21e
LW
144}
145
146sub xlate {
cb7e02c5
JS
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
JS
153 elsif ($pack eq '' || $pack eq 'main') {
154 if ($export->{$ident}) {
155 $xlated = "$prefix$ident";
a0d0e21e
LW
156 }
157 else {
cb7e02c5 158 $xlated = "$prefix${pack}::$ident";
a0d0e21e
LW
159 }
160 }
161 elsif ($pack eq $oldpack) {
cb7e02c5 162 $xlated = "$prefix${newpack}::$ident";
a0d0e21e
LW
163 }
164 else {
cb7e02c5 165 $xlated = "$prefix${pack}::$ident";
a0d0e21e 166 }
cb7e02c5
JS
167
168 return $xlated;
a0d0e21e
LW
169}
170__END__
171AUTOLOAD
172BEGIN
d9fd9de7 173CHECK
a0d0e21e
LW
174CORE
175DESTROY
176END
cb7e02c5 177INIT
d9fd9de7 178UNITCHECK
a0d0e21e
LW
179abs
180accept
181alarm
182and
183atan2
184bind
185binmode
186bless
187caller
188chdir
189chmod
cb7e02c5 190chomp
a0d0e21e
LW
191chop
192chown
193chr
194chroot
195close
196closedir
197cmp
198connect
199continue
200cos
201crypt
202dbmclose
203dbmopen
204defined
205delete
206die
207do
208dump
209each
210else
211elsif
212endgrent
213endhostent
214endnetent
215endprotoent
216endpwent
217endservent
218eof
219eq
220eval
221exec
cb7e02c5 222exists
a0d0e21e
LW
223exit
224exp
225fcntl
226fileno
227flock
228for
229foreach
230fork
231format
232formline
233ge
234getc
235getgrent
236getgrgid
237getgrnam
238gethostbyaddr
239gethostbyname
240gethostent
241getlogin
242getnetbyaddr
243getnetbyname
244getnetent
245getpeername
246getpgrp
247getppid
248getpriority
249getprotobyname
250getprotobynumber
251getprotoent
252getpwent
253getpwnam
254getpwuid
255getservbyname
256getservbyport
257getservent
258getsockname
259getsockopt
260glob
261gmtime
262goto
263grep
264gt
265hex
266if
267index
268int
269ioctl
270join
271keys
272kill
273last
274lc
275lcfirst
276le
277length
278link
279listen
280local
281localtime
cb7e02c5 282lock
a0d0e21e
LW
283log
284lstat
285lt
286m
cb7e02c5 287map
a0d0e21e
LW
288mkdir
289msgctl
290msgget
291msgrcv
292msgsnd
293my
294ne
295next
296no
297not
298oct
299open
300opendir
301or
302ord
cb7e02c5 303our
a0d0e21e
LW
304pack
305package
306pipe
307pop
cb7e02c5 308pos
a0d0e21e
LW
309print
310printf
cb7e02c5 311prototype
a0d0e21e
LW
312push
313q
314qq
cb7e02c5 315qr
a0d0e21e
LW
316quotemeta
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
LW
379system
380syswrite
381tell
382telldir
383tie
cb7e02c5 384tied
a0d0e21e
LW
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
PP
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;