Commit | Line | Data |
---|---|---|
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 | |
45 | require 'getopts.pl'; | |
46 | &usage unless $#ARGV >= 0; | |
47 | &usage unless &Getopts("abfhnpqsV"); | |
48 | ||
49 | if ($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 | ||
60 | system 'mkdir', 'RCS' unless -d 'RCS'; | |
61 | ||
62 | chop($pwd = `pwd`) unless -f '.package'; | |
63 | until (-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 | } | |
69 | if ($prefix) { | |
70 | for (@ARGV) { | |
71 | s/^/$prefix/ unless m|^[-/]|; | |
72 | } | |
73 | } | |
74 | ||
75 | # We now are at the top level | |
76 | ||
77 | &readpackage; | |
78 | ||
79 | if (-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 | ||
90 | system 'mkdir', 'bugs' unless -d 'bugs'; | |
91 | open(LOGS,">>bugs/.logs$bnum"); # Remember logs for patmake | |
92 | open(MODS,">>bugs/.mods$bnum"); # Remember modified files | |
93 | ||
94 | push(@sw,'-q') if $opt_q; | |
95 | push(@sw,'-f') if $opt_f; | |
96 | ||
97 | if ($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 | ||
115 | sub CLEANUP { | |
116 | print "$progname: Warning: restore $ARGV\n"; | |
117 | exit 1; | |
118 | } | |
119 | ||
120 | if ($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 | ||
160 | if ($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 | ||
169 | open(MANI,"MANIFEST.new") || die "$progname: can't open MANIFEST.new: $!\n"; | |
170 | while (<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 | } | |
177 | close MANI; | |
178 | $space = 29 unless $space; # Default value | |
179 | ||
180 | file: 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 | |
270 | sub 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. | |
282 | sub 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 | ||
304 | sub feed { | |
305 | local($mess) = shift(@_); | |
306 | open(FORK,"|-") || exec @_; | |
307 | print FORK $mess; | |
308 | close FORK; | |
309 | $?; | |
310 | } | |
311 | ||
312 | sub 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 " | |
338 | CR or . Terminate log message. | |
339 | !<cmd> Start command in a subshell. | |
340 | D Print out diff listing since last patch. | |
341 | N Give name of the current file. | |
342 | E Call editor for log message with a diff listing. | |
343 | V Call editor for file with a context diff added to HISTORY. | |
344 | X Extract HISTORY and append it to current log message. | |
345 | a Always use this message. | |
346 | d Print out diff listing since last patcil. | |
347 | f Forget message I have so far. | |
348 | h or ? This help message. | |
349 | l List what I have so far. | |
350 | n Forget this file; go to next file if any. | |
351 | p Append previous message. | |
352 | r Print out the rlog for this file. | |
353 | e Call editor for log message. | |
354 | v Call editor for file. | |
355 | x 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 | ||
485 | sub 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 | ||
496 | sub usage { | |
497 | print STDERR <<EOM; | |
498 | Usage: $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 | |
508 | EOM | |
509 | exit 1; | |
510 | } | |
511 | ||
512 | sub 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 | ||
569 | sub 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 | ||
594 | sub 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 | ||
610 | sub 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 | ||
623 | sub 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 | ||
639 | sub 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 | |
671 | sub 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 ;-) | |
681 | sub 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. | |
691 | sub 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 |