home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume18 / perl / part26 < prev    next >
Encoding:
Internet Message Format  |  1991-04-17  |  49.7 KB
  1. From: lwall@netlabs.com (Larry Wall)
  2. Newsgroups: comp.sources.misc
  3. Subject: v18i044:  perl - The perl programming language, Part26/36
  4. Message-ID: <1991Apr17.185738.2601@sparky.IMD.Sterling.COM>
  5. Date: 17 Apr 91 18:57:38 GMT
  6. Approved: kent@sparky.imd.sterling.com
  7. X-Checksum-Snefru: 229e1a20 f9e5048a 92059680 c6251a39
  8.  
  9. Submitted-by: Larry Wall <lwall@netlabs.com>
  10. Posting-number: Volume 18, Issue 44
  11. Archive-name: perl/part26
  12.  
  13. [There are 36 kits for perl version 4.0.]
  14.  
  15. #! /bin/sh
  16.  
  17. # Make a new directory for the perl sources, cd to it, and run kits 1
  18. # thru 36 through sh.  When all 36 kits have been run, read README.
  19.  
  20. echo "This is perl 4.0 kit 26 (of 36).  If kit 26 is complete, the line"
  21. echo '"'"End of kit 26 (of 36)"'" will echo at the end.'
  22. echo ""
  23. export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
  24. mkdir eg lib x2p 2>/dev/null
  25. echo Extracting lib/perldb.pl
  26. sed >lib/perldb.pl <<'!STUFFY!FUNK!' -e 's/X//'
  27. Xpackage DB;
  28. X
  29. X$header = '$Header: perldb.pl,v 4.0 91/03/20 01:25:50 lwall Locked $';
  30. X#
  31. X# This file is automatically included if you do perl -d.
  32. X# It's probably not useful to include this yourself.
  33. X#
  34. X# Perl supplies the values for @line and %sub.  It effectively inserts
  35. X# a do DB'DB(<linenum>); in front of every place that can
  36. X# have a breakpoint.  It also inserts a do 'perldb.pl' before the first line.
  37. X#
  38. X# $Log:    perldb.pl,v $
  39. X# Revision 4.0  91/03/20  01:25:50  lwall
  40. X# 4.0 baseline.
  41. X# 
  42. X# Revision 3.0.1.6  91/01/11  18:08:58  lwall
  43. X# patch42: @_ couldn't be accessed from debugger
  44. X# 
  45. X# Revision 3.0.1.5  90/11/10  01:40:26  lwall
  46. X# patch38: the debugger wouldn't stop correctly or do action routines
  47. X# 
  48. X# Revision 3.0.1.4  90/10/15  17:40:38  lwall
  49. X# patch29: added caller
  50. X# patch29: the debugger now understands packages and evals
  51. X# patch29: scripts now run at almost full speed under the debugger
  52. X# patch29: more variables are settable from debugger
  53. X# 
  54. X# Revision 3.0.1.3  90/08/09  04:00:58  lwall
  55. X# patch19: debugger now allows continuation lines
  56. X# patch19: debugger can now dump lists of variables
  57. X# patch19: debugger can now add aliases easily from prompt
  58. X# 
  59. X# Revision 3.0.1.2  90/03/12  16:39:39  lwall
  60. X# patch13: perl -d didn't format stack traces of *foo right
  61. X# patch13: perl -d wiped out scalar return values of subroutines
  62. X# 
  63. X# Revision 3.0.1.1  89/10/26  23:14:02  lwall
  64. X# patch1: RCS expanded an unintended $Header in lib/perldb.pl
  65. X# 
  66. X# Revision 3.0  89/10/18  15:19:46  lwall
  67. X# 3.0 baseline
  68. X# 
  69. X# Revision 2.0  88/06/05  00:09:45  root
  70. X# Baseline version 2.0.
  71. X# 
  72. X#
  73. X
  74. Xopen(IN, "</dev/tty") || open(IN,  "<&STDIN");    # so we don't dingle stdin
  75. Xopen(OUT,">/dev/tty") || open(OUT, ">&STDOUT");    # so we don't dongle stdout
  76. Xselect(OUT);
  77. X$| = 1;                # for DB'OUT
  78. Xselect(STDOUT);
  79. X$| = 1;                # for real STDOUT
  80. X$sub = '';
  81. X
  82. X$header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
  83. Xprint OUT "\nLoading DB routines from $header\n\nEnter h for help.\n\n";
  84. X
  85. Xsub DB {
  86. X    &save;
  87. X    ($package, $filename, $line) = caller;
  88. X    $usercontext = '($@, $!, $[, $,, $/, $\) = @saved;' .
  89. X    "package $package;";        # this won't let them modify, alas
  90. X    local(*dbline) = "_<$filename";
  91. X    $max = $#dbline;
  92. X    if (($stop,$action) = split(/\0/,$dbline{$line})) {
  93. X    if ($stop eq '1') {
  94. X        $signal |= 1;
  95. X    }
  96. X    else {
  97. X        $evalarg = "\$DB'signal |= do {$stop;}"; &eval;
  98. X        $dbline{$line} =~ s/;9($|\0)/$1/;
  99. X    }
  100. X    }
  101. X    if ($single || $trace || $signal) {
  102. X    print OUT "$package'" unless $sub =~ /'/;
  103. X    print OUT "$sub($filename:$line):\t",$dbline[$line];
  104. X    for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) {
  105. X        last if $dbline[$i] =~ /^\s*(}|#|\n)/;
  106. X        print OUT "$sub($filename:$i):\t",$dbline[$i];
  107. X    }
  108. X    }
  109. X    $evalarg = $action, &eval if $action;
  110. X    if ($single || $signal) {
  111. X    $evalarg = $pre, &eval if $pre;
  112. X    print OUT $#stack . " levels deep in subroutine calls!\n"
  113. X        if $single & 4;
  114. X    $start = $line;
  115. X      CMD:
  116. X    while ((print OUT "  DB<", $#hist+1, "> "), $cmd=&gets) {
  117. X        {
  118. X        $single = 0;
  119. X        $signal = 0;
  120. X        $cmd eq '' && exit 0;
  121. X        chop($cmd);
  122. X        $cmd =~ s/\\$// && do {
  123. X            print OUT "  cont: ";
  124. X            $cmd .= &gets;
  125. X            redo CMD;
  126. X        };
  127. X        $cmd =~ /^q$/ && exit 0;
  128. X        $cmd =~ /^$/ && ($cmd = $laststep);
  129. X        push(@hist,$cmd) if length($cmd) > 1;
  130. X        ($i) = split(/\s+/,$cmd);
  131. X        eval "\$cmd =~ $alias{$i}", print OUT $@ if $alias{$i};
  132. X        $cmd =~ /^h$/ && do {
  133. X            print OUT "
  134. XT        Stack trace.
  135. Xs        Single step.
  136. Xn        Next, steps over subroutine calls.
  137. Xr        Return from current subroutine.
  138. Xc [line]    Continue; optionally inserts a one-time-only breakpoint 
  139. X        at the specified line.
  140. X<CR>        Repeat last n or s.
  141. Xl min+incr    List incr+1 lines starting at min.
  142. Xl min-max    List lines.
  143. Xl line        List line;
  144. Xl        List next window.
  145. X-        List previous window.
  146. Xw line        List window around line.
  147. Xl subname    List subroutine.
  148. Xf filename    Switch to filename.
  149. X/pattern/    Search forwards for pattern; final / is optional.
  150. X?pattern?    Search backwards for pattern.
  151. XL        List breakpoints and actions.
  152. XS        List subroutine names.
  153. Xt        Toggle trace mode.
  154. Xb [line] [condition]
  155. X        Set breakpoint; line defaults to the current execution line; 
  156. X        condition breaks if it evaluates to true, defaults to \'1\'.
  157. Xb subname [condition]
  158. X        Set breakpoint at first line of subroutine.
  159. Xd [line]    Delete breakpoint.
  160. XD        Delete all breakpoints.
  161. Xa [line] command
  162. X        Set an action to be done before the line is executed.
  163. X        Sequence is: check for breakpoint, print line if necessary,
  164. X        do action, prompt user if breakpoint or step, evaluate line.
  165. XA        Delete all actions.
  166. XV [pkg [vars]]    List some (default all) variables in package (default current).
  167. XX [vars]    Same as \"V currentpackage [vars]\".
  168. X< command    Define command before prompt.
  169. X> command    Define command after prompt.
  170. X! number    Redo command (default previous command).
  171. X! -number    Redo number\'th to last command.
  172. XH -number    Display last number commands (default all).
  173. Xq or ^D        Quit.
  174. Xp expr        Same as \"print DB'OUT expr\" in current package.
  175. X= [alias value]    Define a command alias, or list current aliases.
  176. Xcommand        Execute as a perl statement in current package.
  177. X
  178. X";
  179. X            next CMD; };
  180. X        $cmd =~ /^t$/ && do {
  181. X            $trace = !$trace;
  182. X            print OUT "Trace = ".($trace?"on":"off")."\n";
  183. X            next CMD; };
  184. X        $cmd =~ /^S$/ && do {
  185. X            foreach $subname (sort(keys %sub)) {
  186. X            print OUT $subname,"\n";
  187. X            }
  188. X            next CMD; };
  189. X        $cmd =~ s/^X\b/V $package/;
  190. X        $cmd =~ /^V$/ && do {
  191. X            $cmd = 'V $package'; };
  192. X        $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
  193. X            $packname = $1;
  194. X            @vars = split(' ',$2);
  195. X            do 'dumpvar.pl' unless defined &main'dumpvar;
  196. X            if (defined &main'dumpvar) {
  197. X            &main'dumpvar($packname,@vars);
  198. X            }
  199. X            else {
  200. X            print DB'OUT "dumpvar.pl not available.\n";
  201. X            }
  202. X            next CMD; };
  203. X        $cmd =~ /^f\b\s*(.*)/ && do {
  204. X            $file = $1;
  205. X            if (!$file) {
  206. X            print OUT "The old f command is now the r command.\n";
  207. X            print OUT "The new f command switches filenames.\n";
  208. X            next CMD;
  209. X            }
  210. X            if (!defined $_main{'_<' . $file}) {
  211. X            if (($try) = grep(m#^_<.*$file#, keys %_main)) {
  212. X                $file = substr($try,2);
  213. X                print "\n$file:\n";
  214. X            }
  215. X            }
  216. X            if (!defined $_main{'_<' . $file}) {
  217. X            print OUT "There's no code here anything matching $file.\n";
  218. X            next CMD;
  219. X            }
  220. X            elsif ($file ne $filename) {
  221. X            *dbline = "_<$file";
  222. X            $max = $#dbline;
  223. X            $filename = $file;
  224. X            $start = 1;
  225. X            $cmd = "l";
  226. X            } };
  227. X        $cmd =~ /^l\b\s*(['A-Za-z_]['\w]*)/ && do {
  228. X            $subname = $1;
  229. X            $subname = "main'" . $subname unless $subname =~ /'/;
  230. X            $subname = "main" . $subname if substr($subname,0,1) eq "'";
  231. X            ($file,$subrange) = split(/:/,$sub{$subname});
  232. X            if ($file ne $filename) {
  233. X            *dbline = "_<$file";
  234. X            $max = $#dbline;
  235. X            $filename = $file;
  236. X            }
  237. X            if ($subrange) {
  238. X            if (eval($subrange) < -$window) {
  239. X                $subrange =~ s/-.*/+/;
  240. X            }
  241. X            $cmd = "l $subrange";
  242. X            } else {
  243. X            print OUT "Subroutine $1 not found.\n";
  244. X            next CMD;
  245. X            } };
  246. X        $cmd =~ /^w\b\s*(\d*)$/ && do {
  247. X            $incr = $window - 1;
  248. X            $start = $1 if $1;
  249. X            $start -= $preview;
  250. X            $cmd = 'l ' . $start . '-' . ($start + $incr); };
  251. X        $cmd =~ /^-$/ && do {
  252. X            $incr = $window - 1;
  253. X            $cmd = 'l ' . ($start-$window*2) . '+'; };
  254. X        $cmd =~ /^l$/ && do {
  255. X            $incr = $window - 1;
  256. X            $cmd = 'l ' . $start . '-' . ($start + $incr); };
  257. X        $cmd =~ /^l\b\s*(\d*)\+(\d*)$/ && do {
  258. X            $start = $1 if $1;
  259. X            $incr = $2;
  260. X            $incr = $window - 1 unless $incr;
  261. X            $cmd = 'l ' . $start . '-' . ($start + $incr); };
  262. X        $cmd =~ /^l\b\s*(([\d\$\.]+)([-,]([\d\$\.]+))?)?/ && do {
  263. X            $end = (!$2) ? $max : ($4 ? $4 : $2);
  264. X            $end = $max if $end > $max;
  265. X            $i = $2;
  266. X            $i = $line if $i eq '.';
  267. X            $i = 1 if $i < 1;
  268. X            for (; $i <= $end; $i++) {
  269. X            print OUT "$i:\t", $dbline[$i];
  270. X            last if $signal;
  271. X            }
  272. X            $start = $i;    # remember in case they want more
  273. X            $start = $max if $start > $max;
  274. X            next CMD; };
  275. X        $cmd =~ /^D$/ && do {
  276. X            print OUT "Deleting all breakpoints...\n";
  277. X            for ($i = 1; $i <= $max ; $i++) {
  278. X            if (defined $dbline{$i}) {
  279. X                $dbline{$i} =~ s/^[^\0]+//;
  280. X                if ($dbline{$i} =~ s/^\0?$//) {
  281. X                delete $dbline{$i};
  282. X                }
  283. X            }
  284. X            }
  285. X            next CMD; };
  286. X        $cmd =~ /^L$/ && do {
  287. X            for ($i = 1; $i <= $max; $i++) {
  288. X            if (defined $dbline{$i}) {
  289. X                print OUT "$i:\t", $dbline[$i];
  290. X                ($stop,$action) = split(/\0/, $dbline{$i});
  291. X                print OUT "  break if (", $stop, ")\n" 
  292. X                if $stop;
  293. X                print OUT "  action:  ", $action, "\n" 
  294. X                if $action;
  295. X                last if $signal;
  296. X            }
  297. X            }
  298. X            next CMD; };
  299. X        $cmd =~ /^b\b\s*(['A-Za-z_]['\w]*)\s*(.*)/ && do {
  300. X            $subname = $1;
  301. X            $cond = $2 || '1';
  302. X            $subname = "$package'" . $subname unless $subname =~ /'/;
  303. X            $subname = "main" . $subname if substr($subname,0,1) eq "'";
  304. X            ($filename,$i) = split(/[:-]/, $sub{$subname});
  305. X            if ($i) {
  306. X            *dbline = "_<$filename";
  307. X            ++$i while $dbline[$i] == 0 && $i < $#dbline;
  308. X            $dbline{$i} =~ s/^[^\0]*/$cond/;
  309. X            } else {
  310. X            print OUT "Subroutine $subname not found.\n";
  311. X            }
  312. X            next CMD; };
  313. X        $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
  314. X            $i = ($1?$1:$line);
  315. X            $cond = $2 || '1';
  316. X            if ($dbline[$i] == 0) {
  317. X            print OUT "Line $i not breakable.\n";
  318. X            } else {
  319. X            $dbline{$i} =~ s/^[^\0]*/$cond/;
  320. X            }
  321. X            next CMD; };
  322. X        $cmd =~ /^d\b\s*(\d+)?/ && do {
  323. X            $i = ($1?$1:$line);
  324. X            $dbline{$i} =~ s/^[^\0]*//;
  325. X            delete $dbline{$i} if $dbline{$i} eq '';
  326. X            next CMD; };
  327. X        $cmd =~ /^A$/ && do {
  328. X            for ($i = 1; $i <= $max ; $i++) {
  329. X            if (defined $dbline{$i}) {
  330. X                $dbline{$i} =~ s/\0[^\0]*//;
  331. X                delete $dbline{$i} if $dbline{$i} eq '';
  332. X            }
  333. X            }
  334. X            next CMD; };
  335. X        $cmd =~ /^<\s*(.*)/ && do {
  336. X            $pre = do action($1);
  337. X            next CMD; };
  338. X        $cmd =~ /^>\s*(.*)/ && do {
  339. X            $post = do action($1);
  340. X            next CMD; };
  341. X        $cmd =~ /^a\b\s*(\d+)(\s+(.*))?/ && do {
  342. X            $i = $1;
  343. X            if ($dbline[$i] == 0) {
  344. X            print OUT "Line $i may not have an action.\n";
  345. X            } else {
  346. X            $dbline{$i} =~ s/\0[^\0]*//;
  347. X            $dbline{$i} .= "\0" . do action($3);
  348. X            }
  349. X            next CMD; };
  350. X        $cmd =~ /^n$/ && do {
  351. X            $single = 2;
  352. X            $laststep = $cmd;
  353. X            last CMD; };
  354. X        $cmd =~ /^s$/ && do {
  355. X            $single = 1;
  356. X            $laststep = $cmd;
  357. X            last CMD; };
  358. X        $cmd =~ /^c\b\s*(\d*)\s*$/ && do {
  359. X            $i = $1;
  360. X            if ($i) {
  361. X            if ($dbline[$i] == 0) {
  362. X                print OUT "Line $i not breakable.\n";
  363. X                next CMD;
  364. X            }
  365. X            $dbline{$i} =~ s/(\0|$)/;9$1/;    # add one-time-only b.p.
  366. X            }
  367. X            for ($i=0; $i <= $#stack; ) {
  368. X            $stack[$i++] &= ~1;
  369. X            }
  370. X            last CMD; };
  371. X        $cmd =~ /^r$/ && do {
  372. X            $stack[$#stack] |= 2;
  373. X            last CMD; };
  374. X        $cmd =~ /^T$/ && do {
  375. X            local($p,$f,$l,$s,$h,$a,@a,@sub);
  376. X            for ($i = 1; ($p,$f,$l,$s,$h,$w) = caller($i); $i++) {
  377. X            @a = @args;
  378. X            for (@a) {
  379. X                if (/^StB\000/ && length($_) == length($_main{'_main'})) {
  380. X                $_ = sprintf("%s",$_);
  381. X                }
  382. X                else {
  383. X                s/'/\\'/g;
  384. X                s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
  385. X                s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  386. X                s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  387. X                }
  388. X            }
  389. X            $w = $w ? '@ = ' : '$ = ';
  390. X            $a = $h ? '(' . join(', ', @a) . ')' : '';
  391. X            push(@sub, "$w&$s$a from file $f line $l\n");
  392. X            last if $signal;
  393. X            }
  394. X            for ($i=0; $i <= $#sub; $i++) {
  395. X            last if $signal;
  396. X            print OUT $sub[$i];
  397. X            }
  398. X            next CMD; };
  399. X        $cmd =~ /^\/(.*)$/ && do {
  400. X            $inpat = $1;
  401. X            $inpat =~ s:([^\\])/$:$1:;
  402. X            if ($inpat ne "") {
  403. X            eval '$inpat =~ m'."\n$inpat\n";    
  404. X            if ($@ ne "") {
  405. X                print OUT "$@";
  406. X                next CMD;
  407. X            }
  408. X            $pat = $inpat;
  409. X            }
  410. X            $end = $start;
  411. X            eval '
  412. X            for (;;) {
  413. X            ++$start;
  414. X            $start = 1 if ($start > $max);
  415. X            last if ($start == $end);
  416. X            if ($dbline[$start] =~ m'."\n$pat\n".'i) {
  417. X                print OUT "$start:\t", $dbline[$start], "\n";
  418. X                last;
  419. X            }
  420. X            } ';
  421. X            print OUT "/$pat/: not found\n" if ($start == $end);
  422. X            next CMD; };
  423. X        $cmd =~ /^\?(.*)$/ && do {
  424. X            $inpat = $1;
  425. X            $inpat =~ s:([^\\])\?$:$1:;
  426. X            if ($inpat ne "") {
  427. X            eval '$inpat =~ m'."\n$inpat\n";    
  428. X            if ($@ ne "") {
  429. X                print OUT "$@";
  430. X                next CMD;
  431. X            }
  432. X            $pat = $inpat;
  433. X            }
  434. X            $end = $start;
  435. X            eval '
  436. X            for (;;) {
  437. X            --$start;
  438. X            $start = $max if ($start <= 0);
  439. X            last if ($start == $end);
  440. X            if ($dbline[$start] =~ m'."\n$pat\n".'i) {
  441. X                print OUT "$start:\t", $dbline[$start], "\n";
  442. X                last;
  443. X            }
  444. X            } ';
  445. X            print OUT "?$pat?: not found\n" if ($start == $end);
  446. X            next CMD; };
  447. X        $cmd =~ /^!+\s*(-)?(\d+)?$/ && do {
  448. X            pop(@hist) if length($cmd) > 1;
  449. X            $i = ($1?($#hist-($2?$2:1)):($2?$2:$#hist));
  450. X            $cmd = $hist[$i] . "\n";
  451. X            print OUT $cmd;
  452. X            redo CMD; };
  453. X        $cmd =~ /^!(.+)$/ && do {
  454. X            $pat = "^$1";
  455. X            pop(@hist) if length($cmd) > 1;
  456. X            for ($i = $#hist; $i; --$i) {
  457. X            last if $hist[$i] =~ $pat;
  458. X            }
  459. X            if (!$i) {
  460. X            print OUT "No such command!\n\n";
  461. X            next CMD;
  462. X            }
  463. X            $cmd = $hist[$i] . "\n";
  464. X            print OUT $cmd;
  465. X            redo CMD; };
  466. X        $cmd =~ /^H\b\s*(-(\d+))?/ && do {
  467. X            $end = $2?($#hist-$2):0;
  468. X            $hist = 0 if $hist < 0;
  469. X            for ($i=$#hist; $i>$end; $i--) {
  470. X            print OUT "$i: ",$hist[$i],"\n"
  471. X                unless $hist[$i] =~ /^.?$/;
  472. X            };
  473. X            next CMD; };
  474. X        $cmd =~ s/^p( .*)?$/print DB'OUT$1/;
  475. X        $cmd =~ /^=/ && do {
  476. X            if (local($k,$v) = ($cmd =~ /^=\s*(\S+)\s+(.*)/)) {
  477. X            $alias{$k}="s~$k~$v~";
  478. X            print OUT "$k = $v\n";
  479. X            } elsif ($cmd =~ /^=\s*$/) {
  480. X            foreach $k (sort keys(%alias)) {
  481. X                if (($v = $alias{$k}) =~ s~^s\~$k\~(.*)\~$~$1~) {
  482. X                print OUT "$k = $v\n";
  483. X                } else {
  484. X                print OUT "$k\t$alias{$k}\n";
  485. X                };
  486. X            };
  487. X            };
  488. X            next CMD; };
  489. X        }
  490. X        $evalarg = $cmd; &eval;
  491. X        print OUT "\n";
  492. X    }
  493. X    if ($post) {
  494. X        $evalarg = $post; &eval;
  495. X    }
  496. X    }
  497. X    ($@, $!, $[, $,, $/, $\) = @saved;
  498. X}
  499. X
  500. Xsub save {
  501. X    @saved = ($@, $!, $[, $,, $/, $\);
  502. X    $[ = 0; $, = ""; $/ = "\n"; $\ = "";
  503. X}
  504. X
  505. X# The following takes its argument via $evalarg to preserve current @_
  506. X
  507. Xsub eval {
  508. X    eval "$usercontext $evalarg; &DB'save";
  509. X    print OUT $@;
  510. X}
  511. X
  512. Xsub action {
  513. X    local($action) = @_;
  514. X    while ($action =~ s/\\$//) {
  515. X    print OUT "+ ";
  516. X    $action .= &gets;
  517. X    }
  518. X    $action;
  519. X}
  520. X
  521. Xsub gets {
  522. X    local($.);
  523. X    <IN>;
  524. X}
  525. X
  526. Xsub catch {
  527. X    $signal = 1;
  528. X}
  529. X
  530. Xsub sub {
  531. X    push(@stack, $single);
  532. X    $single &= 1;
  533. X    $single |= 4 if $#stack == $deep;
  534. X    if (wantarray) {
  535. X    @i = &$sub;
  536. X    $single |= pop(@stack);
  537. X    @i;
  538. X    }
  539. X    else {
  540. X    $i = &$sub;
  541. X    $single |= pop(@stack);
  542. X    $i;
  543. X    }
  544. X}
  545. X
  546. X$single = 1;            # so it stops on first executable statement
  547. X@hist = ('?');
  548. X$SIG{'INT'} = "DB'catch";
  549. X$deep = 100;        # warning if stack gets this deep
  550. X$window = 10;
  551. X$preview = 3;
  552. X
  553. X@stack = (0);
  554. X@ARGS = @ARGV;
  555. Xfor (@args) {
  556. X    s/'/\\'/g;
  557. X    s/(.*)/'$1'/ unless /^-?[\d.]+$/;
  558. X}
  559. X
  560. Xif (-f '.perldb') {
  561. X    do './.perldb';
  562. X}
  563. Xelsif (-f "$ENV{'LOGDIR'}/.perldb") {
  564. X    do "$ENV{'LOGDIR'}/.perldb";
  565. X}
  566. Xelsif (-f "$ENV{'HOME'}/.perldb") {
  567. X    do "$ENV{'HOME'}/.perldb";
  568. X}
  569. X
  570. X1;
  571. !STUFFY!FUNK!
  572. echo Extracting hash.c
  573. sed >hash.c <<'!STUFFY!FUNK!' -e 's/X//'
  574. X/* $Header: hash.c,v 4.0 91/03/20 01:22:26 lwall Locked $
  575. X *
  576. X *    Copyright (c) 1989, Larry Wall
  577. X *
  578. X *    You may distribute under the terms of the GNU General Public License
  579. X *    as specified in the README file that comes with the perl 3.0 kit.
  580. X *
  581. X * $Log:    hash.c,v $
  582. X * Revision 4.0  91/03/20  01:22:26  lwall
  583. X * 4.0 baseline.
  584. X * 
  585. X */
  586. X
  587. X#include "EXTERN.h"
  588. X#include "perl.h"
  589. X
  590. Xstatic char coeff[] = {
  591. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  592. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  593. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  594. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  595. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  596. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  597. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1,
  598. X        61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1};
  599. X
  600. Xstatic void hfreeentries();
  601. X
  602. XSTR *
  603. Xhfetch(tb,key,klen,lval)
  604. Xregister HASH *tb;
  605. Xchar *key;
  606. Xunsigned int klen;
  607. Xint lval;
  608. X{
  609. X    register char *s;
  610. X    register int i;
  611. X    register int hash;
  612. X    register HENT *entry;
  613. X    register int maxi;
  614. X    STR *str;
  615. X#ifdef SOME_DBM
  616. X    datum dkey,dcontent;
  617. X#endif
  618. X
  619. X    if (!tb)
  620. X    return &str_undef;
  621. X    if (!tb->tbl_array) {
  622. X    if (lval)
  623. X        Newz(503,tb->tbl_array, tb->tbl_max + 1, HENT*);
  624. X    else
  625. X        return &str_undef;
  626. X    }
  627. X
  628. X    /* The hash function we use on symbols has to be equal to the first
  629. X     * character when taken modulo 128, so that str_reset() can be implemented
  630. X     * efficiently.  We throw in the second character and the last character
  631. X     * (times 128) so that long chains of identifiers starting with the
  632. X     * same letter don't have to be strEQ'ed within hfetch(), since it
  633. X     * compares hash values before trying strEQ().
  634. X     */
  635. X    if (!tb->tbl_coeffsize)
  636. X    hash = *key + 128 * key[1] + 128 * key[klen-1];    /* assuming klen > 0 */
  637. X    else {    /* use normal coefficients */
  638. X    if (klen < tb->tbl_coeffsize)
  639. X        maxi = klen;
  640. X    else
  641. X        maxi = tb->tbl_coeffsize;
  642. X    for (s=key,        i=0,    hash = 0;
  643. X                i < maxi;
  644. X         s++,        i++,    hash *= 5) {
  645. X        hash += *s * coeff[i];
  646. X    }
  647. X    }
  648. X
  649. X    entry = tb->tbl_array[hash & tb->tbl_max];
  650. X    for (; entry; entry = entry->hent_next) {
  651. X    if (entry->hent_hash != hash)        /* strings can't be equal */
  652. X        continue;
  653. X    if (entry->hent_klen != klen)
  654. X        continue;
  655. X    if (bcmp(entry->hent_key,key,klen))    /* is this it? */
  656. X        continue;
  657. X    return entry->hent_val;
  658. X    }
  659. X#ifdef SOME_DBM
  660. X    if (tb->tbl_dbm) {
  661. X    dkey.dptr = key;
  662. X    dkey.dsize = klen;
  663. X#ifdef HAS_GDBM
  664. X    dcontent = gdbm_fetch(tb->tbl_dbm,dkey);
  665. X#else
  666. X    dcontent = dbm_fetch(tb->tbl_dbm,dkey);
  667. X#endif
  668. X    if (dcontent.dptr) {            /* found one */
  669. X        str = Str_new(60,dcontent.dsize);
  670. X        str_nset(str,dcontent.dptr,dcontent.dsize);
  671. X        hstore(tb,key,klen,str,hash);        /* cache it */
  672. X        return str;
  673. X    }
  674. X    }
  675. X#endif
  676. X    if (lval) {        /* gonna assign to this, so it better be there */
  677. X    str = Str_new(61,0);
  678. X    hstore(tb,key,klen,str,hash);
  679. X    return str;
  680. X    }
  681. X    return &str_undef;
  682. X}
  683. X
  684. Xbool
  685. Xhstore(tb,key,klen,val,hash)
  686. Xregister HASH *tb;
  687. Xchar *key;
  688. Xunsigned int klen;
  689. XSTR *val;
  690. Xregister int hash;
  691. X{
  692. X    register char *s;
  693. X    register int i;
  694. X    register HENT *entry;
  695. X    register HENT **oentry;
  696. X    register int maxi;
  697. X
  698. X    if (!tb)
  699. X    return FALSE;
  700. X
  701. X    if (hash)
  702. X    ;
  703. X    else if (!tb->tbl_coeffsize)
  704. X    hash = *key + 128 * key[1] + 128 * key[klen-1];
  705. X    else {    /* use normal coefficients */
  706. X    if (klen < tb->tbl_coeffsize)
  707. X        maxi = klen;
  708. X    else
  709. X        maxi = tb->tbl_coeffsize;
  710. X    for (s=key,        i=0,    hash = 0;
  711. X                i < maxi;
  712. X         s++,        i++,    hash *= 5) {
  713. X        hash += *s * coeff[i];
  714. X    }
  715. X    }
  716. X
  717. X    if (!tb->tbl_array)
  718. X    Newz(505,tb->tbl_array, tb->tbl_max + 1, HENT*);
  719. X
  720. X    oentry = &(tb->tbl_array[hash & tb->tbl_max]);
  721. X    i = 1;
  722. X
  723. X    for (entry = *oentry; entry; i=0, entry = entry->hent_next) {
  724. X    if (entry->hent_hash != hash)        /* strings can't be equal */
  725. X        continue;
  726. X    if (entry->hent_klen != klen)
  727. X        continue;
  728. X    if (bcmp(entry->hent_key,key,klen))    /* is this it? */
  729. X        continue;
  730. X    Safefree(entry->hent_val);
  731. X    entry->hent_val = val;
  732. X    return TRUE;
  733. X    }
  734. X    New(501,entry, 1, HENT);
  735. X
  736. X    entry->hent_klen = klen;
  737. X    entry->hent_key = nsavestr(key,klen);
  738. X    entry->hent_val = val;
  739. X    entry->hent_hash = hash;
  740. X    entry->hent_next = *oentry;
  741. X    *oentry = entry;
  742. X
  743. X    /* hdbmstore not necessary here because it's called from stabset() */
  744. X
  745. X    if (i) {                /* initial entry? */
  746. X    tb->tbl_fill++;
  747. X#ifdef SOME_DBM
  748. X    if (tb->tbl_dbm && tb->tbl_max >= DBM_CACHE_MAX)
  749. X        return FALSE;
  750. X#endif
  751. X    if (tb->tbl_fill > tb->tbl_dosplit)
  752. X        hsplit(tb);
  753. X    }
  754. X#ifdef SOME_DBM
  755. X    else if (tb->tbl_dbm) {        /* is this just a cache for dbm file? */
  756. X    void hentdelayfree();
  757. X
  758. X    entry = tb->tbl_array[hash & tb->tbl_max];
  759. X    oentry = &entry->hent_next;
  760. X    entry = *oentry;
  761. X    while (entry) {    /* trim chain down to 1 entry */
  762. X        *oentry = entry->hent_next;
  763. X        hentdelayfree(entry);    /* no doubt they'll want this next. */
  764. X        entry = *oentry;
  765. X    }
  766. X    }
  767. X#endif
  768. X
  769. X    return FALSE;
  770. X}
  771. X
  772. XSTR *
  773. Xhdelete(tb,key,klen)
  774. Xregister HASH *tb;
  775. Xchar *key;
  776. Xunsigned int klen;
  777. X{
  778. X    register char *s;
  779. X    register int i;
  780. X    register int hash;
  781. X    register HENT *entry;
  782. X    register HENT **oentry;
  783. X    STR *str;
  784. X    int maxi;
  785. X#ifdef SOME_DBM
  786. X    datum dkey;
  787. X#endif
  788. X
  789. X    if (!tb || !tb->tbl_array)
  790. X    return Nullstr;
  791. X    if (!tb->tbl_coeffsize)
  792. X    hash = *key + 128 * key[1] + 128 * key[klen-1];
  793. X    else {    /* use normal coefficients */
  794. X    if (klen < tb->tbl_coeffsize)
  795. X        maxi = klen;
  796. X    else
  797. X        maxi = tb->tbl_coeffsize;
  798. X    for (s=key,        i=0,    hash = 0;
  799. X                i < maxi;
  800. X         s++,        i++,    hash *= 5) {
  801. X        hash += *s * coeff[i];
  802. X    }
  803. X    }
  804. X
  805. X    oentry = &(tb->tbl_array[hash & tb->tbl_max]);
  806. X    entry = *oentry;
  807. X    i = 1;
  808. X    for (; entry; i=0, oentry = &entry->hent_next, entry = *oentry) {
  809. X    if (entry->hent_hash != hash)        /* strings can't be equal */
  810. X        continue;
  811. X    if (entry->hent_klen != klen)
  812. X        continue;
  813. X    if (bcmp(entry->hent_key,key,klen))    /* is this it? */
  814. X        continue;
  815. X    *oentry = entry->hent_next;
  816. X    str = str_mortal(entry->hent_val);
  817. X    hentfree(entry);
  818. X    if (i)
  819. X        tb->tbl_fill--;
  820. X#ifdef SOME_DBM
  821. X      do_dbm_delete:
  822. X    if (tb->tbl_dbm) {
  823. X        dkey.dptr = key;
  824. X        dkey.dsize = klen;
  825. X#ifdef HAS_GDBM
  826. X        gdbm_delete(tb->tbl_dbm,dkey);
  827. X#else
  828. X        dbm_delete(tb->tbl_dbm,dkey);
  829. X#endif
  830. X    }
  831. X#endif
  832. X    return str;
  833. X    }
  834. X#ifdef SOME_DBM
  835. X    str = Nullstr;
  836. X    goto do_dbm_delete;
  837. X#else
  838. X    return Nullstr;
  839. X#endif
  840. X}
  841. X
  842. Xhsplit(tb)
  843. XHASH *tb;
  844. X{
  845. X    int oldsize = tb->tbl_max + 1;
  846. X    register int newsize = oldsize * 2;
  847. X    register int i;
  848. X    register HENT **a;
  849. X    register HENT **b;
  850. X    register HENT *entry;
  851. X    register HENT **oentry;
  852. X
  853. X    a = tb->tbl_array;
  854. X    Renew(a, newsize, HENT*);
  855. X    Zero(&a[oldsize], oldsize, HENT*);        /* zero 2nd half*/
  856. X    tb->tbl_max = --newsize;
  857. X    tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
  858. X    tb->tbl_array = a;
  859. X
  860. X    for (i=0; i<oldsize; i++,a++) {
  861. X    if (!*a)                /* non-existent */
  862. X        continue;
  863. X    b = a+oldsize;
  864. X    for (oentry = a, entry = *a; entry; entry = *oentry) {
  865. X        if ((entry->hent_hash & newsize) != i) {
  866. X        *oentry = entry->hent_next;
  867. X        entry->hent_next = *b;
  868. X        if (!*b)
  869. X            tb->tbl_fill++;
  870. X        *b = entry;
  871. X        continue;
  872. X        }
  873. X        else
  874. X        oentry = &entry->hent_next;
  875. X    }
  876. X    if (!*a)                /* everything moved */
  877. X        tb->tbl_fill--;
  878. X    }
  879. X}
  880. X
  881. XHASH *
  882. Xhnew(lookat)
  883. Xunsigned int lookat;
  884. X{
  885. X    register HASH *tb;
  886. X
  887. X    Newz(502,tb, 1, HASH);
  888. X    if (lookat) {
  889. X    tb->tbl_coeffsize = lookat;
  890. X    tb->tbl_max = 7;        /* it's a normal associative array */
  891. X    tb->tbl_dosplit = tb->tbl_max * FILLPCT / 100;
  892. X    }
  893. X    else {
  894. X    tb->tbl_max = 127;        /* it's a symbol table */
  895. X    tb->tbl_dosplit = 128;        /* so never split */
  896. X    }
  897. X    tb->tbl_fill = 0;
  898. X#ifdef SOME_DBM
  899. X    tb->tbl_dbm = 0;
  900. X#endif
  901. X    (void)hiterinit(tb);    /* so each() will start off right */
  902. X    return tb;
  903. X}
  904. X
  905. Xvoid
  906. Xhentfree(hent)
  907. Xregister HENT *hent;
  908. X{
  909. X    if (!hent)
  910. X    return;
  911. X    str_free(hent->hent_val);
  912. X    Safefree(hent->hent_key);
  913. X    Safefree(hent);
  914. X}
  915. X
  916. Xvoid
  917. Xhentdelayfree(hent)
  918. Xregister HENT *hent;
  919. X{
  920. X    if (!hent)
  921. X    return;
  922. X    str_2mortal(hent->hent_val);    /* free between statements */
  923. X    Safefree(hent->hent_key);
  924. X    Safefree(hent);
  925. X}
  926. X
  927. Xvoid
  928. Xhclear(tb,dodbm)
  929. Xregister HASH *tb;
  930. Xint dodbm;
  931. X{
  932. X    if (!tb)
  933. X    return;
  934. X    hfreeentries(tb,dodbm);
  935. X    tb->tbl_fill = 0;
  936. X#ifndef lint
  937. X    if (tb->tbl_array)
  938. X    (void)bzero((char*)tb->tbl_array, (tb->tbl_max + 1) * sizeof(HENT*));
  939. X#endif
  940. X}
  941. X
  942. Xstatic void
  943. Xhfreeentries(tb,dodbm)
  944. Xregister HASH *tb;
  945. Xint dodbm;
  946. X{
  947. X    register HENT *hent;
  948. X    register HENT *ohent = Null(HENT*);
  949. X#ifdef SOME_DBM
  950. X    datum dkey;
  951. X    datum nextdkey;
  952. X#ifdef HAS_GDBM
  953. X    GDBM_FILE old_dbm;
  954. X#else
  955. X#ifdef HAS_NDBM
  956. X    DBM *old_dbm;
  957. X#else
  958. X    int old_dbm;
  959. X#endif
  960. X#endif
  961. X#endif
  962. X
  963. X    if (!tb || !tb->tbl_array)
  964. X    return;
  965. X#ifdef SOME_DBM
  966. X    if ((old_dbm = tb->tbl_dbm) && dodbm) {
  967. X#ifdef HAS_GDBM
  968. X    while (dkey = gdbm_firstkey(tb->tbl_dbm), dkey.dptr) {
  969. X#else
  970. X    while (dkey = dbm_firstkey(tb->tbl_dbm), dkey.dptr) {
  971. X#endif
  972. X        do {
  973. X#ifdef HAS_GDBM
  974. X        nextdkey = gdbm_nextkey(tb->tbl_dbm, dkey);
  975. X#else
  976. X#ifdef HAS_NDBM
  977. X#ifdef _CX_UX
  978. X        nextdkey = dbm_nextkey(tb->tbl_dbm, dkey);
  979. X#else
  980. X        nextdkey = dbm_nextkey(tb->tbl_dbm);
  981. X#endif
  982. X#else
  983. X        nextdkey = nextkey(dkey);
  984. X#endif
  985. X#endif
  986. X#ifdef HAS_GDBM
  987. X        gdbm_delete(tb->tbl_dbm,dkey);
  988. X#else
  989. X        dbm_delete(tb->tbl_dbm,dkey);
  990. X#endif
  991. X        dkey = nextdkey;
  992. X        } while (dkey.dptr);    /* one way or another, this works */
  993. X    }
  994. X    }
  995. X    tb->tbl_dbm = 0;            /* now clear just cache */
  996. X#endif
  997. X    (void)hiterinit(tb);
  998. X    while (hent = hiternext(tb)) {    /* concise but not very efficient */
  999. X    hentfree(ohent);
  1000. X    ohent = hent;
  1001. X    }
  1002. X    hentfree(ohent);
  1003. X#ifdef SOME_DBM
  1004. X    tb->tbl_dbm = old_dbm;
  1005. X#endif
  1006. X}
  1007. X
  1008. Xvoid
  1009. Xhfree(tb,dodbm)
  1010. Xregister HASH *tb;
  1011. Xint dodbm;
  1012. X{
  1013. X    if (!tb)
  1014. X    return;
  1015. X    hfreeentries(tb,dodbm);
  1016. X    Safefree(tb->tbl_array);
  1017. X    Safefree(tb);
  1018. X}
  1019. X
  1020. Xint
  1021. Xhiterinit(tb)
  1022. Xregister HASH *tb;
  1023. X{
  1024. X    tb->tbl_riter = -1;
  1025. X    tb->tbl_eiter = Null(HENT*);
  1026. X    return tb->tbl_fill;
  1027. X}
  1028. X
  1029. XHENT *
  1030. Xhiternext(tb)
  1031. Xregister HASH *tb;
  1032. X{
  1033. X    register HENT *entry;
  1034. X#ifdef SOME_DBM
  1035. X    datum key;
  1036. X#endif
  1037. X
  1038. X    entry = tb->tbl_eiter;
  1039. X#ifdef SOME_DBM
  1040. X    if (tb->tbl_dbm) {
  1041. X    if (entry) {
  1042. X#ifdef HAS_GDBM
  1043. X        key.dptr = entry->hent_key;
  1044. X        key.dsize = entry->hent_klen;
  1045. X        key = gdbm_nextkey(tb->tbl_dbm, key);
  1046. X#else
  1047. X#ifdef HAS_NDBM
  1048. X#ifdef _CX_UX
  1049. X        key.dptr = entry->hent_key;
  1050. X        key.dsize = entry->hent_klen;
  1051. X        key = dbm_nextkey(tb->tbl_dbm, key);
  1052. X#else
  1053. X        key = dbm_nextkey(tb->tbl_dbm);
  1054. X#endif /* _CX_UX */
  1055. X#else
  1056. X        key.dptr = entry->hent_key;
  1057. X        key.dsize = entry->hent_klen;
  1058. X        key = nextkey(key);
  1059. X#endif
  1060. X#endif
  1061. X    }
  1062. X    else {
  1063. X        Newz(504,entry, 1, HENT);
  1064. X        tb->tbl_eiter = entry;
  1065. X#ifdef HAS_GDBM
  1066. X        key = gdbm_firstkey(tb->tbl_dbm);
  1067. X#else
  1068. X        key = dbm_firstkey(tb->tbl_dbm);
  1069. X#endif
  1070. X    }
  1071. X    entry->hent_key = key.dptr;
  1072. X    entry->hent_klen = key.dsize;
  1073. X    if (!key.dptr) {
  1074. X        if (entry->hent_val)
  1075. X        str_free(entry->hent_val);
  1076. X        Safefree(entry);
  1077. X        tb->tbl_eiter = Null(HENT*);
  1078. X        return Null(HENT*);
  1079. X    }
  1080. X    return entry;
  1081. X    }
  1082. X#endif
  1083. X    if (!tb->tbl_array)
  1084. X    Newz(506,tb->tbl_array, tb->tbl_max + 1, HENT*);
  1085. X    do {
  1086. X    if (entry)
  1087. X        entry = entry->hent_next;
  1088. X    if (!entry) {
  1089. X        tb->tbl_riter++;
  1090. X        if (tb->tbl_riter > tb->tbl_max) {
  1091. X        tb->tbl_riter = -1;
  1092. X        break;
  1093. X        }
  1094. X        entry = tb->tbl_array[tb->tbl_riter];
  1095. X    }
  1096. X    } while (!entry);
  1097. X
  1098. X    tb->tbl_eiter = entry;
  1099. X    return entry;
  1100. X}
  1101. X
  1102. Xchar *
  1103. Xhiterkey(entry,retlen)
  1104. Xregister HENT *entry;
  1105. Xint *retlen;
  1106. X{
  1107. X    *retlen = entry->hent_klen;
  1108. X    return entry->hent_key;
  1109. X}
  1110. X
  1111. XSTR *
  1112. Xhiterval(tb,entry)
  1113. Xregister HASH *tb;
  1114. Xregister HENT *entry;
  1115. X{
  1116. X#ifdef SOME_DBM
  1117. X    datum key, content;
  1118. X
  1119. X    if (tb->tbl_dbm) {
  1120. X    key.dptr = entry->hent_key;
  1121. X    key.dsize = entry->hent_klen;
  1122. X#ifdef HAS_GDBM
  1123. X    content = gdbm_fetch(tb->tbl_dbm,key);
  1124. X#else
  1125. X    content = dbm_fetch(tb->tbl_dbm,key);
  1126. X#endif
  1127. X    if (!entry->hent_val)
  1128. X        entry->hent_val = Str_new(62,0);
  1129. X    str_nset(entry->hent_val,content.dptr,content.dsize);
  1130. X    }
  1131. X#endif
  1132. X    return entry->hent_val;
  1133. X}
  1134. X
  1135. X#ifdef SOME_DBM
  1136. X
  1137. X#ifndef O_CREAT
  1138. X#  ifdef I_FCNTL
  1139. X#    include <fcntl.h>
  1140. X#  endif
  1141. X#  ifdef I_SYS_FILE
  1142. X#    include <sys/file.h>
  1143. X#  endif
  1144. X#endif
  1145. X
  1146. X#ifndef O_RDONLY
  1147. X#define O_RDONLY 0
  1148. X#endif
  1149. X#ifndef O_RDWR
  1150. X#define O_RDWR 2
  1151. X#endif
  1152. X#ifndef O_CREAT
  1153. X#define O_CREAT 01000
  1154. X#endif
  1155. X
  1156. X#ifdef HAS_ODBM
  1157. Xstatic int dbmrefcnt = 0;
  1158. X#endif
  1159. X
  1160. Xbool
  1161. Xhdbmopen(tb,fname,mode)
  1162. Xregister HASH *tb;
  1163. Xchar *fname;
  1164. Xint mode;
  1165. X{
  1166. X    if (!tb)
  1167. X    return FALSE;
  1168. X#ifdef HAS_ODBM
  1169. X    if (tb->tbl_dbm)    /* never really closed it */
  1170. X    return TRUE;
  1171. X#endif
  1172. X    if (tb->tbl_dbm) {
  1173. X    hdbmclose(tb);
  1174. X    tb->tbl_dbm = 0;
  1175. X    }
  1176. X    hclear(tb, FALSE);    /* clear cache */
  1177. X#ifdef HAS_GDBM
  1178. X    if (mode >= 0)
  1179. X    tb->tbl_dbm = gdbm_open(fname, 0, GDBM_WRCREAT,mode, (void *) NULL);
  1180. X    if (!tb->tbl_dbm)
  1181. X    tb->tbl_dbm = gdbm_open(fname, 0, GDBM_WRITER, mode, (void *) NULL);
  1182. X    if (!tb->tbl_dbm)
  1183. X    tb->tbl_dbm = gdbm_open(fname, 0, GDBM_READER, mode, (void *) NULL);
  1184. X#else
  1185. X#ifdef HAS_NDBM
  1186. X    if (mode >= 0)
  1187. X    tb->tbl_dbm = dbm_open(fname, O_RDWR|O_CREAT, mode);
  1188. X    if (!tb->tbl_dbm)
  1189. X    tb->tbl_dbm = dbm_open(fname, O_RDWR, mode);
  1190. X    if (!tb->tbl_dbm)
  1191. X    tb->tbl_dbm = dbm_open(fname, O_RDONLY, mode);
  1192. X#else
  1193. X    if (dbmrefcnt++)
  1194. X    fatal("Old dbm can only open one database");
  1195. X    sprintf(buf,"%s.dir",fname);
  1196. X    if (stat(buf, &statbuf) < 0) {
  1197. X    if (mode < 0 || close(creat(buf,mode)) < 0)
  1198. X        return FALSE;
  1199. X    sprintf(buf,"%s.pag",fname);
  1200. X    if (close(creat(buf,mode)) < 0)
  1201. X        return FALSE;
  1202. X    }
  1203. X    tb->tbl_dbm = dbminit(fname) >= 0;
  1204. X#endif
  1205. X#endif
  1206. X    if (!tb->tbl_array && tb->tbl_dbm != 0)
  1207. X    Newz(507,tb->tbl_array, tb->tbl_max + 1, HENT*);
  1208. X    return tb->tbl_dbm != 0;
  1209. X}
  1210. X
  1211. Xvoid
  1212. Xhdbmclose(tb)
  1213. Xregister HASH *tb;
  1214. X{
  1215. X    if (tb && tb->tbl_dbm) {
  1216. X#ifdef HAS_GDBM
  1217. X    gdbm_close(tb->tbl_dbm);
  1218. X    tb->tbl_dbm = 0;
  1219. X#else
  1220. X#ifdef HAS_NDBM
  1221. X    dbm_close(tb->tbl_dbm);
  1222. X    tb->tbl_dbm = 0;
  1223. X#else
  1224. X    /* dbmrefcnt--;  */    /* doesn't work, rats */
  1225. X#endif
  1226. X#endif
  1227. X    }
  1228. X    else if (dowarn)
  1229. X    warn("Close on unopened dbm file");
  1230. X}
  1231. X
  1232. Xbool
  1233. Xhdbmstore(tb,key,klen,str)
  1234. Xregister HASH *tb;
  1235. Xchar *key;
  1236. Xunsigned int klen;
  1237. Xregister STR *str;
  1238. X{
  1239. X    datum dkey, dcontent;
  1240. X    int error;
  1241. X
  1242. X    if (!tb || !tb->tbl_dbm)
  1243. X    return FALSE;
  1244. X    dkey.dptr = key;
  1245. X    dkey.dsize = klen;
  1246. X    dcontent.dptr = str_get(str);
  1247. X    dcontent.dsize = str->str_cur;
  1248. X#ifdef HAS_GDBM
  1249. X    error = gdbm_store(tb->tbl_dbm, dkey, dcontent, GDBM_REPLACE);
  1250. X#else
  1251. X    error = dbm_store(tb->tbl_dbm, dkey, dcontent, DBM_REPLACE);
  1252. X#endif
  1253. X    if (error) {
  1254. X    if (errno == EPERM)
  1255. X        fatal("No write permission to dbm file");
  1256. X    warn("dbm store returned %d, errno %d, key \"%s\"",error,errno,key);
  1257. X#ifdef HAS_NDBM
  1258. X        dbm_clearerr(tb->tbl_dbm);
  1259. X#endif
  1260. X    }
  1261. X    return !error;
  1262. X}
  1263. X#endif /* SOME_DBM */
  1264. !STUFFY!FUNK!
  1265. echo Extracting x2p/find2perl.SH
  1266. sed >x2p/find2perl.SH <<'!STUFFY!FUNK!' -e 's/X//'
  1267. Xcase $CONFIG in
  1268. X'')
  1269. X    if test ! -f config.sh; then
  1270. X    ln ../config.sh . || \
  1271. X    ln ../../config.sh . || \
  1272. X    ln ../../../config.sh . || \
  1273. X    (echo "Can't find config.sh."; exit 1)
  1274. X    fi
  1275. X    . config.sh
  1276. X    ;;
  1277. Xesac
  1278. X: This forces SH files to create target in same directory as SH file.
  1279. X: This is so that make depend always knows where to find SH derivatives.
  1280. Xcase "$0" in
  1281. X*/*) cd `expr X$0 : 'X\(.*\)/'` ;;
  1282. Xesac
  1283. Xecho "Extracting find2perl (with variable substitutions)"
  1284. X: This section of the file will have variable substitutions done on it.
  1285. X: Move anything that needs config subs from !NO!SUBS! section to !GROK!THIS!.
  1286. X: Protect any dollar signs and backticks that you do not want interpreted
  1287. X: by putting a backslash in front.  You may delete these comments.
  1288. X$spitshell >find2perl <<!GROK!THIS!
  1289. X#!$bin/perl
  1290. X
  1291. X\$bin = "$bin";
  1292. X
  1293. X!GROK!THIS!
  1294. X
  1295. X: In the following dollars and backticks do not need the extra backslash.
  1296. X$spitshell >>find2perl <<'!NO!SUBS!'
  1297. X
  1298. Xwhile ($ARGV[0] =~ /^[^-!(]/) {
  1299. X    push(@roots, shift);
  1300. X}
  1301. X@roots = ('.') unless @roots;
  1302. Xfor (@roots) { $_ = "e($_); }
  1303. X$roots = join(',', @roots);
  1304. X
  1305. X$indent = 1;
  1306. X
  1307. Xwhile (@ARGV) {
  1308. X    $_ = shift;
  1309. X    s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
  1310. X    if ($_ eq '(') {
  1311. X    $out .= &tab . "(\n";
  1312. X    $indent++;
  1313. X    next;
  1314. X    }
  1315. X    elsif ($_ eq ')') {
  1316. X    $indent--;
  1317. X    $out .= &tab . ")";
  1318. X    }
  1319. X    elsif ($_ eq '!') {
  1320. X    $out .= &tab . "!";
  1321. X    next;
  1322. X    }
  1323. X    elsif ($_ eq 'name') {
  1324. X    $out .= &tab;
  1325. X    $pat = &fileglob_to_re(shift);
  1326. X    $out .= '/' . $pat . "/";
  1327. X    }
  1328. X    elsif ($_ eq 'perm') {
  1329. X    $onum = shift;
  1330. X    die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
  1331. X    if ($onum =~ s/^-//) {
  1332. X        $onum = '0' . sprintf("%o", oct($onum) & 017777);    # s/b 07777 ?
  1333. X        $out .= &tab . "(\$mode & $onum) == $onum";
  1334. X    }
  1335. X    else {
  1336. X        $onum = '0' . $onum unless $onum =~ /^0/;
  1337. X        $out .= &tab . "(\$mode & 0777) == $onum";
  1338. X    }
  1339. X    }
  1340. X    elsif ($_ eq 'type') {
  1341. X    ($filetest = shift) =~ tr/s/S/;
  1342. X    $out .= &tab . "-$filetest _";
  1343. X    }
  1344. X    elsif ($_ eq 'print') {
  1345. X    $out .= &tab . 'print("$name\n")';
  1346. X    }
  1347. X    elsif ($_ eq 'print0') {
  1348. X    $out .= &tab . 'print("$name\0")';
  1349. X    }
  1350. X    elsif ($_ eq 'fstype') {
  1351. X    $out .= &tab;
  1352. X    $type = shift;
  1353. X    if ($type eq 'nfs')
  1354. X        { $out .= '$dev < 0'; }
  1355. X    else
  1356. X        { $out .= '$dev >= 0'; }
  1357. X    }
  1358. X    elsif ($_ eq 'user') {
  1359. X    $uname = shift;
  1360. X    $out .= &tab . "\$uid == \$uid{'$uname'}";
  1361. X    $inituser++;
  1362. X    }
  1363. X    elsif ($_ eq 'group') {
  1364. X    $gname = shift;
  1365. X    $out .= &tab . "\$gid == \$gid('$gname')";
  1366. X    $initgroup++;
  1367. X    }
  1368. X    elsif ($_ eq 'nouser') {
  1369. X    $out .= &tab . '!defined $uid{$uid}';
  1370. X    $inituser++;
  1371. X    }
  1372. X    elsif ($_ eq 'nogroup') {
  1373. X    $out .= &tab . '!defined $gid{$gid}';
  1374. X    $initgroup++;
  1375. X    }
  1376. X    elsif ($_ eq 'links') {
  1377. X    $out .= &tab . '$nlink ' . &n(shift);
  1378. X    }
  1379. X    elsif ($_ eq 'inum') {
  1380. X    $out .= &tab . '$ino ' . &n(shift);
  1381. X    }
  1382. X    elsif ($_ eq 'size') {
  1383. X    $out .= &tab . 'int((-s _ + 511) / 512) ' . &n(shift);
  1384. X    }
  1385. X    elsif ($_ eq 'atime') {
  1386. X    $out .= &tab . 'int(-A _) ' . &n(shift);
  1387. X    }
  1388. X    elsif ($_ eq 'mtime') {
  1389. X    $out .= &tab . 'int(-M _) ' . &n(shift);
  1390. X    }
  1391. X    elsif ($_ eq 'ctime') {
  1392. X    $out .= &tab . 'int(-C _) ' . &n(shift);
  1393. X    }
  1394. X    elsif ($_ eq 'exec') {
  1395. X    for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
  1396. X    shift;
  1397. X    for (@cmd) { s/'/\\'/g; }
  1398. X    $" = "','";
  1399. X    $out .= &tab . "&exec(0, '@cmd')";
  1400. X    $" = ' ';
  1401. X    $initexec++;
  1402. X    }
  1403. X    elsif ($_ eq 'ok') {
  1404. X    for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
  1405. X    shift;
  1406. X    for (@cmd) { s/'/\\'/g; }
  1407. X    $" = "','";
  1408. X    $out .= &tab . "&exec(1, '@cmd')";
  1409. X    $" = ' ';
  1410. X    $initexec++;
  1411. X    }
  1412. X    elsif ($_ eq 'prune') {
  1413. X    $out .= &tab . '($prune = 1)';
  1414. X    }
  1415. X    elsif ($_ eq 'xdev') {
  1416. X    $out .= &tab . '(($prune |= ($dev != $topdev)),1)';
  1417. X    }
  1418. X    elsif ($_ eq 'newer') {
  1419. X    $out .= &tab;
  1420. X    $file = shift;
  1421. X    $newername = 'AGE_OF' . $file;
  1422. X    $newername =~ s/[^\w]/_/g;
  1423. X    $newername = '$' . $newername;
  1424. X    $out .= "-M _ < $newername";
  1425. X    $initnewer .= "$newername = -M " . "e($file) . ";\n";
  1426. X    }
  1427. X    elsif ($_ eq 'eval') {
  1428. X    $prog = "e(shift);
  1429. X    $out .= &tab . "eval $prog";
  1430. X    }
  1431. X    elsif ($_ eq 'depth') {
  1432. X    $depth++;
  1433. X    next;
  1434. X    }
  1435. X    elsif ($_ eq 'ls') {
  1436. X    $out .= &tab . "&ls";
  1437. X    $initls++;
  1438. X    }
  1439. X    elsif ($_ eq 'tar') {
  1440. X    $out .= &tab;
  1441. X    die "-tar must have a filename argument\n" unless @ARGV;
  1442. X    $file = shift;
  1443. X    $fh = 'FH' . $file;
  1444. X    $fh =~ s/[^\w]/_/g;
  1445. X    $out .= "&tar($fh)";
  1446. X    $file = '>' . $file;
  1447. X    $initfile .= "open($fh, " . "e($file) .
  1448. X      qq{) || die "Can't open $fh: \$!\\n";\n};
  1449. X    $inittar++;
  1450. X    $flushall = "\n&tflushall;\n";
  1451. X    }
  1452. X    elsif (/^n?cpio$/) {
  1453. X    $depth++;
  1454. X    $out .= &tab;
  1455. X    die "-$_ must have a filename argument\n" unless @ARGV;
  1456. X    $file = shift;
  1457. X    $fh = 'FH' . $file;
  1458. X    $fh =~ s/[^\w]/_/g;
  1459. X    $out .= "&cpio('" . substr($_,0,1) . "', $fh)";
  1460. X    $file = '>' . $file;
  1461. X    $initfile .= "open($fh, " . "e($file) .
  1462. X      qq{) || die "Can't open $fh: \$!\\n";\n};
  1463. X    $initcpio++;
  1464. X    $flushall = "\n&flushall;\n";
  1465. X    }
  1466. X    else {
  1467. X    die "Unrecognized switch: -$_\n";
  1468. X    }
  1469. X    if (@ARGV) {
  1470. X    if ($ARGV[0] eq '-o') {
  1471. X        $statdone = 0 if $indent == 1 && $delayedstat;
  1472. X        $saw_or++;
  1473. X        $out .= "\n" . &tab . "||\n";
  1474. X        shift;
  1475. X    }
  1476. X    else {
  1477. X        $out .= " &&" unless $ARGV[0] eq ')';
  1478. X        $out .= "\n";
  1479. X        shift if $ARGV[0] eq '-a';
  1480. X    }
  1481. X    }
  1482. X}
  1483. X
  1484. Xprint <<"END";
  1485. X#!$bin/perl
  1486. X
  1487. XEND
  1488. X
  1489. Xif ($initls) {
  1490. X    print <<'END';
  1491. X@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
  1492. X@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
  1493. X
  1494. XEND
  1495. X}
  1496. X
  1497. Xif ($inituser || $initls) {
  1498. X    print 'while (($name, $pw, $uid) = getpwent) {', "\n";
  1499. X    print '    $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
  1500. X    print '    $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
  1501. X    print "}\n\n";
  1502. X}
  1503. X
  1504. Xif ($initgroup || $initls) {
  1505. X    print 'while (($name, $pw, $gid) = getgrent) {', "\n";
  1506. X    print '    $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
  1507. X    print '    $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
  1508. X    print "}\n\n";
  1509. X}
  1510. X
  1511. Xprint $initnewer, "\n" if $initnewer;
  1512. X
  1513. Xprint $initfile, "\n" if $initfile;
  1514. X
  1515. Xprint <<"END";
  1516. X# Traverse desired filesystems
  1517. X
  1518. X&dodirs($roots);
  1519. X$flushall
  1520. Xexit;
  1521. X
  1522. Xsub wanted {
  1523. X$out;
  1524. X}
  1525. X
  1526. XEND
  1527. X
  1528. Xprint <<'END';
  1529. Xsub dodirs {
  1530. X    chop($cwd = `pwd`);
  1531. X    foreach $topdir (@_) {
  1532. X    (($topdev,$topino,$topmode,$topnlink) = stat($topdir))
  1533. X      || (warn("Can't stat $topdir: $!\n"), next);
  1534. X    if (-d _) {
  1535. X        if (chdir($topdir)) {
  1536. XEND
  1537. Xif ($depth) {
  1538. X    print <<'END';
  1539. X        $topdir = '' if $topdir eq '/';
  1540. X        &dodir($topdir,$topnlink);
  1541. X        ($dir,$_) = ($topdir,'.');
  1542. X        $name = $topdir;
  1543. X        &wanted;
  1544. XEND
  1545. X}
  1546. Xelse {
  1547. X    print <<'END';
  1548. X        ($dir,$_) = ($topdir,'.');
  1549. X        $name = $topdir;
  1550. X        &wanted;
  1551. X        $topdir = '' if $topdir eq '/';
  1552. X        &dodir($topdir,$topnlink);
  1553. XEND
  1554. X}
  1555. Xprint <<'END';
  1556. X        }
  1557. X        else {
  1558. X        warn "Can't cd to $topdir: $!\n";
  1559. X        }
  1560. X    }
  1561. X    else {
  1562. X        unless (($dir,$_) = $topdir =~ m#^(.*/)(.*)$#) {
  1563. X        ($dir,$_) = ('.', $topdir);
  1564. X        }
  1565. X        chdir $dir && &wanted;
  1566. X    }
  1567. X    chdir $cwd;
  1568. X    }
  1569. X}
  1570. X
  1571. Xsub dodir {
  1572. X    local($dir,$nlink) = @_;
  1573. X    local($dev,$ino,$mode,$subcount);
  1574. X    local($name);
  1575. X
  1576. X    # Get the list of files in the current directory.
  1577. X
  1578. X    opendir(DIR,'.') || warn "Can't open $dir: $!\n";
  1579. X    local(@filenames) = readdir(DIR);
  1580. X    closedir(DIR);
  1581. X
  1582. X    if ($nlink == 2) {        # This dir has no subdirectories.
  1583. X    for (@filenames) {
  1584. X        next if $_ eq '.';
  1585. X        next if $_ eq '..';
  1586. X        $name = "$dir/$_";
  1587. X        $nlink = 0;
  1588. X        &wanted;
  1589. X    }
  1590. X    }
  1591. X    else {                    # This dir has subdirectories.
  1592. X    $subcount = $nlink - 2;
  1593. X    for (@filenames) {
  1594. X        next if $_ eq '.';
  1595. X        next if $_ eq '..';
  1596. X        $nlink = $prune = 0;
  1597. X        $name = "$dir/$_";
  1598. XEND
  1599. Xprint <<'END' unless $depth;
  1600. X        &wanted;
  1601. XEND
  1602. Xprint <<'END';
  1603. X        if ($subcount > 0) {    # Seen all the subdirs?
  1604. X
  1605. X        # Get link count and check for directoriness.
  1606. X
  1607. X        ($dev,$ino,$mode,$nlink) = lstat($_) unless $nlink;
  1608. X        
  1609. X        if (-d _) {
  1610. X
  1611. X            # It really is a directory, so do it recursively.
  1612. X
  1613. X            if (!$prune && chdir $_) {
  1614. X            &dodir($name,$nlink);
  1615. X            chdir '..';
  1616. X            }
  1617. X            --$subcount;
  1618. X        }
  1619. X        }
  1620. XEND
  1621. Xprint <<'END' if $depth;
  1622. X        &wanted;
  1623. XEND
  1624. Xprint <<'END';
  1625. X    }
  1626. X    }
  1627. X}
  1628. X
  1629. XEND
  1630. X
  1631. Xif ($initexec) {
  1632. X    print <<'END';
  1633. Xsub exec {
  1634. X    local($ok, @cmd) = @_;
  1635. X    foreach $word (@cmd) {
  1636. X    $word =~ s#{}#$name#g;
  1637. X    }
  1638. X    if ($ok) {
  1639. X    local($old) = select(STDOUT);
  1640. X    $| = 1;
  1641. X    print "@cmd";
  1642. X    select($old);
  1643. X    return 0 unless <STDIN> =~ /^y/;
  1644. X    }
  1645. X    chdir $cwd;        # sigh
  1646. X    system @cmd;
  1647. X    chdir $dir;
  1648. X    return !$?;
  1649. X}
  1650. X
  1651. XEND
  1652. X}
  1653. X
  1654. Xif ($initls) {
  1655. X    print <<'END';
  1656. Xsub ls {
  1657. X    ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
  1658. X      $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  1659. X
  1660. X    $pname = $name;
  1661. X
  1662. X    if (defined $blocks) {
  1663. X    $blocks = int(($blocks + 1) / 2);
  1664. X    }
  1665. X    else {
  1666. X    $blocks = int(($size + 1023) / 1024);
  1667. X    }
  1668. X
  1669. X    if    (-f _) { $perms = '-'; }
  1670. X    elsif (-d _) { $perms = 'd'; }
  1671. X    elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
  1672. X    elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
  1673. X    elsif (-p _) { $perms = 'p'; }
  1674. X    elsif (-S _) { $perms = 's'; }
  1675. X    else         { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
  1676. X
  1677. X    $tmpmode = $mode;
  1678. X    $tmp = $rwx[$tmpmode & 7];
  1679. X    $tmpmode >>= 3;
  1680. X    $tmp = $rwx[$tmpmode & 7] . $tmp;
  1681. X    $tmpmode >>= 3;
  1682. X    $tmp = $rwx[$tmpmode & 7] . $tmp;
  1683. X    substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
  1684. X    substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
  1685. X    substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
  1686. X    $perms .= $tmp;
  1687. X
  1688. X    $user = $user{$uid} || $uid;
  1689. X    $group = $group{$gid} || $gid;
  1690. X
  1691. X    ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
  1692. X    $moname = $moname[$mon];
  1693. X    if (-M _ > 365.25 / 2) {
  1694. X    $timeyear = '19' . $year;
  1695. X    }
  1696. X    else {
  1697. X    $timeyear = sprintf("%02d:%02d", $hour, $min);
  1698. X    }
  1699. X
  1700. X    printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
  1701. X        $ino,
  1702. X         $blocks,
  1703. X              $perms,
  1704. X                $nlink,
  1705. X                $user,
  1706. X                     $group,
  1707. X                      $sizemm,
  1708. X                          $moname,
  1709. X                         $mday,
  1710. X                             $timeyear,
  1711. X                             $pname;
  1712. X    1;
  1713. X}
  1714. X
  1715. Xsub sizemm {
  1716. X    sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
  1717. X}
  1718. X
  1719. XEND
  1720. X}
  1721. X
  1722. Xif ($initcpio) {
  1723. Xprint <<'END';
  1724. Xsub cpio {
  1725. X    local($nc,$fh) = @_;
  1726. X    local($text);
  1727. X
  1728. X    if ($name eq 'TRAILER!!!') {
  1729. X    $text = '';
  1730. X    $size = 0;
  1731. X    }
  1732. X    else {
  1733. X    ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  1734. X      $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  1735. X    if (-f _) {
  1736. X        open(IN, $_) || do {
  1737. X        warn "Couldn't open $name: $!\n";
  1738. X        return;
  1739. X        };
  1740. X    }
  1741. X    else {
  1742. X        $text = readlink($_);
  1743. X        $size = 0 unless defined $text;
  1744. X    }
  1745. X    }
  1746. X
  1747. X    ($nm = $name) =~ s#^\./##;
  1748. X    $nc{$fh} = $nc;
  1749. X    if ($nc eq 'n') {
  1750. X    $cpout{$fh} .=
  1751. X      sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
  1752. X        070707,
  1753. X        $dev & 0777777,
  1754. X        $ino & 0777777,
  1755. X        $mode & 0777777,
  1756. X        $uid & 0777777,
  1757. X        $gid & 0777777,
  1758. X        $nlink & 0777777,
  1759. X        $rdev & 0177777,
  1760. X        $mtime,
  1761. X        length($nm)+1,
  1762. X        $size,
  1763. X        $nm);
  1764. X    }
  1765. X    else {
  1766. X    $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
  1767. X    $cpout{$fh} .= pack("SSSSSSSSLSLa*",
  1768. X        070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
  1769. X        length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
  1770. X    }
  1771. X    if ($text ne '') {
  1772. X    $cpout{$fh} .= $text;
  1773. X    }
  1774. X    elsif ($size) {
  1775. X    &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
  1776. X    while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
  1777. X        &flush($fh);
  1778. X        $l = length($cpout{$fh});
  1779. X    }
  1780. X    }
  1781. X    close IN;
  1782. X}
  1783. X
  1784. Xsub flush {
  1785. X    local($fh) = @_;
  1786. X
  1787. X    while (length($cpout{$fh}) >= 5120) {
  1788. X    syswrite($fh,$cpout{$fh},5120);
  1789. X    ++$blocks{$fh};
  1790. X    substr($cpout{$fh}, 0, 5120) = '';
  1791. X    }
  1792. X}
  1793. X
  1794. Xsub flushall {
  1795. X    $name = 'TRAILER!!!';
  1796. X    foreach $fh (keys %cpout) {
  1797. X    &cpio($nc{$fh},$fh);
  1798. X    $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
  1799. X    &flush($fh);
  1800. X    print $blocks{$fh} * 10, " blocks\n";
  1801. X    }
  1802. X}
  1803. X
  1804. XEND
  1805. X}
  1806. X
  1807. Xif ($inittar) {
  1808. Xprint <<'END';
  1809. Xsub tar {
  1810. X    local($fh) = @_;
  1811. X    local($linkname,$header,$l,$slop);
  1812. X    local($linkflag) = "\0";
  1813. X
  1814. X    ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
  1815. X      $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
  1816. X    $nm = $name;
  1817. X    if ($nlink > 1) {
  1818. X    if ($linkname = $linkseen{$fh,$dev,$ino}) {
  1819. X        $linkflag = 1;
  1820. X    }
  1821. X    else {
  1822. X        $linkseen{$fh,$dev,$ino} = $nm;
  1823. X    }
  1824. X    }
  1825. X    if (-f _) {
  1826. X    open(IN, $_) || do {
  1827. X        warn "Couldn't open $name: $!\n";
  1828. X        return;
  1829. X    };
  1830. X    $size = 0 if $linkflag ne "\0";
  1831. X    }
  1832. X    else {
  1833. X    $linkname = readlink($_);
  1834. X    $linkflag = 2 if defined $linkname;
  1835. X    $nm .= '/' if -d _;
  1836. X    $size = 0;
  1837. X    }
  1838. X
  1839. X    $header = pack("a100a8a8a8a12a12a8a1a100",
  1840. X    $nm,
  1841. X    sprintf("%6o ", $mode & 0777),
  1842. X    sprintf("%6o ", $uid & 0777777),
  1843. X    sprintf("%6o ", $gid & 0777777),
  1844. X    sprintf("%11o ", $size),
  1845. X    sprintf("%11o ", $mtime),
  1846. X    "        ",
  1847. X    $linkflag,
  1848. X    $linkname);
  1849. X    $l = length($header) % 512;
  1850. X    substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
  1851. X    substr($header, 154, 1) = "\0";  # blech
  1852. X    $tarout{$fh} .= $header;
  1853. X    $tarout{$fh} .= "\0" x (512 - $l) if $l;
  1854. X    if ($size) {
  1855. X    &tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
  1856. X    while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
  1857. X        $slop = length($tarout{$fh}) % 512;
  1858. X        $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
  1859. X        &tflush($fh);
  1860. X        $l = length($tarout{$fh});
  1861. X    }
  1862. X    }
  1863. X    close IN;
  1864. X}
  1865. X
  1866. Xsub tflush {
  1867. X    local($fh) = @_;
  1868. X
  1869. X    while (length($tarout{$fh}) >= 10240) {
  1870. X    syswrite($fh,$tarout{$fh},10240);
  1871. X    ++$blocks{$fh};
  1872. X    substr($tarout{$fh}, 0, 10240) = '';
  1873. X    }
  1874. X}
  1875. X
  1876. Xsub tflushall {
  1877. X    local($len);
  1878. X
  1879. X    foreach $fh (keys %tarout) {
  1880. X    $len = 10240 - length($tarout{$fh});
  1881. X    $len += 10240 if $len < 1024;
  1882. X    $tarout{$fh} .= "\0" x $len;
  1883. X    &tflush($fh);
  1884. X    }
  1885. X}
  1886. X
  1887. XEND
  1888. X}
  1889. X
  1890. Xexit;
  1891. X
  1892. X############################################################################
  1893. X
  1894. Xsub tab {
  1895. X    local($tabstring);
  1896. X
  1897. X    $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
  1898. X    if (!$statdone) {
  1899. X    if ($_ =~ /^(name|print)/) {
  1900. X        $delayedstat++;
  1901. X    }
  1902. X    else {
  1903. X        if ($saw_or) {
  1904. X        $tabstring .= <<'ENDOFSTAT' . $tabstring;
  1905. X($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
  1906. XENDOFSTAT
  1907. X        }
  1908. X        else {
  1909. X        $tabstring .= <<'ENDOFSTAT' . $tabstring;
  1910. X(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
  1911. XENDOFSTAT
  1912. X        }
  1913. X        $statdone = 1;
  1914. X    }
  1915. X    }
  1916. X    $tabstring =~ s/^\s+/ / if $out =~ /!$/;
  1917. X    $tabstring;
  1918. X}
  1919. X
  1920. Xsub fileglob_to_re {
  1921. X    local($tmp) = @_;
  1922. X
  1923. X    $tmp =~ s/([.^\$()])/\\$1/g;
  1924. X    $tmp =~ s/([?*])/.$1/g;
  1925. X    "^$tmp$";
  1926. X}
  1927. X
  1928. Xsub n {
  1929. X    local($n) = @_;
  1930. X
  1931. X    $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
  1932. X    $n =~ s/ 0*(\d)/ $1/;
  1933. X    $n;
  1934. X}
  1935. X
  1936. Xsub quote {
  1937. X    local($string) = @_;
  1938. X    $string =~ s/'/\\'/;
  1939. X    "'$string'";
  1940. X}
  1941. X!NO!SUBS!
  1942. Xchmod 755 find2perl
  1943. X$eunicefix find2perl
  1944. !STUFFY!FUNK!
  1945. echo Extracting eg/muck
  1946. sed >eg/muck <<'!STUFFY!FUNK!' -e 's/X//'
  1947. X#!../perl
  1948. X
  1949. X$M = '-M';
  1950. X$M = '-m' if -d '/usr/uts' && -f '/etc/master';
  1951. X
  1952. Xdo 'getopt.pl';
  1953. Xdo Getopt('f');
  1954. X
  1955. Xif ($opt_f) {
  1956. X    $makefile = $opt_f;
  1957. X}
  1958. Xelsif (-f 'makefile') {
  1959. X    $makefile = 'makefile';
  1960. X}
  1961. Xelsif (-f 'Makefile') {
  1962. X    $makefile = 'Makefile';
  1963. X}
  1964. Xelse {
  1965. X    die "No makefile\n";
  1966. X}
  1967. X
  1968. X$MF = 'mf00';
  1969. X
  1970. Xwhile(($key,$val) = each(ENV)) {
  1971. X    $mac{$key} = $val;
  1972. X}
  1973. X
  1974. Xdo scan($makefile);
  1975. X
  1976. X$co = $action{'.c.o'};
  1977. X$co = ' ' unless $co;
  1978. X
  1979. X$missing = "Missing dependencies:\n";
  1980. Xforeach $key (sort keys(o)) {
  1981. X    if ($oc{$key}) {
  1982. X    $src = $oc{$key};
  1983. X    $action = $action{$key};
  1984. X    }
  1985. X    else {
  1986. X    $action = '';
  1987. X    }
  1988. X    if (!$action) {
  1989. X    if ($co && ($c = $key) =~ s/\.o$/.c/ && -f $c) {
  1990. X        $src = $c;
  1991. X        $action = $co;
  1992. X    }
  1993. X    else {
  1994. X        print "No source found for $key $c\n";
  1995. X        next;
  1996. X    }
  1997. X    }
  1998. X    $I = '';
  1999. X    $D = '';
  2000. X    $I .= $1 while $action =~ s/(-I\S+\s*)//;
  2001. X    $D .= $1 . ' ' while $action =~ s/(-D\w+)//;
  2002. X    if ($opt_v) {
  2003. X    $cmd = "Checking $key: cc $M $D $I $src";
  2004. X    $cmd =~ s/\s\s+/ /g;
  2005. X    print stderr $cmd,"\n";
  2006. X    }
  2007. X    open(CPP,"cc $M $D $I $src|") || die "Can't run C preprocessor: $!";
  2008. X    while (<CPP>) {
  2009. X    ($name,$dep) = split;
  2010. X    $dep =~ s|^\./||;
  2011. X    (print $missing,"$key: $dep\n"),($missing='')
  2012. X        unless ($dep{"$key: $dep"} += 2) > 2;
  2013. X    }
  2014. X}
  2015. X
  2016. X$extra = "\nExtraneous dependencies:\n";
  2017. Xforeach $key (sort keys(dep)) {
  2018. X    if ($key =~ /\.o: .*\.h$/ && $dep{$key} == 1) {
  2019. X    print $extra,$key,"\n";
  2020. X    $extra = '';
  2021. X    }
  2022. X}
  2023. X
  2024. Xsub scan {
  2025. X    local($makefile) = @_;
  2026. X    local($MF) = $MF;
  2027. X    print stderr "Analyzing $makefile.\n" if $opt_v;
  2028. X    $MF++;
  2029. X    open($MF,$makefile) || die "Can't open $makefile: $!";
  2030. X    while (<$MF>) {
  2031. X    chop;
  2032. X    chop($_ = $_ . <$MF>) while s/\\$//;
  2033. X    next if /^#/;
  2034. X    next if /^$/;
  2035. X    s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
  2036. X    s/\$\((\w+)\)/$mac{$1}/eg;
  2037. X    $mac{$1} = $2, next if /^(\w+)\s*=\s*(.*)/;
  2038. X    if (/^include\s+(.*)/) {
  2039. X        do scan($1);
  2040. X        print stderr "Continuing $makefile.\n" if $opt_v;
  2041. X        next;
  2042. X    }
  2043. X    if (/^([^:]+):\s*(.*)/) {
  2044. X        $left = $1;
  2045. X        $right = $2;
  2046. X        if ($right =~ /^([^;]*);(.*)/) {
  2047. X        $right = $1;
  2048. X        $action = $2;
  2049. X        }
  2050. X        else {
  2051. X        $action = '';
  2052. X        }
  2053. X        while (<$MF>) {
  2054. X        last unless /^\t/;
  2055. X        chop;
  2056. X        chop($_ = $_ . <$MF>) while s/\\$//;
  2057. X        next if /^#/;
  2058. X        last if /^$/;
  2059. X        s/\$\((\w+):([^=)]*)=([^)]*)\)/do subst("$1","$2","$3")/eg;
  2060. X        s/\$\((\w+)\)/$mac{$1}/eg;
  2061. X        $action .= $_;
  2062. X        }
  2063. X        foreach $targ (split(' ',$left)) {
  2064. X        $targ =~ s|^\./||;
  2065. X        foreach $src (split(' ',$right)) {
  2066. X            $src =~ s|^\./||;
  2067. X            $deplist{$targ} .= ' ' . $src;
  2068. X            $dep{"$targ: $src"} = 1;
  2069. X            $o{$src} = 1 if $src =~ /\.o$/;
  2070. X            $oc{$targ} = $src if $targ =~ /\.o$/ && $src =~ /\.[yc]$/;
  2071. X        }
  2072. X        $action{$targ} .= $action;
  2073. X        }
  2074. X        redo if $_;
  2075. X    }
  2076. X    }
  2077. X    close($MF);
  2078. X}
  2079. X
  2080. Xsub subst {
  2081. X    local($foo,$from,$to) = @_;
  2082. X    $foo = $mac{$foo};
  2083. X    $from =~ s/\./[.]/;
  2084. X    y/a/a/;
  2085. X    $foo =~ s/\b$from\b/$to/g;
  2086. X    $foo;
  2087. X}
  2088. !STUFFY!FUNK!
  2089. echo " "
  2090. echo "End of kit 26 (of 36)"
  2091. cat /dev/null >kit26isdone
  2092. run=''
  2093. config=''
  2094. for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do
  2095.     if test -f kit${iskit}isdone; then
  2096.     run="$run $iskit"
  2097.     else
  2098.     todo="$todo $iskit"
  2099.     fi
  2100. done
  2101. case $todo in
  2102.     '')
  2103.     echo "You have run all your kits.  Please read README and then type Configure."
  2104.     for combo in *:AA; do
  2105.         if test -f "$combo"; then
  2106.         realfile=`basename $combo :AA`
  2107.         cat $realfile:[A-Z][A-Z] >$realfile
  2108.         rm -rf $realfile:[A-Z][A-Z]
  2109.         fi
  2110.     done
  2111.     rm -rf kit*isdone
  2112.     chmod 755 Configure
  2113.     ;;
  2114.     *)  echo "You have run$run."
  2115.     echo "You still need to run$todo."
  2116.     ;;
  2117. esac
  2118. : Someone might mail this, so...
  2119. exit
  2120.  
  2121. exit 0 # Just in case...
  2122. -- 
  2123. Kent Landfield                   INTERNET: kent@sparky.IMD.Sterling.COM
  2124. Sterling Software, IMD           UUCP:     uunet!sparky!kent
  2125. Phone:    (402) 291-8300         FAX:      (402) 291-4362
  2126. Please send comp.sources.misc-related mail to kent@uunet.uu.net.
  2127.