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 use 5.006;
 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 CHECK
 174 CORE
 175 DESTROY
 176 END
 177 INIT
 178 UNITCHECK
 179 abs
 180 accept
 181 alarm
 182 and
 183 atan2
 184 bind
 185 binmode
 186 bless
 187 caller
 188 chdir
 189 chmod
 190 chomp
 191 chop
 192 chown
 193 chr
 194 chroot
 195 close
 196 closedir
 197 cmp
 198 connect
 199 continue
 200 cos
 201 crypt
 202 dbmclose
 203 dbmopen
 204 defined
 205 delete
 206 die
 207 do
 208 dump
 209 each
 210 else
 211 elsif
 212 endgrent
 213 endhostent
 214 endnetent
 215 endprotoent
 216 endpwent
 217 endservent
 218 eof
 219 eq
 220 eval
 221 exec
 222 exists
 223 exit
 224 exp
 225 fcntl
 226 fileno
 227 flock
 228 for
 229 foreach
 230 fork
 231 format
 232 formline
 233 ge
 234 getc
 235 getgrent
 236 getgrgid
 237 getgrnam
 238 gethostbyaddr
 239 gethostbyname
 240 gethostent
 241 getlogin
 242 getnetbyaddr
 243 getnetbyname
 244 getnetent
 245 getpeername
 246 getpgrp
 247 getppid
 248 getpriority
 249 getprotobyname
 250 getprotobynumber
 251 getprotoent
 252 getpwent
 253 getpwnam
 254 getpwuid
 255 getservbyname
 256 getservbyport
 257 getservent
 258 getsockname
 259 getsockopt
 260 glob
 261 gmtime
 262 goto
 263 grep
 264 gt
 265 hex
 266 if
 267 index
 268 int
 269 ioctl
 270 join
 271 keys
 272 kill
 273 last
 274 lc
 275 lcfirst
 276 le
 277 length
 278 link
 279 listen
 280 local
 281 localtime
 282 lock
 283 log
 284 lstat
 285 lt
 286 m
 287 map
 288 mkdir
 289 msgctl
 290 msgget
 291 msgrcv
 292 msgsnd
 293 my
 294 ne
 295 next
 296 no
 297 not
 298 oct
 299 open
 300 opendir
 301 or
 302 ord
 303 our
 304 pack
 305 package
 306 pipe
 307 pop
 308 pos
 309 print
 310 printf
 311 prototype
 312 push
 313 q
 314 qq
 315 qr
 316 quotemeta
 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;