This is a live mirror of the Perl 5 development currently hosted at
https://github.com/perl/perl5
https://perl5.git.perl.org
/
perl5.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
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
=cut
+use strict;
+use warnings;
+
+my %keyword = ();
+
while (<DATA>) {
while (<DATA>) {
- chop;
+ cho
m
p;
$keyword{$_} = 1;
}
$keyword{$_} = 1;
}
-
undef
$/;
-$* = 1;
+
local
$/;
+
while (<>) {
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;
}
$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;
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;
}
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);
@export = grep(!$keyword{$_}, @export);
+
+ my %export = ();
@export{@export} = (1) x @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/(^\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;
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;
}
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;
}
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";
}
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;
package $newpack;
-
require 5.000
;
+
use 5.006
;
require Exporter;
$carp
\@ISA = qw(Exporter);
require Exporter;
$carp
\@ISA = qw(Exporter);
@@
-131,34
+137,45
@@
$carp
$export_ok
$_
END
$export_ok
$_
END
+ }
+ else {
+ warn "Can't create $newname: $!\n";
+ }
}
sub xlate {
}
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)$/) {
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 {
}
else {
- "$prefix${pack}::$ident";
+
$xlated =
"$prefix${pack}::$ident";
}
}
elsif ($pack eq $oldpack) {
}
}
elsif ($pack eq $oldpack) {
- "$prefix${newpack}::$ident";
+
$xlated =
"$prefix${newpack}::$ident";
}
else {
}
else {
- "$prefix${pack}::$ident";
+
$xlated =
"$prefix${pack}::$ident";
}
}
+
+ return $xlated;
}
__END__
AUTOLOAD
BEGIN
}
__END__
AUTOLOAD
BEGIN
+CHECK
CORE
DESTROY
END
CORE
DESTROY
END
+INIT
+UNITCHECK
abs
accept
alarm
abs
accept
alarm
@@
-170,6
+187,7
@@
bless
caller
chdir
chmod
caller
chdir
chmod
+chomp
chop
chown
chr
chop
chown
chr
@@
-201,6
+219,7
@@
eof
eq
eval
exec
eq
eval
exec
+exists
exit
exp
fcntl
exit
exp
fcntl
@@
-260,10
+279,12
@@
link
listen
local
localtime
listen
local
localtime
+lock
log
lstat
lt
m
log
lstat
lt
m
+map
mkdir
msgctl
msgget
mkdir
msgctl
msgget
@@
-279,15
+300,19
@@
open
opendir
or
ord
opendir
or
ord
+our
pack
package
pipe
pop
pack
package
pipe
pop
+pos
print
printf
print
printf
+prototype
push
q
qq
push
q
qq
+qr
quotemeta
qw
qx
quotemeta
qw
qx
@@
-348,12
+373,15
@@
sub
substr
symlink
syscall
substr
symlink
syscall
+sysopen
sysread
sysread
+sysseek
system
syswrite
tell
telldir
tie
system
syswrite
tell
telldir
tie
+tied
time
times
tr
time
times
tr