utils/pl2pm.PL

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