perl5.002beta3
[perl.git] / utils / pl2pm.PL
1 #!/usr/local/bin/perl
2
3 use Config;
4 use File::Basename qw(&basename &dirname);
5
6 # List explicitly here the variables you want Configure to
7 # generate.  Metaconfig only looks for shell variables, so you
8 # have to mention them as if they were shell variables, not
9 # %Config entries.  Thus you write
10 #  $startperl
11 # to ensure Configure will look for $Config{startperl}.
12
13 # This forces PL files to create target in same directory as PL file.
14 # This is so that make depend always knows where to find PL derivatives.
15 chdir(dirname($0));
16 ($file = basename($0)) =~ s/\.PL$//;
17 $file =~ s/\.pl$//
18         if ($Config{'osname'} eq 'VMS' or
19             $Config{'osname'} eq 'OS2');  # "case-forgiving"
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 perl -S \$0 "\$@"'
31         if 0;
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 <lwall@sems.com>
61
62 =cut
63
64 while (<DATA>) {
65     chop;
66     $keyword{$_} = 1;
67 }
68
69 undef $/;
70 $* = 1;
71 while (<>) {
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
84     s/\bstd(in|out|err)\b/\U$&/g;
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";
125 package $newpack;
126 require 5.000;
127 require Exporter;
128 $carp
129 \@ISA = qw(Exporter);
130 \@EXPORT = qw(@export);
131 $export_ok
132 $_
133 END
134 }
135
136 sub 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__
157 AUTOLOAD
158 BEGIN
159 CORE
160 DESTROY
161 END
162 abs
163 accept
164 alarm
165 and
166 atan2
167 bind
168 binmode
169 bless
170 caller
171 chdir
172 chmod
173 chop
174 chown
175 chr
176 chroot
177 close
178 closedir
179 cmp
180 connect
181 continue
182 cos
183 crypt
184 dbmclose
185 dbmopen
186 defined
187 delete
188 die
189 do
190 dump
191 each
192 else
193 elsif
194 endgrent
195 endhostent
196 endnetent
197 endprotoent
198 endpwent
199 endservent
200 eof
201 eq
202 eval
203 exec
204 exit
205 exp
206 fcntl
207 fileno
208 flock
209 for
210 foreach
211 fork
212 format
213 formline
214 ge
215 getc
216 getgrent
217 getgrgid
218 getgrnam
219 gethostbyaddr
220 gethostbyname
221 gethostent
222 getlogin
223 getnetbyaddr
224 getnetbyname
225 getnetent
226 getpeername
227 getpgrp
228 getppid
229 getpriority
230 getprotobyname
231 getprotobynumber
232 getprotoent
233 getpwent
234 getpwnam
235 getpwuid
236 getservbyname
237 getservbyport
238 getservent
239 getsockname
240 getsockopt
241 glob
242 gmtime
243 goto
244 grep
245 gt
246 hex
247 if
248 index
249 int
250 ioctl
251 join
252 keys
253 kill
254 last
255 lc
256 lcfirst
257 le
258 length
259 link
260 listen
261 local
262 localtime
263 log
264 lstat
265 lt
266 m
267 mkdir
268 msgctl
269 msgget
270 msgrcv
271 msgsnd
272 my
273 ne
274 next
275 no
276 not
277 oct
278 open
279 opendir
280 or
281 ord
282 pack
283 package
284 pipe
285 pop
286 print
287 printf
288 push
289 q
290 qq
291 quotemeta
292 qw
293 qx
294 rand
295 read
296 readdir
297 readline
298 readlink
299 readpipe
300 recv
301 redo
302 ref
303 rename
304 require
305 reset
306 return
307 reverse
308 rewinddir
309 rindex
310 rmdir
311 s
312 scalar
313 seek
314 seekdir
315 select
316 semctl
317 semget
318 semop
319 send
320 setgrent
321 sethostent
322 setnetent
323 setpgrp
324 setpriority
325 setprotoent
326 setpwent
327 setservent
328 setsockopt
329 shift
330 shmctl
331 shmget
332 shmread
333 shmwrite
334 shutdown
335 sin
336 sleep
337 socket
338 socketpair
339 sort
340 splice
341 split
342 sprintf
343 sqrt
344 srand
345 stat
346 study
347 sub
348 substr
349 symlink
350 syscall
351 sysread
352 system
353 syswrite
354 tell
355 telldir
356 tie
357 time
358 times
359 tr
360 truncate
361 uc
362 ucfirst
363 umask
364 undef
365 unless
366 unlink
367 unpack
368 unshift
369 untie
370 until
371 use
372 utime
373 values
374 vec
375 wait
376 waitpid
377 wantarray
378 warn
379 while
380 write
381 x
382 xor
383 y
384 !NO!SUBS!
385
386 close OUT or die "Can't close $file: $!";
387 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
388 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';