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
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 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
# 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.
# 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: $!";
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!";
# 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.
!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
=head1 AUTHOR
-Larry Wall <l
wall@sems.com
>
+Larry Wall <l
arry@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;
@@
-105,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);
@@
-130,27
+137,35
@@
$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
}
__END__
AUTOLOAD
@@
-158,6
+173,8
@@
BEGIN
CORE
DESTROY
END
CORE
DESTROY
END
+INIT
+CHECK
abs
accept
alarm
abs
accept
alarm
@@
-169,6
+186,7
@@
bless
caller
chdir
chmod
caller
chdir
chmod
+chomp
chop
chown
chr
chop
chown
chr
@@
-200,6
+218,7
@@
eof
eq
eval
exec
eq
eval
exec
+exists
exit
exp
fcntl
exit
exp
fcntl
@@
-259,10
+278,12
@@
link
listen
local
localtime
listen
local
localtime
+lock
log
lstat
lt
m
log
lstat
lt
m
+map
mkdir
msgctl
msgget
mkdir
msgctl
msgget
@@
-278,15
+299,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
@@
-347,12
+372,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
@@
-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 ':';
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;