develooper Front page | perl.perl5.porters | Postings from July 2001

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

Thread Previous | Thread Next
From:
Jonathan Stowe
Date:
July 2, 2001 12:18
Subject:
[PATCH 2 pl2pm.PL] (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
On Mon, 2 Jul 2001, Jonathan Stowe wrote:

> I'm almost certain that no-one uses pl2pm anymore but lest anyone should
> look at it as an example I have fixed it to use 'strict' and 'warnings' -
> and generally had a bit of a cleanup.  It does appear that it has had a
> long standing bug which can be evidenced by running the current version
> against ftp.pl in the distribution - I have fixed the symptom of the bug
> :)
>

That might be what I thought I was doing but it was a bunch of crap.  Put
it down to the heat, the dust, the surfeit of beer at the weekend but I
totally misdiagnosed the problem based on what I was seeing :(

Anyway here is one that *does* fix the bug :)

Oh and I took the opportunity to update the list of keywords too.

/J\

--- utils/pl2pm.PL~	Mon Jul  2 10:56:54 2001
+++ utils/pl2pm.PL	Mon Jul  2 18:59:36 2001
@@ -1,4 +1,4 @@
-#!/usr/local/bin/perl
+#!/usr/local/bin/per

 use Config;
 use File::Basename qw(&basename &dirname);
@@ -61,43 +61,50 @@

 =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 @@
     }
     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 @@
 $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 @@
 CORE
 DESTROY
 END
+INIT
+CHECK
 abs
 accept
 alarm
@@ -170,6 +185,7 @@
 caller
 chdir
 chmod
+chomp
 chop
 chown
 chr
@@ -201,6 +217,7 @@
 eq
 eval
 exec
+exists
 exit
 exp
 fcntl
@@ -260,10 +277,12 @@
 listen
 local
 localtime
+lock
 log
 lstat
 lt
 m
+map
 mkdir
 msgctl
 msgget
@@ -279,16 +298,21 @@
 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 @@
 substr
 symlink
 syscall
+sysopen
 sysread
+sysseek
 system
 syswrite
 tell
 telldir
 tie
+tied
 time
 times
 tr




-- 
Jonathan Stowe                      |
<http://www.gellyfish.com>          |      This space for rent
                                    |


Thread Previous | Thread Next


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About