utils/pl2pm.PL

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