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