[patch perl@8150] h2xs SYNOPSIS
[p5sagit/p5-mst-13.2.git] / utils / pl2pm.PL
CommitLineData
f50fdf03 1#!/usr/local/bin/perl
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
64while (<DATA>) {
65 chop;
66 $keyword{$_} = 1;
67}
68
69undef $/;
70$* = 1;
71while (<>) {
72 $newname = $ARGV;
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 }
79 $oldpack = $2;
80 $newpack = "\u$2";
81 @export = ();
82 print "$oldpack => $newpack\n" if $verbose;
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;
86 if (/sub\s+main'/) {
87 @export = m/sub\s+main'(\w+)/g;
88 s/(sub\s+)main'(\w+)/$1$2/g;
89 }
90 else {
91 @export = m/sub\s+([A-Za-z]\w*)/g;
92 }
93 @export_ok = grep($keyword{$_}, @export);
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;
99 s/([\$\@%&*])'(\w+)/&xlate($1,"",$2)/eg;
100 s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3)/eg;
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 }
113 else {
114 $carp = "";
115 }
116 if (@export_ok) {
117 $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
118 }
119 else {
120 $export_ok = "";
121 }
122
123 open(PM, ">$newname") || warn "Can't create $newname: $!\n";
124 print PM <<"END";
125package $newpack;
126require 5.000;
127require Exporter;
128$carp
129\@ISA = qw(Exporter);
130\@EXPORT = qw(@export);
131$export_ok
132$_
133END
134}
135
136sub xlate {
137 local($prefix, $pack, $ident) = @_;
138 if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
139 "${pack}'$ident";
140 }
141 elsif ($pack eq "" || $pack eq "main") {
142 if ($export{$ident}) {
143 "$prefix$ident";
144 }
145 else {
146 "$prefix${pack}::$ident";
147 }
148 }
149 elsif ($pack eq $oldpack) {
150 "$prefix${newpack}::$ident";
151 }
152 else {
153 "$prefix${pack}::$ident";
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 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;