This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix the binary compatibility issue when building with/without
[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
LW
63
64while (<DATA>) {
52781dca 65 chop;
a0d0e21e
LW
66 $keyword{$_} = 1;
67}
68
52781dca
JH
69undef $/;
70$* = 1;
a0d0e21e 71while (<>) {
52781dca 72 $newname = $ARGV;
a0d0e21e
LW
73 $newname =~ s/\.pl$/.pm/ || next;
74 $newname =~ s#(.*/)?(\w+)#$1\u$2#;
75 if (-f $newname) {
76 warn "Won't overwrite existing $newname\n";
77 next;
78 }
52781dca
JH
79 $oldpack = $2;
80 $newpack = "\u$2";
81 @export = ();
82 print "$oldpack => $newpack\n" if $verbose;
a0d0e21e 83
748a9306 84 s/\bstd(in|out|err)\b/\U$&/g;
a0d0e21e 85 s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
52781dca
JH
86 if (/sub\s+main'/) {
87 @export = m/sub\s+main'(\w+)/g;
a0d0e21e
LW
88 s/(sub\s+)main'(\w+)/$1$2/g;
89 }
90 else {
91 @export = m/sub\s+([A-Za-z]\w*)/g;
92 }
52781dca 93 @export_ok = grep($keyword{$_}, @export);
a0d0e21e
LW
94 @export = grep(!$keyword{$_}, @export);
95 @export{@export} = (1) x @export;
96 s/(^\s*);#/$1#/g;
97 s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
98 s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
52781dca
JH
99 s/([\$\@%&*])'(\w+)/&xlate($1,"",$2)/eg;
100 s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3)/eg;
a0d0e21e
LW
101 if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
102 s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
103 s/\$\[\s*\+\s*//g;
104 s/\s*\+\s*\$\[//g;
105 s/\$\[/0/g;
106 }
107 s/open\s+(\w+)/open($1)/g;
108
109 if (s/\bdie\b/croak/g) {
110 $carp = "use Carp;\n";
111 s/croak "([^"]*)\\n"/croak "$1"/g;
112 }
52781dca
JH
113 else {
114 $carp = "";
115 }
a0d0e21e
LW
116 if (@export_ok) {
117 $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
118 }
52781dca
JH
119 else {
120 $export_ok = "";
121 }
a0d0e21e 122
52781dca
JH
123 open(PM, ">$newname") || warn "Can't create $newname: $!\n";
124 print PM <<"END";
a0d0e21e 125package $newpack;
52781dca 126require 5.000;
a0d0e21e
LW
127require Exporter;
128$carp
129\@ISA = qw(Exporter);
130\@EXPORT = qw(@export);
131$export_ok
132$_
133END
134}
135
136sub xlate {
52781dca 137 local($prefix, $pack, $ident) = @_;
a0d0e21e 138 if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
52781dca 139 "${pack}'$ident";
a0d0e21e 140 }
52781dca
JH
141 elsif ($pack eq "" || $pack eq "main") {
142 if ($export{$ident}) {
143 "$prefix$ident";
a0d0e21e
LW
144 }
145 else {
52781dca 146 "$prefix${pack}::$ident";
a0d0e21e
LW
147 }
148 }
149 elsif ($pack eq $oldpack) {
52781dca 150 "$prefix${newpack}::$ident";
a0d0e21e
LW
151 }
152 else {
52781dca 153 "$prefix${pack}::$ident";
a0d0e21e
LW
154 }
155}
156__END__
157AUTOLOAD
158BEGIN
159CORE
160DESTROY
161END
162abs
163accept
164alarm
165and
166atan2
167bind
168binmode
169bless
170caller
171chdir
172chmod
173chop
174chown
175chr
176chroot
177close
178closedir
179cmp
180connect
181continue
182cos
183crypt
184dbmclose
185dbmopen
186defined
187delete
188die
189do
190dump
191each
192else
193elsif
194endgrent
195endhostent
196endnetent
197endprotoent
198endpwent
199endservent
200eof
201eq
202eval
203exec
204exit
205exp
206fcntl
207fileno
208flock
209for
210foreach
211fork
212format
213formline
214ge
215getc
216getgrent
217getgrgid
218getgrnam
219gethostbyaddr
220gethostbyname
221gethostent
222getlogin
223getnetbyaddr
224getnetbyname
225getnetent
226getpeername
227getpgrp
228getppid
229getpriority
230getprotobyname
231getprotobynumber
232getprotoent
233getpwent
234getpwnam
235getpwuid
236getservbyname
237getservbyport
238getservent
239getsockname
240getsockopt
241glob
242gmtime
243goto
244grep
245gt
246hex
247if
248index
249int
250ioctl
251join
252keys
253kill
254last
255lc
256lcfirst
257le
258length
259link
260listen
261local
262localtime
263log
264lstat
265lt
266m
267mkdir
268msgctl
269msgget
270msgrcv
271msgsnd
272my
273ne
274next
275no
276not
277oct
278open
279opendir
280or
281ord
282pack
283package
284pipe
285pop
286print
287printf
288push
289q
290qq
291quotemeta
292qw
293qx
294rand
295read
296readdir
297readline
298readlink
299readpipe
300recv
301redo
302ref
303rename
304require
305reset
306return
307reverse
308rewinddir
309rindex
310rmdir
311s
312scalar
313seek
314seekdir
315select
316semctl
317semget
318semop
319send
320setgrent
321sethostent
322setnetent
323setpgrp
324setpriority
325setprotoent
326setpwent
327setservent
328setsockopt
329shift
330shmctl
331shmget
332shmread
333shmwrite
334shutdown
335sin
336sleep
337socket
338socketpair
339sort
340splice
341split
342sprintf
343sqrt
344srand
345stat
346study
347sub
348substr
349symlink
350syscall
351sysread
352system
353syswrite
354tell
355telldir
356tie
357time
358times
359tr
360truncate
361uc
362ucfirst
363umask
364undef
365unless
366unlink
367unpack
368unshift
369untie
370until
371use
372utime
373values
374vec
375wait
376waitpid
377wantarray
378warn
379while
380write
381x
382xor
383y
f50fdf03
PP
384!NO!SUBS!
385
386close OUT or die "Can't close $file: $!";
387chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
388exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
8a5546a1 389chdir $origdir;