1#!/usr/local/bin/perl 2 3use Config; 4use File::Basename qw(&basename &dirname); 5use 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; 17chdir dirname($0); 18$file = basename($0, '.PL'); 19$file .= '.com' if $^O eq 'VMS'; 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!"; 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 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 60Larry Wall <larry@wall.org> 61 62=cut 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 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"; 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 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 ':'; 389chdir $origdir; 390