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