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