pod/perlipc.pod patch
[p5sagit/p5-mst-13.2.git] / x2p / find2perl.PL
CommitLineData
4633a7c4 1#!/usr/local/bin/perl
2
3use Config;
4use File::Basename qw(&basename &dirname);
5
6# List explicitly here the variables you want Configure to
7# generate. Metaconfig only looks for shell variables, so you
8# have to mention them as if they were shell variables, not
9# %Config entries. Thus you write
10# $startperl
11# to ensure Configure will look for $Config{startperl}.
12
13# This forces PL files to create target in same directory as PL file.
14# This is so that make depend always knows where to find PL derivatives.
15chdir(dirname($0));
16($file = basename($0)) =~ s/\.PL$//;
17$file =~ s/\.pl$//
f360dba1 18 if ($^O eq 'VMS' or $^O eq 'os2'); # "case-forgiving"
4633a7c4 19
20open OUT,">$file" or die "Can't create $file: $!";
21
22print "Extracting $file (with variable substitutions)\n";
23
24# In this section, perl variables will be expanded during extraction.
25# You can use $Config{...} to use Configure variables.
26
27print OUT <<"!GROK!THIS!";
28$Config{'startperl'}
29 eval 'exec perl -S \$0 "\$@"'
30 if 0;
f70b6ff5 31\$startperl = "$Config{startperl}";
4633a7c4 32!GROK!THIS!
33
34# In the following, perl variables are not expanded during extraction.
35
36print OUT <<'!NO!SUBS!';
93a17b20 37#
38# Modified September 26, 1993 to provide proper handling of years after 1999
39# Tom Link <tml+@pitt.edu>
40# University of Pittsburgh
fe14fcc3 41
fe14fcc3 42while ($ARGV[0] =~ /^[^-!(]/) {
43 push(@roots, shift);
44}
45@roots = ('.') unless @roots;
46for (@roots) { $_ = &quote($_); }
47$roots = join(',', @roots);
48
49$indent = 1;
50
51while (@ARGV) {
52 $_ = shift;
53 s/^-// || /^[()!]/ || die "Unrecognized switch: $_\n";
54 if ($_ eq '(') {
55 $out .= &tab . "(\n";
56 $indent++;
57 next;
58 }
59 elsif ($_ eq ')') {
60 $indent--;
61 $out .= &tab . ")";
62 }
63 elsif ($_ eq '!') {
64 $out .= &tab . "!";
65 next;
66 }
67 elsif ($_ eq 'name') {
68 $out .= &tab;
69 $pat = &fileglob_to_re(shift);
70 $out .= '/' . $pat . "/";
71 }
72 elsif ($_ eq 'perm') {
73 $onum = shift;
74 die "Malformed -perm argument: $onum\n" unless $onum =~ /^-?[0-7]+$/;
75 if ($onum =~ s/^-//) {
76 $onum = '0' . sprintf("%o", oct($onum) & 017777); # s/b 07777 ?
e334a159 77 $out .= &tab . "((\$mode & $onum) == $onum)";
fe14fcc3 78 }
79 else {
80 $onum = '0' . $onum unless $onum =~ /^0/;
e334a159 81 $out .= &tab . "((\$mode & 0777) == $onum)";
fe14fcc3 82 }
83 }
84 elsif ($_ eq 'type') {
85 ($filetest = shift) =~ tr/s/S/;
86 $out .= &tab . "-$filetest _";
87 }
88 elsif ($_ eq 'print') {
89 $out .= &tab . 'print("$name\n")';
90 }
91 elsif ($_ eq 'print0') {
92 $out .= &tab . 'print("$name\0")';
93 }
94 elsif ($_ eq 'fstype') {
95 $out .= &tab;
96 $type = shift;
97 if ($type eq 'nfs')
79072805 98 { $out .= '($dev < 0)'; }
fe14fcc3 99 else
79072805 100 { $out .= '($dev >= 0)'; }
fe14fcc3 101 }
102 elsif ($_ eq 'user') {
103 $uname = shift;
79072805 104 $out .= &tab . "(\$uid == \$uid{'$uname'})";
fe14fcc3 105 $inituser++;
106 }
107 elsif ($_ eq 'group') {
108 $gname = shift;
79072805 109 $out .= &tab . "(\$gid == \$gid{'$gname'})";
fe14fcc3 110 $initgroup++;
111 }
112 elsif ($_ eq 'nouser') {
113 $out .= &tab . '!defined $uid{$uid}';
114 $inituser++;
115 }
116 elsif ($_ eq 'nogroup') {
117 $out .= &tab . '!defined $gid{$gid}';
118 $initgroup++;
119 }
120 elsif ($_ eq 'links') {
79072805 121 $out .= &tab . '($nlink ' . &n(shift);
fe14fcc3 122 }
123 elsif ($_ eq 'inum') {
79072805 124 $out .= &tab . '($ino ' . &n(shift);
fe14fcc3 125 }
126 elsif ($_ eq 'size') {
463ee0b2 127 $out .= &tab . '(int(((-s _) + 511) / 512) ' . &n(shift);
fe14fcc3 128 }
129 elsif ($_ eq 'atime') {
79072805 130 $out .= &tab . '(int(-A _) ' . &n(shift);
fe14fcc3 131 }
132 elsif ($_ eq 'mtime') {
79072805 133 $out .= &tab . '(int(-M _) ' . &n(shift);
fe14fcc3 134 }
135 elsif ($_ eq 'ctime') {
79072805 136 $out .= &tab . '(int(-C _) ' . &n(shift);
fe14fcc3 137 }
138 elsif ($_ eq 'exec') {
139 for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
140 shift;
6e21c824 141 $_ = "@cmd";
142 if (m#^(/bin/)?rm -f {}$#) {
143 if (!@ARGV) {
144 $out .= &tab . 'unlink($_)';
145 }
146 else {
147 $out .= &tab . '(unlink($_) || 1)';
148 }
149 }
150 elsif (m#^(/bin/)?rm {}$#) {
151 $out .= &tab . '(unlink($_) || warn "$name: $!\n")';
152 }
153 else {
154 for (@cmd) { s/'/\\'/g; }
155 $" = "','";
156 $out .= &tab . "&exec(0, '@cmd')";
157 $" = ' ';
158 $initexec++;
159 }
fe14fcc3 160 }
161 elsif ($_ eq 'ok') {
162 for (@cmd = (); @ARGV && $ARGV[0] ne ';'; push(@cmd,shift)) { }
163 shift;
164 for (@cmd) { s/'/\\'/g; }
165 $" = "','";
166 $out .= &tab . "&exec(1, '@cmd')";
167 $" = ' ';
168 $initexec++;
169 }
170 elsif ($_ eq 'prune') {
171 $out .= &tab . '($prune = 1)';
172 }
173 elsif ($_ eq 'xdev') {
a0d0e21e 174 $out .= &tab . '!($prune |= ($dev != $topdev))';
fe14fcc3 175 }
176 elsif ($_ eq 'newer') {
177 $out .= &tab;
178 $file = shift;
179 $newername = 'AGE_OF' . $file;
180 $newername =~ s/[^\w]/_/g;
181 $newername = '$' . $newername;
79072805 182 $out .= "(-M _ < $newername)";
fe14fcc3 183 $initnewer .= "$newername = -M " . &quote($file) . ";\n";
184 }
185 elsif ($_ eq 'eval') {
186 $prog = &quote(shift);
187 $out .= &tab . "eval $prog";
188 }
189 elsif ($_ eq 'depth') {
190 $depth++;
191 next;
192 }
193 elsif ($_ eq 'ls') {
194 $out .= &tab . "&ls";
195 $initls++;
196 }
197 elsif ($_ eq 'tar') {
198 $out .= &tab;
199 die "-tar must have a filename argument\n" unless @ARGV;
200 $file = shift;
201 $fh = 'FH' . $file;
202 $fh =~ s/[^\w]/_/g;
203 $out .= "&tar($fh)";
204 $file = '>' . $file;
205 $initfile .= "open($fh, " . &quote($file) .
206 qq{) || die "Can't open $fh: \$!\\n";\n};
207 $inittar++;
208 $flushall = "\n&tflushall;\n";
209 }
210 elsif (/^n?cpio$/) {
211 $depth++;
212 $out .= &tab;
213 die "-$_ must have a filename argument\n" unless @ARGV;
214 $file = shift;
215 $fh = 'FH' . $file;
216 $fh =~ s/[^\w]/_/g;
217 $out .= "&cpio('" . substr($_,0,1) . "', $fh)";
218 $file = '>' . $file;
219 $initfile .= "open($fh, " . &quote($file) .
220 qq{) || die "Can't open $fh: \$!\\n";\n};
221 $initcpio++;
222 $flushall = "\n&flushall;\n";
223 }
224 else {
225 die "Unrecognized switch: -$_\n";
226 }
227 if (@ARGV) {
228 if ($ARGV[0] eq '-o') {
6e21c824 229 { local($statdone) = 1; $out .= "\n" . &tab . "||\n"; }
1c3d792e 230 $statdone = 0 if $indent == 1 && $delayedstat;
231 $saw_or++;
fe14fcc3 232 shift;
233 }
234 else {
235 $out .= " &&" unless $ARGV[0] eq ')';
236 $out .= "\n";
237 shift if $ARGV[0] eq '-a';
238 }
239 }
240}
241
242print <<"END";
4633a7c4 243$startperl
fe14fcc3 244
4633a7c4 245eval 'exec perl -S \$0 \${1+"\$@"}'
8adcabd8 246 if \$running_under_some_shell;
247
fe14fcc3 248END
249
250if ($initls) {
251 print <<'END';
252@rwx = ('---','--x','-w-','-wx','r--','r-x','rw-','rwx');
253@moname = (Jan,Feb,Mar,Apr,May,Jun,Jul,Aug,Sep,Oct,Nov,Dec);
254
255END
256}
257
258if ($inituser || $initls) {
259 print 'while (($name, $pw, $uid) = getpwent) {', "\n";
260 print ' $uid{$name} = $uid{$uid} = $uid;', "\n" if $inituser;
261 print ' $user{$uid} = $name unless $user{$uid};', "\n" if $initls;
262 print "}\n\n";
263}
264
265if ($initgroup || $initls) {
266 print 'while (($name, $pw, $gid) = getgrent) {', "\n";
267 print ' $gid{$name} = $gid{$gid} = $gid;', "\n" if $initgroup;
268 print ' $group{$gid} = $name unless $group{$gid};', "\n" if $initls;
269 print "}\n\n";
270}
271
272print $initnewer, "\n" if $initnewer;
273
274print $initfile, "\n" if $initfile;
275
6e21c824 276$find = $depth ? "finddepth" : "find";
fe14fcc3 277print <<"END";
6e21c824 278require "$find.pl";
279
fe14fcc3 280# Traverse desired filesystems
281
6e21c824 282&$find($roots);
fe14fcc3 283$flushall
284exit;
285
286sub wanted {
287$out;
288}
289
290END
291
fe14fcc3 292if ($initexec) {
293 print <<'END';
294sub exec {
295 local($ok, @cmd) = @_;
296 foreach $word (@cmd) {
297 $word =~ s#{}#$name#g;
298 }
299 if ($ok) {
300 local($old) = select(STDOUT);
301 $| = 1;
302 print "@cmd";
303 select($old);
304 return 0 unless <STDIN> =~ /^y/;
305 }
306 chdir $cwd; # sigh
307 system @cmd;
308 chdir $dir;
309 return !$?;
310}
311
312END
313}
314
315if ($initls) {
316 print <<'END';
317sub ls {
318 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$sizemm,
319 $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
320
321 $pname = $name;
322
323 if (defined $blocks) {
324 $blocks = int(($blocks + 1) / 2);
325 }
326 else {
327 $blocks = int(($size + 1023) / 1024);
328 }
329
330 if (-f _) { $perms = '-'; }
331 elsif (-d _) { $perms = 'd'; }
332 elsif (-c _) { $perms = 'c'; $sizemm = &sizemm; }
333 elsif (-b _) { $perms = 'b'; $sizemm = &sizemm; }
334 elsif (-p _) { $perms = 'p'; }
335 elsif (-S _) { $perms = 's'; }
336 else { $perms = 'l'; $pname .= ' -> ' . readlink($_); }
337
338 $tmpmode = $mode;
339 $tmp = $rwx[$tmpmode & 7];
340 $tmpmode >>= 3;
341 $tmp = $rwx[$tmpmode & 7] . $tmp;
342 $tmpmode >>= 3;
343 $tmp = $rwx[$tmpmode & 7] . $tmp;
344 substr($tmp,2,1) =~ tr/-x/Ss/ if -u _;
345 substr($tmp,5,1) =~ tr/-x/Ss/ if -g _;
346 substr($tmp,8,1) =~ tr/-x/Tt/ if -k _;
347 $perms .= $tmp;
348
349 $user = $user{$uid} || $uid;
350 $group = $group{$gid} || $gid;
351
352 ($sec,$min,$hour,$mday,$mon,$year) = localtime($mtime);
353 $moname = $moname[$mon];
354 if (-M _ > 365.25 / 2) {
93a17b20 355 $timeyear = $year + 1900;
fe14fcc3 356 }
357 else {
358 $timeyear = sprintf("%02d:%02d", $hour, $min);
359 }
360
361 printf "%5lu %4ld %-10s %2d %-8s %-8s %8s %s %2d %5s %s\n",
362 $ino,
363 $blocks,
364 $perms,
365 $nlink,
366 $user,
367 $group,
368 $sizemm,
369 $moname,
370 $mday,
371 $timeyear,
372 $pname;
373 1;
374}
375
376sub sizemm {
377 sprintf("%3d, %3d", ($rdev >> 8) & 255, $rdev & 255);
378}
379
380END
381}
382
383if ($initcpio) {
384print <<'END';
385sub cpio {
386 local($nc,$fh) = @_;
387 local($text);
388
389 if ($name eq 'TRAILER!!!') {
390 $text = '';
391 $size = 0;
392 }
393 else {
394 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
395 $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
396 if (-f _) {
99b89507 397 open(IN, "./$_\0") || do {
fe14fcc3 398 warn "Couldn't open $name: $!\n";
399 return;
400 };
401 }
402 else {
403 $text = readlink($_);
404 $size = 0 unless defined $text;
405 }
406 }
407
408 ($nm = $name) =~ s#^\./##;
409 $nc{$fh} = $nc;
410 if ($nc eq 'n') {
411 $cpout{$fh} .=
412 sprintf("%06o%06o%06o%06o%06o%06o%06o%06o%011lo%06o%011lo%s\0",
413 070707,
414 $dev & 0777777,
415 $ino & 0777777,
416 $mode & 0777777,
417 $uid & 0777777,
418 $gid & 0777777,
419 $nlink & 0777777,
420 $rdev & 0177777,
421 $mtime,
422 length($nm)+1,
423 $size,
424 $nm);
425 }
426 else {
427 $cpout{$fh} .= "\0" if length($cpout{$fh}) & 1;
428 $cpout{$fh} .= pack("SSSSSSSSLSLa*",
429 070707, $dev, $ino, $mode, $uid, $gid, $nlink, $rdev, $mtime,
430 length($nm)+1, $size, $nm . (length($nm) & 1 ? "\0" : "\0\0"));
431 }
432 if ($text ne '') {
433 $cpout{$fh} .= $text;
434 }
435 elsif ($size) {
436 &flush($fh) while ($l = length($cpout{$fh})) >= 5120;
437 while (sysread(IN, $cpout{$fh}, 5120 - $l, $l)) {
438 &flush($fh);
439 $l = length($cpout{$fh});
440 }
441 }
442 close IN;
443}
444
445sub flush {
446 local($fh) = @_;
447
448 while (length($cpout{$fh}) >= 5120) {
449 syswrite($fh,$cpout{$fh},5120);
450 ++$blocks{$fh};
451 substr($cpout{$fh}, 0, 5120) = '';
452 }
453}
454
455sub flushall {
456 $name = 'TRAILER!!!';
457 foreach $fh (keys %cpout) {
458 &cpio($nc{$fh},$fh);
459 $cpout{$fh} .= "0" x (5120 - length($cpout{$fh}));
460 &flush($fh);
461 print $blocks{$fh} * 10, " blocks\n";
462 }
463}
464
465END
466}
467
468if ($inittar) {
469print <<'END';
470sub tar {
471 local($fh) = @_;
472 local($linkname,$header,$l,$slop);
473 local($linkflag) = "\0";
474
475 ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
476 $atime,$mtime,$ctime,$blksize,$blocks) = lstat(_);
477 $nm = $name;
478 if ($nlink > 1) {
479 if ($linkname = $linkseen{$fh,$dev,$ino}) {
480 $linkflag = 1;
481 }
482 else {
483 $linkseen{$fh,$dev,$ino} = $nm;
484 }
485 }
486 if (-f _) {
99b89507 487 open(IN, "./$_\0") || do {
fe14fcc3 488 warn "Couldn't open $name: $!\n";
489 return;
490 };
491 $size = 0 if $linkflag ne "\0";
492 }
493 else {
494 $linkname = readlink($_);
495 $linkflag = 2 if defined $linkname;
496 $nm .= '/' if -d _;
497 $size = 0;
498 }
499
500 $header = pack("a100a8a8a8a12a12a8a1a100",
501 $nm,
502 sprintf("%6o ", $mode & 0777),
503 sprintf("%6o ", $uid & 0777777),
504 sprintf("%6o ", $gid & 0777777),
505 sprintf("%11o ", $size),
506 sprintf("%11o ", $mtime),
507 " ",
508 $linkflag,
509 $linkname);
510 $l = length($header) % 512;
511 substr($header, 148, 6) = sprintf("%6o", unpack("%16C*", $header));
512 substr($header, 154, 1) = "\0"; # blech
513 $tarout{$fh} .= $header;
514 $tarout{$fh} .= "\0" x (512 - $l) if $l;
515 if ($size) {
516 &tflush($fh) while ($l = length($tarout{$fh})) >= 10240;
517 while (sysread(IN, $tarout{$fh}, 10240 - $l, $l)) {
518 $slop = length($tarout{$fh}) % 512;
519 $tarout{$fh} .= "\0" x (512 - $slop) if $slop;
520 &tflush($fh);
521 $l = length($tarout{$fh});
522 }
523 }
524 close IN;
525}
526
527sub tflush {
528 local($fh) = @_;
529
530 while (length($tarout{$fh}) >= 10240) {
531 syswrite($fh,$tarout{$fh},10240);
532 ++$blocks{$fh};
533 substr($tarout{$fh}, 0, 10240) = '';
534 }
535}
536
537sub tflushall {
538 local($len);
539
540 foreach $fh (keys %tarout) {
541 $len = 10240 - length($tarout{$fh});
542 $len += 10240 if $len < 1024;
543 $tarout{$fh} .= "\0" x $len;
544 &tflush($fh);
545 }
546}
547
548END
549}
550
551exit;
552
553############################################################################
554
555sub tab {
556 local($tabstring);
557
558 $tabstring = "\t" x ($indent / 2) . ' ' x ($indent % 2 * 4);
1c3d792e 559 if (!$statdone) {
8adcabd8 560 if ($_ =~ /^(name|print|prune|exec|ok|\(|\))/) {
1c3d792e 561 $delayedstat++;
562 }
563 else {
564 if ($saw_or) {
565 $tabstring .= <<'ENDOFSTAT' . $tabstring;
566($nlink || (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_))) &&
567ENDOFSTAT
568 }
569 else {
570 $tabstring .= <<'ENDOFSTAT' . $tabstring;
fe14fcc3 571(($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
572ENDOFSTAT
1c3d792e 573 }
fe14fcc3 574 $statdone = 1;
575 }
576 }
577 $tabstring =~ s/^\s+/ / if $out =~ /!$/;
578 $tabstring;
579}
580
581sub fileglob_to_re {
582 local($tmp) = @_;
583
79072805 584 $tmp =~ s#([./^\$()])#\\$1#g;
fe14fcc3 585 $tmp =~ s/([?*])/.$1/g;
8990e307 586 "^$tmp\$";
fe14fcc3 587}
588
589sub n {
590 local($n) = @_;
591
1c3d792e 592 $n =~ s/^-/< / || $n =~ s/^\+/> / || $n =~ s/^/== /;
593 $n =~ s/ 0*(\d)/ $1/;
79072805 594 $n . ')';
fe14fcc3 595}
596
597sub quote {
598 local($string) = @_;
599 $string =~ s/'/\\'/;
600 "'$string'";
601}
602!NO!SUBS!
4633a7c4 603
604close OUT or die "Can't close $file: $!";
605chmod 0755, $file or die "Can't reset permissions for $file: $!\n";
606exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':';