utils/pl2pm.PL

   1 #!/usr/local/bin/per
   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     if (s/\bdie\b/croak/g) {
 120         $carp = "use Carp;\n";
 121         s/croak "([^"]*)\\n"/croak "$1"/g;
 122     }
 123
 124     if (@export_ok) {
 125         $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
 126     }
 127
 128     if ( open(PM, ">$newname") ) {
 129        print PM <<"END";
 130 package $newpack;
 131 require 5.6.0;
 132 require Exporter;
 133 $carp
 134 \@ISA = qw(Exporter);
 135 \@EXPORT = qw(@export);
 136 $export_ok
 137 $_
 138 END
 139     }
 140     else {
 141       warn "Can't create $newname: $!\n";
 142     }
 143 }
 144
 145 sub xlate {
 146     my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;
 147
 148     my $xlated ;
 149     if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
 150         $xlated = "${pack}'$ident";
 151     }
 152     elsif ($pack eq '' || $pack eq 'main') {
 153         if ($export->{$ident}) {
 154             $xlated = "$prefix$ident";
 155         }
 156         else {
 157             $xlated = "$prefix${pack}::$ident";
 158         }
 159     }
 160     elsif ($pack eq $oldpack) {
 161         $xlated = "$prefix${newpack}::$ident";
 162     }
 163     else {
 164         $xlated = "$prefix${pack}::$ident";
 165     }
 166
 167     return $xlated;
 168 }
 169 __END__
 170 AUTOLOAD
 171 BEGIN
 172 CORE
 173 DESTROY
 174 END
 175 INIT
 176 CHECK
 177 abs
 178 accept
 179 alarm
 180 and
 181 atan2
 182 bind
 183 binmode
 184 bless
 185 caller
 186 chdir
 187 chmod
 188 chomp
 189 chop
 190 chown
 191 chr
 192 chroot
 193 close
 194 closedir
 195 cmp
 196 connect
 197 continue
 198 cos
 199 crypt
 200 dbmclose
 201 dbmopen
 202 defined
 203 delete
 204 die
 205 do
 206 dump
 207 each
 208 else
 209 elsif
 210 endgrent
 211 endhostent
 212 endnetent
 213 endprotoent
 214 endpwent
 215 endservent
 216 eof
 217 eq
 218 eval
 219 exec
 220 exists
 221 exit
 222 exp
 223 fcntl
 224 fileno
 225 flock
 226 for
 227 foreach
 228 fork
 229 format
 230 formline
 231 ge
 232 getc
 233 getgrent
 234 getgrgid
 235 getgrnam
 236 gethostbyaddr
 237 gethostbyname
 238 gethostent
 239 getlogin
 240 getnetbyaddr
 241 getnetbyname
 242 getnetent
 243 getpeername
 244 getpgrp
 245 getppid
 246 getpriority
 247 getprotobyname
 248 getprotobynumber
 249 getprotoent
 250 getpwent
 251 getpwnam
 252 getpwuid
 253 getservbyname
 254 getservbyport
 255 getservent
 256 getsockname
 257 getsockopt
 258 glob
 259 gmtime
 260 goto
 261 grep
 262 gt
 263 hex
 264 if
 265 index
 266 int
 267 ioctl
 268 join
 269 keys
 270 kill
 271 last
 272 lc
 273 lcfirst
 274 le
 275 length
 276 link
 277 listen
 278 local
 279 localtime
 280 lock
 281 log
 282 lstat
 283 lt
 284 m
 285 map
 286 mkdir
 287 msgctl
 288 msgget
 289 msgrcv
 290 msgsnd
 291 my
 292 ne
 293 next
 294 no
 295 not
 296 oct
 297 open
 298 opendir
 299 or
 300 ord
 301 our
 302 pack
 303 package
 304 pipe
 305 pop
 306 pos
 307 print
 308 printf
 309 prototype
 310 push
 311 q
 312 qq
 313 qr
 314 quotemeta
 315 qu
 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;