Oops. Failed to remove the now obsolete comment about custom ops.

[perl5.git] / utils / pl2pm.PL

diff --git a/utils/pl2pm.PL b/utils/pl2pm.PL
index e8277bb..d135bc8 100644 (file)
--- a/utils/pl2pm.PL
+++ b/utils/pl2pm.PL
@@ -2,6 +2,7 @@
 
 use Config;
 use File::Basename qw(&basename &dirname);
+use Cwd;
 
 # List explicitly here the variables you want Configure to
 # generate.  Metaconfig only looks for shell variables, so you
@@ -12,10 +13,10 @@ use File::Basename qw(&basename &dirname);
 
 # This forces PL files to create target in same directory as PL file.
 # This is so that make depend always knows where to find PL derivatives.
-chdir(dirname($0));
-($file = basename($0)) =~ s/\.PL$//;
-$file =~ s/\.pl$//
-       if ($^O eq 'VMS' or $^O eq 'os2');  # "case-forgiving"
+$origdir = cwd;
+chdir dirname($0);
+$file = basename($0, '.PL');
+$file .= '.com' if $^O eq 'VMS';
 
 open OUT,">$file" or die "Can't create $file: $!";
 
@@ -25,9 +26,9 @@ print "Extracting $file (with variable substitutions)\n";
 # You can use $Config{...} to use Configure variables.
 
 print OUT <<"!GROK!THIS!";
-$Config{'startperl'}
-    eval 'exec perl -S \$0 "\$@"'
-       if 0;
+$Config{startperl}
+    eval 'exec $Config{perlpath} -S \$0 \${1+"\$@"}'
+       if \$running_under_some_shell;
 !GROK!THIS!
 
 # In the following, perl variables are not expanded during extraction.
@@ -56,47 +57,54 @@ It's just a first step, but it's usually a good first step.
 
 =head1 AUTHOR
 
-Larry Wall <lwall@sems.com>
+Larry Wall <larry@wall.org>
 
 =cut
 
+use strict;
+use warnings;
+
+my %keyword = ();
+
 while (<DATA>) {
-    chop;
+    chomp;
     $keyword{$_} = 1;
 }
 
-undef $/;
-$* = 1;
+local $/;
+
 while (<>) {
-    $newname = $ARGV;
+    my $newname = $ARGV;
     $newname =~ s/\.pl$/.pm/ || next;
     $newname =~ s#(.*/)?(\w+)#$1\u$2#;
     if (-f $newname) {
        warn "Won't overwrite existing $newname\n";
        next;
     }
-    $oldpack = $2;
-    $newpack = "\u$2";
-    @export = ();
-    print "$oldpack => $newpack\n" if $verbose;
+    my $oldpack = $2;
+    my $newpack = "\u$2";
+    my @export = ();
 
     s/\bstd(in|out|err)\b/\U$&/g;
     s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
-    if (/sub\s+main'/) {
-       @export = m/sub\s+main'(\w+)/g;
+    if (/sub\s+\w+'/) {
+       @export = m/sub\s+\w+'(\w+)/g;
        s/(sub\s+)main'(\w+)/$1$2/g;
     }
     else {
        @export = m/sub\s+([A-Za-z]\w*)/g;
     }
-    @export_ok = grep($keyword{$_}, @export);
+    my @export_ok = grep($keyword{$_}, @export);
     @export = grep(!$keyword{$_}, @export);
+
+    my %export = ();
     @export{@export} = (1) x @export;
+
     s/(^\s*);#/$1#/g;
     s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
     s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
-    s/([\$\@%&*])'(\w+)/&xlate($1,"",$2)/eg;
-    s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3)/eg;
+    s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg;
+    s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg;
     if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
        s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
        s/\$\[\s*\+\s*//g;
@@ -105,24 +113,23 @@ while (<>) {
     }
     s/open\s+(\w+)/open($1)/g;
  
+    my $export_ok = '';
+    my $carp      ='';
+
+
     if (s/\bdie\b/croak/g) {
        $carp = "use Carp;\n";
        s/croak "([^"]*)\\n"/croak "$1"/g;
     }
-    else {
-       $carp = "";
-    }
+
     if (@export_ok) {
        $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
     }
-    else {
-       $export_ok = "";
-    }
 
-    open(PM, ">$newname") || warn "Can't create $newname: $!\n";
-    print PM <<"END";
+    if ( open(PM, ">$newname") ) {
+        print PM <<"END";
 package $newpack;
-require 5.000;
+use 5.006;
 require Exporter;
 $carp
 \@ISA = qw(Exporter);
@@ -130,27 +137,35 @@ $carp
 $export_ok
 $_
 END
+    }
+    else {
+      warn "Can't create $newname: $!\n";
+    }
 }
 
 sub xlate {
-    local($prefix, $pack, $ident) = @_;
+    my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;
+
+    my $xlated ;
     if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
-       "${pack}'$ident";
+       $xlated = "${pack}'$ident";
     }
-    elsif ($pack eq "" || $pack eq "main") {
-       if ($export{$ident}) {
-           "$prefix$ident";
+    elsif ($pack eq '' || $pack eq 'main') {
+       if ($export->{$ident}) {
+           $xlated = "$prefix$ident";
        }
        else {
-           "$prefix${pack}::$ident";
+           $xlated = "$prefix${pack}::$ident";
        }
     }
     elsif ($pack eq $oldpack) {
-       "$prefix${newpack}::$ident";
+       $xlated = "$prefix${newpack}::$ident";
     }
     else {
-       "$prefix${pack}::$ident";
+       $xlated = "$prefix${pack}::$ident";
     }
+
+    return $xlated;
 }
 __END__
 AUTOLOAD
@@ -158,6 +173,8 @@ BEGIN
 CORE
 DESTROY
 END
+INIT
+CHECK
 abs
 accept
 alarm
@@ -169,6 +186,7 @@ bless
 caller
 chdir
 chmod
+chomp
 chop
 chown
 chr
@@ -200,6 +218,7 @@ eof
 eq
 eval
 exec
+exists
 exit
 exp
 fcntl
@@ -259,10 +278,12 @@ link
 listen
 local
 localtime
+lock
 log
 lstat
 lt
 m
+map
 mkdir
 msgctl
 msgget
@@ -278,15 +299,19 @@ open
 opendir
 or
 ord
+our
 pack
 package
 pipe
 pop
+pos
 print
 printf
+prototype
 push
 q
 qq
+qr
 quotemeta
 qw
 qx
@@ -347,12 +372,15 @@ sub
 substr
 symlink
 syscall
+sysopen
 sysread
+sysseek
 system
 syswrite
 tell
 telldir
 tie
+tied
 time
 times
 tr
@@ -385,3 +413,4 @@ y
 close OUT or die "Can't close $file: $!";
 chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
 exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';
+chdir $origdir;