codekingpro/portable-devtools

1#!/usr/bin/perl2    eval 'exec /usr/bin/perl -S $0 ${1+"$@"}'3	if 0; # ^ Run only under a shell4 5=head1 NAME6 7pl2pm - Rough tool to translate Perl4 .pl files to Perl5 .pm modules.8 9=head1 SYNOPSIS10 11B<pl2pm> F<files>12 13=head1 DESCRIPTION14 15B<pl2pm> is a tool to aid in the conversion of Perl4-style .pl16library files to Perl5-style library modules.  Usually, your old .pl17file will still work fine and you should only use this tool if you18plan to update your library to use some of the newer Perl 5 features,19such as AutoLoading.20 21=head1 LIMITATIONS22 23It's just a first step, but it's usually a good first step.24 25=head1 AUTHOR26 27Larry Wall <larry@wall.org>28 29=cut30 31use strict;32use warnings;33 34my %keyword = ();35 36while (<DATA>) {37    chomp;38    $keyword{$_} = 1;39}40 41local $/;42 43while (<>) {44    my $newname = $ARGV;45    $newname =~ s/\.pl$/.pm/ || next;46    $newname =~ s#(.*/)?(\w+)#$1\u$2#;47    if (-f $newname) {48	warn "Won't overwrite existing $newname\n";49	next;50    }51    my $oldpack = $2;52    my $newpack = "\u$2";53    my @export = ();54 55    s/\bstd(in|out|err)\b/\U$&/g;56    s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;57    if (/sub\s+\w+'/) {58	@export = m/sub\s+\w+'(\w+)/g;59	s/(sub\s+)main'(\w+)/$1$2/g;60    }61    else {62	@export = m/sub\s+([A-Za-z]\w*)/g;63    }64    my @export_ok = grep($keyword{$_}, @export);65    @export = grep(!$keyword{$_}, @export);66 67    my %export = ();68    @export{@export} = (1) x @export;69 70    s/(^\s*);#/$1#/g;71    s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;72    s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;73    s/([\$\@%&*])'(\w+)/&xlate($1,"",$2,$newpack,$oldpack,\%export)/eg;74    s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3,$newpack,$oldpack,\%export)/eg;75    if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {76	s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;77	s/\$\[\s*\+\s*//g;78	s/\s*\+\s*\$\[//g;79	s/\$\[/0/g;80    }81    s/open\s+(\w+)/open($1)/g;82 83    my $export_ok = '';84    my $carp      ='';85 86 87    if (s/\bdie\b/croak/g) {88	$carp = "use Carp;\n";89	s/croak "([^"]*)\\n"/croak "$1"/g;90    }91 92    if (@export_ok) {93	$export_ok = "\@EXPORT_OK = qw(@export_ok);\n";94    }95 96    if ( open(PM, ">", $newname) ) {97        print PM <<"END";98package $newpack;99use 5.006;100require Exporter;101$carp102\@ISA = qw(Exporter);103\@EXPORT = qw(@export);104$export_ok105$_106END107    }108    else {109      warn "Can't create $newname: $!\n";110    }111}112 113sub xlate {114    my ($prefix, $pack, $ident,$newpack,$oldpack,$export) = @_;115 116    my $xlated ;117    if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {118	$xlated = "${pack}'$ident";119    }120    elsif ($pack eq '' || $pack eq 'main') {121	if ($export->{$ident}) {122	    $xlated = "$prefix$ident";123	}124	else {125	    $xlated = "$prefix${pack}::$ident";126	}127    }128    elsif ($pack eq $oldpack) {129	$xlated = "$prefix${newpack}::$ident";130    }131    else {132	$xlated = "$prefix${pack}::$ident";133    }134 135    return $xlated;136}137__END__138AUTOLOAD139BEGIN140CHECK141CORE142DESTROY143END144INIT145UNITCHECK146abs147accept148alarm149and150atan2151bind152binmode153bless154caller155chdir156chmod157chomp158chop159chown160chr161chroot162close163closedir164cmp165connect166continue167cos168crypt169dbmclose170dbmopen171defined172delete173die174do175dump176each177else178elsif179endgrent180endhostent181endnetent182endprotoent183endpwent184endservent185eof186eq187eval188exec189exists190exit191exp192fcntl193fileno194flock195for196foreach197fork198format199formline200ge201getc202getgrent203getgrgid204getgrnam205gethostbyaddr206gethostbyname207gethostent208getlogin209getnetbyaddr210getnetbyname211getnetent212getpeername213getpgrp214getppid215getpriority216getprotobyname217getprotobynumber218getprotoent219getpwent220getpwnam221getpwuid222getservbyname223getservbyport224getservent225getsockname226getsockopt227glob228gmtime229goto230grep231gt232hex233if234index235int236ioctl237join238keys239kill240last241lc242lcfirst243le244length245link246listen247local248localtime249lock250log251lstat252lt253m254map255mkdir256msgctl257msgget258msgrcv259msgsnd260my261ne262next263no264not265oct266open267opendir268or269ord270our271pack272package273pipe274pop275pos276print277printf278prototype279push280q281qq282qr283quotemeta284qw285qx286rand287read288readdir289readline290readlink291readpipe292recv293redo294ref295rename296require297reset298return299reverse300rewinddir301rindex302rmdir303s304scalar305seek306seekdir307select308semctl309semget310semop311send312setgrent313sethostent314setnetent315setpgrp316setpriority317setprotoent318setpwent319setservent320setsockopt321shift322shmctl323shmget324shmread325shmwrite326shutdown327sin328sleep329socket330socketpair331sort332splice333split334sprintf335sqrt336srand337stat338study339sub340substr341symlink342syscall343sysopen344sysread345sysseek346system347syswrite348tell349telldir350tie351tied352time353times354tr355truncate356uc357ucfirst358umask359undef360unless361unlink362unpack363unshift364untie365until366use367utime368values369vec370wait371waitpid372wantarray373warn374while375write376x377xor378y379