utils/pl2pm.PL

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