This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
add probe for __attribute__(always_inline)
[metaconfig.git] / bin / patcil
CommitLineData
459d3fb5
MBT
1#!/usr/bin/perl
2 eval "exec perl -i~ -S $0 $*"
3 if $running_under_some_shell;
4
5# $Id: patcil.SH 1 2006-08-24 12:32:52Z rmanfredi $
6#
7# Copyright (c) 1991-1997, 2004-2006, Raphael Manfredi
8#
9# You may redistribute only under the terms of the Artistic Licence,
10# as specified in the README file that comes with the distribution.
11# You may reuse parts of this distribution only within the terms of
12# that same Artistic Licence; a copy of which may be found at the root
13# of the source tree for dist 4.0.
14#
15# Original Author: Larry Wall <lwall@netlabs.com>
16#
17# $Log: patcil.SH,v $
18# Revision 3.0.1.4 1994/10/29 16:42:12 ram
19# patch36: now honors the VISUAL and EDITOR environment variables
20# patch36: newer RCS programs chop trailing spaces in log messages
21# patch36: separated V/E and v/e commands
22# patch36: new 'v' command to edit the file being patcil'ed
23# patch36: added hook for 'V' command (not implemented yet)
24#
25# Revision 3.0.1.3 1994/01/24 14:30:04 ram
26# patch16: now prefix error messages with program's name
27# patch16: added ~/.dist_profile awareness
28#
29# Revision 3.0.1.2 1993/08/25 14:05:35 ram
30# patch6: moved geteditor to ../pl/editor.pl
31#
32# Revision 3.0.1.1 1993/08/19 06:42:33 ram
33# patch1: leading config.sh searching was not aborting properly
34#
35# Revision 3.0 1993/08/18 12:10:40 ram
36# Baseline for dist 3.0 netwide release.
37#
38
39$defeditor = '/usr/bin/vi';
40$pager = '/pro/local/bin/less';
41$version = '3.5';
42$patchlevel = '0';
43
44$progname = &profile; # Read ~/.dist_profile
45require 'getopts.pl';
46&usage unless $#ARGV >= 0;
47&usage unless &Getopts("abfhnpqsV");
48
49if ($opt_V) {
50 print STDERR "$progname $version PL$patchlevel\n";
51 exit 0;
52} elsif ($opt_h) {
53 &usage;
54}
55
56$RCSEXT = ',v' unless $RCSEXT;
57$PAGER = $ENV{'PAGER'} || "$pager";
58$EDITOR = &geteditor;
59
60system 'mkdir', 'RCS' unless -d 'RCS';
61
62chop($pwd = `pwd`) unless -f '.package';
63until (-f '.package') {
64 die "$progname: no .package file! Run packinit.\n" unless $pwd;
65 chdir '..' || die "Can't cd ..";
66 $pwd =~ s|(.*)/(.*)|$1|;
67 $prefix = $2 . '/' . $prefix;
68}
69if ($prefix) {
70 for (@ARGV) {
71 s/^/$prefix/ unless m|^[-/]|;
72 }
73}
74
75# We now are at the top level
76
77&readpackage;
78
79if (-f 'patchlevel.h') {
80 open(PL,"patchlevel.h") || die "$progname: can't open patchlevel.h: $!\n";
81 while (<PL>) {
82 $bnum = $1 if /^#define\s+PATCHLEVEL\s+(\d+)/;
83 }
84 die "$progname: malformed patchlevel.h file.\n" if $bnum eq '';
85 ++$bnum;
86} else {
87 $bnum=1;
88}
89
90system 'mkdir', 'bugs' unless -d 'bugs';
91open(LOGS,">>bugs/.logs$bnum"); # Remember logs for patmake
92open(MODS,">>bugs/.mods$bnum"); # Remember modified files
93
94push(@sw,'-q') if $opt_q;
95push(@sw,'-f') if $opt_f;
96
97if ($opt_a) {
98 open(MANI,"MANIFEST.new") || die "$progname: can't read MANIFEST.new: $!\n";
99 @ARGV = ();
100 while (<MANI>) {
101 chop;
102 s|^\./||;
103 next if m|^patchlevel.h|; # Special file
104 ($_) = split(' ');
105 next if -d;
106 push(@ARGV,$_);
107 }
108 close MANI;
109} elsif ($opt_n) {
110 &newer;
111}
112
113@filelist = @ARGV;
114
115sub CLEANUP {
116 print "$progname: Warning: restore $ARGV\n";
117 exit 1;
118}
119
120if ($opt_s) {
121 open(TTY,">/dev/tty");
122 select(TTY);
123 $| = 1;
124 select(stdout);
125 $SIG{'INT'} = 'CLEANUP';
126 while (<>) {
127 if (/^(.*)\$Log[:\$]/) {
128 $comment = $1;
129 $comment =~ s/\s+$//; # Newer RCS chop spaces on emtpy lines
130 $len = length($comment);
131 print;
132 $lastnl = 1;
133 logline: while (<>) {
134 $c = substr($_,0,$len);
135 last logline unless $c eq $comment;
136 $_ = substr($_,$len,999);
137 if ($lastnl) {
138 unless (/^\s*Revision\s+\d/) {
139 $_ = $comment . $_;
140 last logline;
141 }
142 $lastnl = 0;
143 } else {
144 $lastnl = 1 if /^\s*$/;
145 }
146 }
147 }
148 }
149 continue {
150 print;
151 if ($ARGV ne $oldargv) {
152 print TTY "$progname: stripping $ARGV...\n";
153 $oldargv = $ARGV;
154 }
155 }
156 $SIG{'INT'} = 'DEFAULT';
157 close TTY;
158}
159
160if ($opt_b) {
161 $flist = &rcsargs(@filelist);
162 @flist=split(' ',$flist);
163 system 'rcs', '-u', @flist;
164 system 'rcs', "-l$revbranch", @flist;
165 system 'ci', '-l', "-r$revbranch", @sw, @flist;
166 exit 0;
167}
168
169open(MANI,"MANIFEST.new") || die "$progname: can't open MANIFEST.new: $!\n";
170while (<MANI>) {
171 # Find how many spaces the user wants before comments
172 $space || /(\S+\s+)\S+/ && ($space = length($1));
173 ($file,$file_comment) = m|(\S+)\s+(.*)|;
174 $inmani{$file} = 1; # File is listed in MANIFEST
175 $comment{$file} = $file_comment; # Save comments
176}
177close MANI;
178$space = 29 unless $space; # Default value
179
180file: foreach $file (@filelist) {
181 $files = &rcsargs($file);
182 @files = split(' ',$files);
183 $file = $files[1] if $file =~ /\.$RCSEXT$/;
184 unless ($inmani{$file}) {
185 print "$file does not appear to be in your MANIFEST.new--add? [y] ";
186 $ans = <stdin>;
187 if ($ans !~ /^n/i) {
188 print "MANIFEST.new comment? ";
189 $file_comment = <stdin>;
190 chop($file_comment);
191 $spacenum = $space - length($file);
192 $blank = " ";
193 $blank = " " x $spacenum unless $spacenum < 1;
194 `echo '${file}${blank}$file_comment' >>MANIFEST.new`;
195 if (-f 'MANIFEST') {
196 print "(Also adding file to your MANIFEST)\n";
197 # Add a (new) at the end, so the two manifests will
198 # differ and thus manifest will get patched correctly.
199 `echo '${file}${blank}$file_comment (new)' >>MANIFEST`;
200 print MODS "MANIFEST\n";
201 }
202 } else {
203 $file_comment = ""; # No file, no comment
204 }
205 }
206 $is_first = 0; # Suppose this is not the first cil
207 $revs = 0; # Makes revs a numeric variable
208 $rlog = `rlog -r$baserev -r$revbranch $files 2>&1`;
209 ($total) = ($rlog =~ /total revisions: (\d+)/);
210 ($revs) = ($rlog =~ /selected revisions: (\d+)/);
211 $comment = &rcscomment($file);
212 if (!$revs) {
213 if ($total) {
214 if ($rlog !~ /locks:\s*;/) {
215 system 'rcs', '-u', @files; # unlock branch
216 }
217 # New trunck revision
218 system 'rcs', '-l', @files; # lock trunk
219 }
220 else {
221 $file_comment = $comment{$file} if $inmani{$file};
222 if ($comment ne '') {
223 &feed($file_comment, 'rcs', '-i', "-c$comment", @files);
224 } else {
225 &feed($file_comment, 'rcs', '-i', @files);
226 }
227 }
228 if ($opt_p) { # check in null as trunk revision
229 rename($file, "$file.xxx");
230 `cp /dev/null $file` unless -f $file;
231 &cil_col("empty\n", $baserev);
232 system 'rcs', "-Nlastpat:$baserev", @files;
233 rename("$file.xxx", $file);
234 $mess = &getlog($file);
235 next file if $mess eq 'nope';
236 system 'rcs', '-u', @files; # Unlock trunck
237 &feed($mess, 'ci', "-l$revbranch", @sw, @files) unless $?;
238 } else {
239 $is_first = 1; # This is the first cil
240 $mess = &getlog($file);
241 next file if $mess eq 'nope';
242 &cil_col($mess, $baserev);
243 system 'rcs', "-Nlastpat:$baserev", @files;
244 }
245 } else {
246 if (!$opt_f) {
247 if ($revs == 1) {
248 $delta = `rcsdiff -r$baserev $files 2>/dev/null`;
249 } else {
250 $delta = `rcsdiff -r$revbranch $files 2>/dev/null`;
251 }
252 if ($delta eq '') { # No change in file
253 print "$progname: no changes in $file since last patcil.\n";
254 next; # Skip file
255 }
256 }
257 if ($revs == 1) {
258 $mess = &getlog($file);
259 next file if $mess eq 'nope';
260 &cil_cil($mess, $revbranch);
261 } else {
262 $mess = &getlog($file);
263 next file if $mess eq 'nope';
264 &cil_col($mess, $revbranch);
265 }
266 }
267}
268
269# Used for the first revisions on a branch
270sub cil_cil {
271 local($mess) = shift(@_);
272 local($rev) = shift(@_);
273 if (&feed($mess, 'ci', @sw, "-l$rev", @files)) {
274 print "$progname: unlocking and trying again...\n";
275 system 'rcs', '-u', @files;
276 &feed($mess, 'ci', @sw, "-l$rev", @files) unless $?;
277 }
278}
279
280# Run a ci -l on the file. If this fails, try to lock the file first.
281# If this fails again, try again with a separate checkout.
282sub cil_col {
283 local($mess) = shift(@_);
284 local($rev) = shift(@_);
285 if (&feed($mess, 'ci', @sw, "-l$rev", @files)) {
286 print "$progname: locking and trying again...\n";
287 if ($rev =~ /\d+\.\d+\.\d+/) {
288 system 'rcs', "-l$rev", @files; # Lock branch
289 } else {
290 system 'rcs', '-l', @files; # Lock trunck
291 }
292 if (&feed($mess, 'ci', @sw, "-l$rev", @files)) {
293 print "$progname: trying again with separate checkout...\n";
294 if (&feed($mess, 'ci', @sw, "-r$rev", @files)) {
295 system 'rcs', "-u$rev", @files unless $?;
296 system 'co', "-l$rev", @files unless $?;
297 } else {
298 print "$progname: sorry, giving up...\n";
299 }
300 }
301 }
302}
303
304sub feed {
305 local($mess) = shift(@_);
306 open(FORK,"|-") || exec @_;
307 print FORK $mess;
308 close FORK;
309 $?;
310}
311
312sub getlog {
313 local($file) = @_;
314 local($mess) = '';
315 local($prefix) = "patch$bnum: ";
316 local($prompt) = $comment;
317 local($len);
318 $prompt = '>> ' unless $prompt;
319 $prefix = '' if $is_first;
320 print "Type log message for $file (finish with ., CR for previous):\n";
321 try: for (;;) {
322 line: for (print "$prompt$prefix";;print "$prompt$prefix") {
323 if ($always) {
324 print "\n";
325 $line = '';
326 } else {
327 $line = <stdin>;
328 }
329 if ($line =~ /^\.?$/) {
330 if ($mess) {
331 last line;
332 } else {
333 $line = 'p';
334 }
335 }
336 if ($line =~ /^[h?]$/) {
337 print "
338CR or . Terminate log message.
339!<cmd> Start command in a subshell.
340D Print out diff listing since last patch.
341N Give name of the current file.
342E Call editor for log message with a diff listing.
343V Call editor for file with a context diff added to HISTORY.
344X Extract HISTORY and append it to current log message.
345a Always use this message.
346d Print out diff listing since last patcil.
347f Forget message I have so far.
348h or ? This help message.
349l List what I have so far.
350n Forget this file; go to next file if any.
351p Append previous message.
352r Print out the rlog for this file.
353e Call editor for log message.
354v Call editor for file.
355x Toggle patch# prefix.
356
357";
358 next line;
359 }
360 if ($line =~ /^!(.*)$/) {
361 $_ = $1;
362 $_ = ($ENV{'SHELL'} || "/bin/sh") if $1 eq '';
363 system $_;
364 next line;
365 }
366 if ($line =~ /^E$/) {
367 $mess .= "\n" . `rcsdiff -c -rlastpat $files`;
368 }
369 if ($line =~ /^e$/) {
370 $mess = &edit($mess);
371 next line;
372 }
373 if ($line =~ /^V$/) {
374 ######## FIXME #########
375 # Will do something like:
376 # &add_history($file, `rcsdiff -c -rlastpat $files`);
377 # HISTORY
378 # Extract or add this. Create it if not already there.
379 # $Log
380 # $EndLog <<-- stops HISTORY and COPYRIGHT lookup
381 ########################
382 print "HISTORY processing not implemented yet.\n";
383 print "(You have to use 'E' to get old 'V' processing).\n";
384 next line;
385 }
386 if ($line =~ /^v$/) {
387 system $EDITOR, $file;
388 next line;
389 }
390 if ($line =~ /^r$/) {
391 system "rlog $files | $PAGER";
392 next line;
393 }
394 if ($line =~ /^D$/) {
395 if ($revs == 0) {
396 print "Sorry. There is no revision for this file yet.\n";
397 } else {
398 system "rcsdiff -c -rlastpat $files | $PAGER";
399 }
400 next line;
401 }
402 if ($line =~ /^d$/) {
403 if ($revs == 0) {
404 print "Sorry. There is no revision for this file yet.\n";
405 }
406 elsif ($revs == 1) {
407 system "rcsdiff -c -r$baserev $files | $PAGER";
408 } else {
409 system "rcsdiff -c -r$revbranch $files | $PAGER";
410 }
411 next line;
412 }
413 if ($line =~ /^N$/) {
414 print "Typing log message for $file.\n";
415 next line;
416 }
417 if ($line =~ /^f$/) {
418 $mess = '';
419 next line;
420 }
421 if ($line =~ /^a$/) {
422 $always++ if $mess || $prevmess;
423 next line;
424 }
425 if ($line =~ /^n$/) {
426 $mess = 'nope';
427 last line;
428 }
429 if ($line =~ /^l$/) {
430 foreach $line (split(/\n/,$mess)) {
431 print $prompt,$line,"\n";
432 }
433 next line;
434 }
435 if ($line =~ /^p$/) {
436 $mess .= $prevmess;
437 foreach $line (split(/\n/,$prevmess)) {
438 print $prompt,$line,"\n";
439 }
440 next line;
441 }
442 if ($line =~ /^X$/) {
443 foreach $line (split(/\n/, &xtract_history($file))) {
444 $mess .= $prompt . $line . "\n";
445 print $prompt,$line,"\n";
446 }
447 next line;
448 }
449 if ($line =~ /^x$/) {
450 $prefix = $prefix ? '' : "patch$bnum: ";
451 next line;
452 }
453 $mess .= $prefix . $line;
454 $len = length($comment . $prefix . $line);
455 if ($len > 80) {
456 print "(Warning: last line longer than 80 chars)\n";
457 } elsif ($len > 72) { # In case of vi with line numbers
458 print "(Warning: last line longer than 72 chars)\n";
459 }
460 if (length($mess) > 511) {
461 print "You'll have to trim to less than 512 chars...\n";
462 sleep(3);
463 $mess = &edit($mess);
464 }
465 }
466 $mess = $prevmess if $mess eq '';
467 if (!$mess) {
468 print "No previous message, try again.\n";
469 next try;
470 }
471 if (length($mess) > 511) {
472 print "Sorry, that's too long; RCS won't take it. Try again...\n";
473 next try;
474 }
475 last try;
476 }
477 unless ($is_first) {
478 print LOGS $mess unless $mess eq 'nope';
479 print MODS "$file\n";
480 }
481 $prevmess = $mess unless $mess eq 'nope';
482 $mess; # Returned value
483}
484
485sub edit {
486 local($text) = join("\n", @_);
487 open(TMP,">/tmp/cil$$") || die "Can't create /tmp/cil$$";
488 print TMP $text;
489 close TMP;
490 system $EDITOR, "/tmp/cil$$";
491 $text = `cat /tmp/cil$$`;
492 unlink "/tmp/cil$$";
493 $text;
494}
495
496sub usage {
497 print STDERR <<EOM;
498Usage: $progname [-abfhnpqsV] [filelist]
499 -a : all the files in MANIFEST.new
500 -b : batch mode
501 -f : force check in (passed through to ci)
502 -h : print this message and exit
503 -n : all the files newer than patchlevel.h
504 -p : patching mode (null trunk revision if new file)
505 -q : ask rcs to be quiet
506 -s : strip log messages
507 -V : print version number and exit
508EOM
509 exit 1;
510}
511
512sub newer {
513 open(FIND, "find . -type f -newer patchlevel.h -print | sort |") ||
514 die "Can't run find.\n";
515 open(NEWER,">.newer") || die "Can't create .newer.\n";
516 open(MANI,"MANIFEST.new");
517 while (<MANI>) {
518 ($name,$foo) = split;
519 $mani{$name} = 1;
520 }
521 close MANI;
522 while (<FIND>) {
523 s|^\./||;
524 chop;
525 next if m|^MANIFEST|;
526 next if m|^PACKLIST$|;
527 if (!$mani{$_}) {
528 next if m|^MANIFEST.new$|;
529 next if m|^Changes$|;
530 next if m|^Wanted$|;
531 next if m|^.package$|;
532 next if m|^bugs|;
533 next if m|^users$|;
534 next if m|^UU/|;
535 next if m|^RCS/|;
536 next if m|/RCS/|;
537 next if m|^config.sh$|;
538 next if m|/config.sh$|;
539 next if m|^make.out$|;
540 next if m|/make.out$|;
541 next if m|^all$|;
542 next if m|/all$|;
543 next if m|^core$|;
544 next if m|/core$|;
545 next if m|^toto|;
546 next if m|/toto|;
547 next if m|^\.|;
548 next if m|/\.|;
549 next if m|\.o$|;
550 next if m|\.old$|;
551 next if m|\.orig$|;
552 next if m|~$|;
553 next if $mani{$_ . ".SH"};
554 next if m|(.*)\.c$| && $mani{$1 . ".y"};
555 next if m|(.*)\.c$| && $mani{$1 . ".l"};
556 next if (-x $_ && !m|^Configure$|);
557 }
558 print NEWER $_,"\n";
559 }
560 close FIND;
561 close NEWER;
562 print "Please remove unwanted files...\n";
563 sleep(2);
564 system '${EDITOR-vi} .newer';
565 die "Aborted.\n" unless -s '.newer' > 1;
566 @ARGV = split(' ',`cat .newer`);
567}
568
569sub readpackage {
570 if (! -f '.package') {
571 if (
572 -f '../.package' ||
573 -f '../../.package' ||
574 -f '../../../.package' ||
575 -f '../../../../.package'
576 ) {
577 die "Run in top level directory only.\n";
578 } else {
579 die "No .package file! Run packinit.\n";
580 }
581 }
582 open(PACKAGE,'.package');
583 while (<PACKAGE>) {
584 next if /^:/;
585 next if /^#/;
586 if (($var,$val) = /^\s*(\w+)=(.*)/) {
587 $val = "\"$val\"" unless $val =~ /^['"]/;
588 eval "\$$var = $val;";
589 }
590 }
591 close PACKAGE;
592}
593
594sub rcsargs {
595 local($result) = '';
596 local($_);
597 while ($_ = shift(@_)) {
598 if ($_ =~ /^-/) {
599 $result .= $_ . ' ';
600 } elsif ($#_ >= 0 && do equiv($_,$_[0])) {
601 $result .= $_ . ' ' . $_[0] . ' ';
602 shift(@_);
603 } else {
604 $result .= $_ . ' ' . do other($_) . ' ';
605 }
606 }
607 $result;
608}
609
610sub equiv {
611 local($s1, $s2) = @_;
612 $s1 =~ s|.*/||;
613 $s2 =~ s|.*/||;
614 if ($s1 eq $s2) {
615 0;
616 } elsif ($s1 =~ s/$RCSEXT$// || $s2 =~ s/$RCSEXT$//) {
617 $s1 eq $s2;
618 } else {
619 0;
620 }
621}
622
623sub other {
624 local($s1) = @_;
625 ($dir,$file) = ('./',$s1) unless local($dir,$file) = ($s1 =~ m|(.*/)(.*)|);
626 $dir = $TOPDIR . $dir if -d $TOPDIR . "$dir/RCS";
627 local($wasrcs) = ($file =~ s/$RCSEXT$//);
628 if ($wasrcs) {
629 `mkdir $dir` unless -d $dir;
630 $dir =~ s|RCS/||;
631 } else {
632 $dir .= 'RCS/';
633 `mkdir $dir` unless -d $dir;
634 $file .= $RCSEXT;
635 }
636 "$dir$file";
637}
638
639sub rcscomment {
640 local($file) = @_;
641 local($comment) = '';
642 open(FILE,$file);
643 while (<FILE>) {
644 if (/^(.*)\$Log[:\$]/) { # They know better than us (hopefully)
645 $comment = $1;
646 last;
647 }
648 }
649 close FILE;
650 unless ($comment) {
651 if ($file =~ /\.SH$|[Mm]akefile/) { # Makefile template
652 $comment = '# ';
653 } elsif ($file =~ /\.U$/) { # Metaconfig unit
654 $comment = '?RCS: ';
655 } elsif ($file =~ /\.man$/) { # Manual page
656 $comment = "''' ";
657 } elsif ($file =~ /\.\d\w?$/) { # Manual page
658 $comment = "''' ";
659 } elsif ($file =~ /\.[chyl]$/) { # C source
660 $comment = " * ";
661 } elsif ($file =~ /\.e$/) { # Eiffel source
662 $comment = "-- ";
663 } elsif ($file =~ /\.pl$/) { # Perl library
664 $comment = ";# ";
665 }
666 }
667 $comment;
668}
669
670# Compute suitable editor name
671sub geteditor {
672 local($editor) = $ENV{'VISUAL'};
673 $editor = $ENV{'EDITOR'} unless $editor;
674 $editor = $defeditor unless $editor;
675 $editor = 'vi' unless $editor;
676 $editor;
677}
678
679# Perform ~name expansion ala ksh...
680# (banish csh from your vocabulary ;-)
681sub tilda_expand {
682 local($path) = @_;
683 return $path unless $path =~ /^~/;
684 $path =~ s:^~([^/]+):(getpwnam($1))[$[+7]:e; # ~name
685 $path =~ s:^~:$ENV{'HOME'} || (getpwuid($<))[$[+7]:e; # ~
686 $path;
687}
688
689# Set up profile components into %Profile, add any profile-supplied options
690# into @ARGV and return the command invocation name.
691sub profile {
692 local($profile) = &tilda_expand($ENV{'DIST'} || '~/.dist_profile');
693 local($me) = $0; # Command name
694 $me =~ s|.*/(.*)|$1|; # Keep only base name
695 return $me unless -s $profile;
696 local(*PROFILE); # Local file descriptor
697 local($options) = ''; # Options we get back from profile
698 unless (open(PROFILE, $profile)) {
699 warn "$me: cannot open $profile: $!\n";
700 return;
701 }
702 local($_);
703 local($component);
704 while (<PROFILE>) {
705 next if /^\s*#/; # Skip comments
706 next unless /^$me/o;
707 if (s/^$me://o) { # progname: options
708 chop;
709 $options .= $_; # Merge options if more than one line
710 }
711 elsif (s/^$me-([^:]+)://o) { # progname-component: value
712 $component = $1;
713 chop;
714 s/^\s+//; # Trim leading and trailing spaces
715 s/\s+$//;
716 $Profile{$component} = $_;
717 }
718 }
719 close PROFILE;
720 return unless $options;
721 require 'shellwords.pl';
722 local(@opts);
723 eval '@opts = &shellwords($options)'; # Protect against mismatched quotes
724 unshift(@ARGV, @opts);
725 return $me; # Return our invocation name
726}
727