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 while (<DATA>) {
  65     chop;
  66     $keyword{$_} = 1;
  67 }
  68
  69 undef $/;
  70 $* = 1;
  71 while (<>) {
  72     $newname = $ARGV;
  73     $newname =~ s/\.pl$/.pm/ || next;
  74     $newname =~ s#(.*/)?(\w+)#$1\u$2#;
  75     if (-f $newname) {
  76         warn "Won't overwrite existing $newname\n";
  77         next;
  78     }
  79     $oldpack = $2;
  80     $newpack = "\u$2";
  81     @export = ();
  82     print "$oldpack => $newpack\n" if $verbose;
  83
  84     s/\bstd(in|out|err)\b/\U$&/g;
  85     s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
  86     if (/sub\s+main'/) {
  87         @export = m/sub\s+main'(\w+)/g;
  88         s/(sub\s+)main'(\w+)/$1$2/g;
  89     }
  90     else {
  91         @export = m/sub\s+([A-Za-z]\w*)/g;
  92     }
  93     @export_ok = grep($keyword{$_}, @export);
  94     @export = grep(!$keyword{$_}, @export);
  95     @export{@export} = (1) x @export;
  96     s/(^\s*);#/$1#/g;
  97     s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
  98     s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
  99     s/([\$\@%&*])'(\w+)/&xlate($1,"",$2)/eg;
 100     s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3)/eg;
 101     if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
 102         s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
 103         s/\$\[\s*\+\s*//g;
 104         s/\s*\+\s*\$\[//g;
 105         s/\$\[/0/g;
 106     }
 107     s/open\s+(\w+)/open($1)/g;
 108
 109     if (s/\bdie\b/croak/g) {
 110         $carp = "use Carp;\n";
 111         s/croak "([^"]*)\\n"/croak "$1"/g;
 112     }
 113     else {
 114         $carp = "";
 115     }
 116     if (@export_ok) {
 117         $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
 118     }
 119     else {
 120         $export_ok = "";
 121     }
 122
 123     open(PM, ">$newname") || warn "Can't create $newname: $!\n";
 124     print PM <<"END";
 125 package $newpack;
 126 require 5.000;
 127 require Exporter;
 128 $carp
 129 \@ISA = qw(Exporter);
 130 \@EXPORT = qw(@export);
 131 $export_ok
 132 $_
 133 END
 134 }
 135
 136 sub xlate {
 137     local($prefix, $pack, $ident) = @_;
 138     if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
 139         "${pack}'$ident";
 140     }
 141     elsif ($pack eq "" || $pack eq "main") {
 142         if ($export{$ident}) {
 143             "$prefix$ident";
 144         }
 145         else {
 146             "$prefix${pack}::$ident";
 147         }
 148     }
 149     elsif ($pack eq $oldpack) {
 150         "$prefix${newpack}::$ident";
 151     }
 152     else {
 153         "$prefix${pack}::$ident";
 154     }
 155 }
 156 __END__
 157 AUTOLOAD
 158 BEGIN
 159 CORE
 160 DESTROY
 161 END
 162 abs
 163 accept
 164 alarm
 165 and
 166 atan2
 167 bind
 168 binmode
 169 bless
 170 caller
 171 chdir
 172 chmod
 173 chop
 174 chown
 175 chr
 176 chroot
 177 close
 178 closedir
 179 cmp
 180 connect
 181 continue
 182 cos
 183 crypt
 184 dbmclose
 185 dbmopen
 186 defined
 187 delete
 188 die
 189 do
 190 dump
 191 each
 192 else
 193 elsif
 194 endgrent
 195 endhostent
 196 endnetent
 197 endprotoent
 198 endpwent
 199 endservent
 200 eof
 201 eq
 202 eval
 203 exec
 204 exit
 205 exp
 206 fcntl
 207 fileno
 208 flock
 209 for
 210 foreach
 211 fork
 212 format
 213 formline
 214 ge
 215 getc
 216 getgrent
 217 getgrgid
 218 getgrnam
 219 gethostbyaddr
 220 gethostbyname
 221 gethostent
 222 getlogin
 223 getnetbyaddr
 224 getnetbyname
 225 getnetent
 226 getpeername
 227 getpgrp
 228 getppid
 229 getpriority
 230 getprotobyname
 231 getprotobynumber
 232 getprotoent
 233 getpwent
 234 getpwnam
 235 getpwuid
 236 getservbyname
 237 getservbyport
 238 getservent
 239 getsockname
 240 getsockopt
 241 glob
 242 gmtime
 243 goto
 244 grep
 245 gt
 246 hex
 247 if
 248 index
 249 int
 250 ioctl
 251 join
 252 keys
 253 kill
 254 last
 255 lc
 256 lcfirst
 257 le
 258 length
 259 link
 260 listen
 261 local
 262 localtime
 263 log
 264 lstat
 265 lt
 266 m
 267 mkdir
 268 msgctl
 269 msgget
 270 msgrcv
 271 msgsnd
 272 my
 273 ne
 274 next
 275 no
 276 not
 277 oct
 278 open
 279 opendir
 280 or
 281 ord
 282 pack
 283 package
 284 pipe
 285 pop
 286 print
 287 printf
 288 push
 289 q
 290 qq
 291 quotemeta
 292 qw
 293 qx
 294 rand
 295 read
 296 readdir
 297 readline
 298 readlink
 299 readpipe
 300 recv
 301 redo
 302 ref
 303 rename
 304 require
 305 reset
 306 return
 307 reverse
 308 rewinddir
 309 rindex
 310 rmdir
 311 s
 312 scalar
 313 seek
 314 seekdir
 315 select
 316 semctl
 317 semget
 318 semop
 319 send
 320 setgrent
 321 sethostent
 322 setnetent
 323 setpgrp
 324 setpriority
 325 setprotoent
 326 setpwent
 327 setservent
 328 setsockopt
 329 shift
 330 shmctl
 331 shmget
 332 shmread
 333 shmwrite
 334 shutdown
 335 sin
 336 sleep
 337 socket
 338 socketpair
 339 sort
 340 splice
 341 split
 342 sprintf
 343 sqrt
 344 srand
 345 stat
 346 study
 347 sub
 348 substr
 349 symlink
 350 syscall
 351 sysread
 352 system
 353 syswrite
 354 tell
 355 telldir
 356 tie
 357 time
 358 times
 359 tr
 360 truncate
 361 uc
 362 ucfirst
 363 umask
 364 undef
 365 unless
 366 unlink
 367 unpack
 368 unshift
 369 untie
 370 until
 371 use
 372 utime
 373 values
 374 vec
 375 wait
 376 waitpid
 377 wantarray
 378 warn
 379 while
 380 write
 381 x
 382 xor
 383 y
 384 !NO!SUBS!
 385
 386 close OUT or die "Can't close $file: $!";
 387 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 388 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
 389 chdir $origdir;