home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Source Code / C / Applications / MacPerl 5.0.3 / MacPerl Source ƒ / Perl5 / pl2pm < prev    next >
Encoding:
Text File  |  1994-12-26  |  3.5 KB  |  322 lines  |  [TEXT/MPS ]

  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
  322.