Add test for previously uncovered case.

[perl5.git] / utils / pl2pm.PL

diff --git a/utils/pl2pm.PL b/utils/pl2pm.PL
index 48e281d..b7e1cea 100644 (file)
--- a/utils/pl2pm.PL
+++ b/utils/pl2pm.PL
@@ -61,43 +61,50 @@ 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;
@@ -106,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);
@@ -131,34 +137,45 @@ $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
 BEGIN
+CHECK
 CORE
 DESTROY
 END
+INIT
+UNITCHECK
 abs
 accept
 alarm
@@ -170,6 +187,7 @@ bless
 caller
 chdir
 chmod
+chomp
 chop
 chown
 chr
@@ -201,6 +219,7 @@ eof
 eq
 eval
 exec
+exists
 exit
 exp
 fcntl
@@ -260,10 +279,12 @@ link
 listen
 local
 localtime
+lock
 log
 lstat
 lt
 m
+map
 mkdir
 msgctl
 msgget
@@ -279,15 +300,19 @@ open
 opendir
 or
 ord
+our
 pack
 package
 pipe
 pop
+pos
 print
 printf
+prototype
 push
 q
 qq
+qr
 quotemeta
 qw
 qx
@@ -348,12 +373,15 @@ sub
 substr
 symlink
 syscall
+sysopen
 sysread
+sysseek
 system
 syswrite
 tell
 telldir
 tie
+tied
 time
 times
 tr