(was Re: [PATCH pl2pm.PL] Make pl2pm be nice with 'strict' and 'warnings')

Message-ID: <Pine.LNX.4.33.0107021904530.7401-100000@orpheus.gellyfish.com>

p4raw-id: //depot/perl@11103

1 files changed, 58 insertions, 31 deletions

diff --git a/utils/pl2pm.PL b/utils/pl2pm.PL
index 48e281d1a5..472a478bdf 100644
--- a/utils/pl2pm.PL
+++ b/utils/pl2pm.PL
@@ -1,4 +1,4 @@
-#!/usr/local/bin/perl
+#!/usr/local/bin/per
 
 use Config;
 use File::Basename qw(&basename &dirname);
@@ -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,22 @@ 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;
+require 5.6.0;
 require Exporter;
 $carp
 \@ISA = qw(Exporter);
@@ -131,27 +136,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
@@ -159,6 +172,8 @@ BEGIN
 CORE
 DESTROY
 END
+INIT
+CHECK
 abs
 accept
 alarm
@@ -170,6 +185,7 @@ bless
 caller
 chdir
 chmod
+chomp
 chop
 chown
 chr
@@ -201,6 +217,7 @@ eof
 eq
 eval
 exec
+exists
 exit
 exp
 fcntl
@@ -260,10 +277,12 @@ link
 listen
 local
 localtime
+lock
 log
 lstat
 lt
 m
+map
 mkdir
 msgctl
 msgget
@@ -279,16 +298,21 @@ open
 opendir
 or
 ord
+our
 pack
 package
 pipe
 pop
+pos
 print
 printf
+prototype
 push
 q
 qq
+qr
 quotemeta
+qu
 qw
 qx
 rand
@@ -348,12 +372,15 @@ sub
 substr
 symlink
 syscall
+sysopen
 sysread
+sysseek
 system
 syswrite
 tell
 telldir
 tie
+tied
 time
 times
 tr