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 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 qw
 317 qx
 318 rand
 319 read
 320 readdir
 321 readline
 322 readlink
 323 readpipe
 324 recv
 325 redo
 326 ref
 327 rename
 328 require
 329 reset
 330 return
 331 reverse
 332 rewinddir
 333 rindex
 334 rmdir
 335 s
 336 scalar
 337 seek
 338 seekdir
 339 select
 340 semctl
 341 semget
 342 semop
 343 send
 344 setgrent
 345 sethostent
 346 setnetent
 347 setpgrp
 348 setpriority
 349 setprotoent
 350 setpwent
 351 setservent
 352 setsockopt
 353 shift
 354 shmctl
 355 shmget
 356 shmread
 357 shmwrite
 358 shutdown
 359 sin
 360 sleep
 361 socket
 362 socketpair
 363 sort
 364 splice
 365 split
 366 sprintf
 367 sqrt
 368 srand
 369 stat
 370 study
 371 sub
 372 substr
 373 symlink
 374 syscall
 375 sysopen
 376 sysread
 377 sysseek
 378 system
 379 syswrite
 380 tell
 381 telldir
 382 tie
 383 tied
 384 time
 385 times
 386 tr
 387 truncate
 388 uc
 389 ucfirst
 390 umask
 391 undef
 392 unless
 393 unlink
 394 unpack
 395 unshift
 396 untie
 397 until
 398 use
 399 utime
 400 values
 401 vec
 402 wait
 403 waitpid
 404 wantarray
 405 warn
 406 while
 407 write
 408 x
 409 xor
 410 y
 411 !NO!SUBS!
 412
 413 close OUT or die "Can't close $file: $!";
 414 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 415 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 416 chdir $origdir;