pl2pm

   1 #!/usr/bin/perl
   2
   3 while (<DATA>) {
   4     chop;
   5     $keyword{$_} = 1;
   6 }
   7
   8 undef $/;
   9 $* = 1;
  10 while (<>) {
  11     $newname = $ARGV;
  12     $newname =~ s/\.pl$/.pm/ || next;
  13     $newname =~ s#(.*/)?(\w+)#$1\u$2#;
  14     if (-f $newname) {
  15         warn "Won't overwrite existing $newname\n";
  16         next;
  17     }
  18     $oldpack = $2;
  19     $newpack = "\u$2";
  20     @export = ();
  21     print "$oldpack => $newpack\n" if $verbose;
  22
  23     s/(sub\s+)(\w+)(\s*\{[ \t]*\n)\s*package\s+$oldpack\s*;[ \t]*\n+/${1}main'$2$3/ig;
  24     if (/sub\s+main'/) {
  25         @export = m/sub\s+main'(\w+)/g;
  26         s/(sub\s+)main'(\w+)/$1$2/g;
  27     }
  28     else {
  29         @export = m/sub\s+([A-Za-z]\w*)/g;
  30     }
  31     @export_ok = grep($keyword{$_}, @export);
  32     @export = grep(!$keyword{$_}, @export);
  33     @export{@export} = (1) x @export;
  34     s/(^\s*);#/$1#/g;
  35     s/(#.*)require ['"]$oldpack\.pl['"]/$1use $newpack/;
  36     s/(package\s*)($oldpack)\s*;[ \t]*\n+//ig;
  37     s/([\$\@%&*])'(\w+)/&xlate($1,"",$2)/eg;
  38     s/([\$\@%&*]?)(\w+)'(\w+)/&xlate($1,$2,$3)/eg;
  39     if (!/\$\[\s*\)?\s*=\s*[^0\s]/) {
  40         s/^\s*(local\s*\()?\s*\$\[\s*\)?\s*=\s*0\s*;[ \t]*\n//g;
  41         s/\$\[\s*\+\s*//g;
  42         s/\s*\+\s*\$\[//g;
  43         s/\$\[/0/g;
  44     }
  45     s/open\s+(\w+)/open($1)/g;
  46
  47     if (s/\bdie\b/croak/g) {
  48         $carp = "use Carp;\n";
  49         s/croak "([^"]*)\\n"/croak "$1"/g;
  50     }
  51     else {
  52         $carp = "";
  53     }
  54     if (@export_ok) {
  55         $export_ok = "\@EXPORT_OK = qw(@export_ok);\n";
  56     }
  57     else {
  58         $export_ok = "";
  59     }
  60
  61     open(PM, ">$newname") || warn "Can't create $newname: $!\n";
  62     print PM <<"END";
  63 package $newpack;
  64 require 5.000;
  65 require Exporter;
  66 $carp
  67 \@ISA = qw(Exporter);
  68 \@EXPORT = qw(@export);
  69 $export_ok
  70 $_
  71 END
  72 }
  73
  74 sub xlate {
  75     local($prefix, $pack, $ident) = @_;
  76     if ($prefix eq '' && $ident =~ /^(t|s|m|d|ing|ll|ed|ve|re)$/) {
  77         "${pack}'$ident";
  78     }
  79     elsif ($pack eq "" || $pack eq "main") {
  80         if ($export{$ident}) {
  81             "$prefix$ident";
  82         }
  83         else {
  84             "$prefix${pack}::$ident";
  85         }
  86     }
  87     elsif ($pack eq $oldpack) {
  88         "$prefix${newpack}::$ident";
  89     }
  90     else {
  91         "$prefix${pack}::$ident";
  92     }
  93 }
  94 __END__
  95 AUTOLOAD
  96 BEGIN
  97 CORE
  98 DESTROY
  99 END
 100 abs
 101 accept
 102 alarm
 103 and
 104 atan2
 105 bind
 106 binmode
 107 bless
 108 caller
 109 chdir
 110 chmod
 111 chop
 112 chown
 113 chr
 114 chroot
 115 close
 116 closedir
 117 cmp
 118 connect
 119 continue
 120 cos
 121 crypt
 122 dbmclose
 123 dbmopen
 124 defined
 125 delete
 126 die
 127 do
 128 dump
 129 each
 130 else
 131 elsif
 132 endgrent
 133 endhostent
 134 endnetent
 135 endprotoent
 136 endpwent
 137 endservent
 138 eof
 139 eq
 140 eval
 141 exec
 142 exit
 143 exp
 144 fcntl
 145 fileno
 146 flock
 147 for
 148 foreach
 149 fork
 150 format
 151 formline
 152 ge
 153 getc
 154 getgrent
 155 getgrgid
 156 getgrnam
 157 gethostbyaddr
 158 gethostbyname
 159 gethostent
 160 getlogin
 161 getnetbyaddr
 162 getnetbyname
 163 getnetent
 164 getpeername
 165 getpgrp
 166 getppid
 167 getpriority
 168 getprotobyname
 169 getprotobynumber
 170 getprotoent
 171 getpwent
 172 getpwnam
 173 getpwuid
 174 getservbyname
 175 getservbyport
 176 getservent
 177 getsockname
 178 getsockopt
 179 glob
 180 gmtime
 181 goto
 182 grep
 183 gt
 184 hex
 185 if
 186 index
 187 int
 188 ioctl
 189 join
 190 keys
 191 kill
 192 last
 193 lc
 194 lcfirst
 195 le
 196 length
 197 link
 198 listen
 199 local
 200 localtime
 201 log
 202 lstat
 203 lt
 204 m
 205 mkdir
 206 msgctl
 207 msgget
 208 msgrcv
 209 msgsnd
 210 my
 211 ne
 212 next
 213 no
 214 not
 215 oct
 216 open
 217 opendir
 218 or
 219 ord
 220 pack
 221 package
 222 pipe
 223 pop
 224 print
 225 printf
 226 push
 227 q
 228 qq
 229 quotemeta
 230 qw
 231 qx
 232 rand
 233 read
 234 readdir
 235 readline
 236 readlink
 237 readpipe
 238 recv
 239 redo
 240 ref
 241 rename
 242 require
 243 reset
 244 return
 245 reverse
 246 rewinddir
 247 rindex
 248 rmdir
 249 s
 250 scalar
 251 seek
 252 seekdir
 253 select
 254 semctl
 255 semget
 256 semop
 257 send
 258 setgrent
 259 sethostent
 260 setnetent
 261 setpgrp
 262 setpriority
 263 setprotoent
 264 setpwent
 265 setservent
 266 setsockopt
 267 shift
 268 shmctl
 269 shmget
 270 shmread
 271 shmwrite
 272 shutdown
 273 sin
 274 sleep
 275 socket
 276 socketpair
 277 sort
 278 splice
 279 split
 280 sprintf
 281 sqrt
 282 srand
 283 stat
 284 study
 285 sub
 286 substr
 287 symlink
 288 syscall
 289 sysread
 290 system
 291 syswrite
 292 tell
 293 telldir
 294 tie
 295 time
 296 times
 297 tr
 298 truncate
 299 uc
 300 ucfirst
 301 umask
 302 undef
 303 unless
 304 unlink
 305 unpack
 306 unshift
 307 untie
 308 until
 309 use
 310 utime
 311 values
 312 vec
 313 wait
 314 waitpid
 315 wantarray
 316 warn
 317 while
 318 write
 319 x
 320 xor
 321 y