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 64use strict; 65use warnings; 66 67my %keyword = (); 68 69while (<DATA>) { 70 chomp; 71 $keyword{$_} = 1; 72} 73 74local $/; 75 76while (<>) { 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"; 131package $newpack; 132use 5.006; 133require Exporter; 134$carp 135\@ISA = qw(Exporter); 136\@EXPORT = qw(@export); 137$export_ok 138$_ 139END 140 } 141 else { 142 warn "Can't create $newname: $!\n"; 143 } 144} 145 146sub 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__ 171AUTOLOAD 172BEGIN 173CHECK 174CORE 175DESTROY 176END 177INIT 178UNITCHECK 179abs 180accept 181alarm 182and 183atan2 184bind 185binmode 186bless 187caller 188chdir 189chmod 190chomp 191chop 192chown 193chr 194chroot 195close 196closedir 197cmp 198connect 199continue 200cos 201crypt 202dbmclose 203dbmopen 204defined 205delete 206die 207do 208dump 209each 210else 211elsif 212endgrent 213endhostent 214endnetent 215endprotoent 216endpwent 217endservent 218eof 219eq 220eval 221exec 222exists 223exit 224exp 225fcntl 226fileno 227flock 228for 229foreach 230fork 231format 232formline 233ge 234getc 235getgrent 236getgrgid 237getgrnam 238gethostbyaddr 239gethostbyname 240gethostent 241getlogin 242getnetbyaddr 243getnetbyname 244getnetent 245getpeername 246getpgrp 247getppid 248getpriority 249getprotobyname 250getprotobynumber 251getprotoent 252getpwent 253getpwnam 254getpwuid 255getservbyname 256getservbyport 257getservent 258getsockname 259getsockopt 260glob 261gmtime 262goto 263grep 264gt 265hex 266if 267index 268int 269ioctl 270join 271keys 272kill 273last 274lc 275lcfirst 276le 277length 278link 279listen 280local 281localtime 282lock 283log 284lstat 285lt 286m 287map 288mkdir 289msgctl 290msgget 291msgrcv 292msgsnd 293my 294ne 295next 296no 297not 298oct 299open 300opendir 301or 302ord 303our 304pack 305package 306pipe 307pop 308pos 309print 310printf 311prototype 312push 313q 314qq 315qr 316quotemeta 317qw 318qx 319rand 320read 321readdir 322readline 323readlink 324readpipe 325recv 326redo 327ref 328rename 329require 330reset 331return 332reverse 333rewinddir 334rindex 335rmdir 336s 337scalar 338seek 339seekdir 340select 341semctl 342semget 343semop 344send 345setgrent 346sethostent 347setnetent 348setpgrp 349setpriority 350setprotoent 351setpwent 352setservent 353setsockopt 354shift 355shmctl 356shmget 357shmread 358shmwrite 359shutdown 360sin 361sleep 362socket 363socketpair 364sort 365splice 366split 367sprintf 368sqrt 369srand 370stat 371study 372sub 373substr 374symlink 375syscall 376sysopen 377sysread 378sysseek 379system 380syswrite 381tell 382telldir 383tie 384tied 385time 386times 387tr 388truncate 389uc 390ucfirst 391umask 392undef 393unless 394unlink 395unpack 396unshift 397untie 398until 399use 400utime 401values 402vec 403wait 404waitpid 405wantarray 406warn 407while 408write 409x 410xor 411y 412!NO!SUBS! 413 414close OUT or die "Can't close $file: $!"; 415chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; 416exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; 417chdir $origdir; 418