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