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