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