mzs: adjust relative paths to match ipreg repo
[ipreg/sccs2rcs2cvs2git.git] / rcsappend
1 #!/usr/bin/perl
2
3 use warnings;
4 use strict;
5
6 sub usage () {
7         die <<USAGE;
8 usage: rcsappend <target,v> <source,v>
9
10 rcsappend adds the revisions contained in <source,v> as more recent
11 revisions in <target,v>. It overwrites and deletes a temporary working
12 file in the same directory as <target,v> with the basename <target>.
13
14 USAGE
15 }
16
17 my $log_header_re = qr{
18         \n
19         RCS\ file:[^\n]*\n
20         Working\ file:[^\n]*\n
21         head:\ [0-9.]+\n
22         branch:[^\n]*\n
23         locks:[^\n]*\n
24         access\ list:[^\n]*\n
25         symbolic\ names:[^\n]*\n
26         keyword\ substitution:[^\n]*\n
27         total\ revisions:\ [0-9]+;\s+
28         selected\ revisions:\ [0-9]+\n
29         description:[^\n]*\n
30 }x;
31
32 my $shortline_re = qr{-{28}\n};
33 my $longline_re = qr{={77}\n};
34
35 my $log_end_re = qr{(?:$shortline_re)?$longline_re};
36
37 my $entry_header_re = qr{
38         $shortline_re
39         revision\ ([0-9.]+)\n
40         date:\ ([0-9/]{10}\ [0-9:]{8});[ ][ ]
41         author:\ ([a-z0-9]+);[ ][ ]
42         state:\ [A-Za-z]+;(?:[ ][ ]
43         lines:\ [+][0-9]+\ [-][0-9]+)?\n
44 }x;
45
46 my $entry_separator_re = qr{$entry_header_re|$log_end_re};
47
48 sub shite { die "rcsappend: @_: $!\n"; }
49 sub shit  { die "rcsappend: @_\n"; }
50
51 sub sysx {
52         system @_;
53         shit "failed: @_" if $?;
54 }
55
56 sub popen ($) {
57         my $cmd = shift;
58         my @out = qx{$cmd};
59         shit "failed: $cmd" if $?;
60         if (wantarray) { return @out }
61         else { return join '', @out }
62 }
63
64 usage unless @ARGV == 2;
65
66 my $targetv = shift;
67 my $qtargetv = quotemeta $targetv;
68 usage unless $targetv =~ m{^(.*),v$};
69 my $tmptarget = $1;
70
71 my $sourcev = shift;
72 my $qsourcev = quotemeta $sourcev;
73 usage unless $sourcev =~ m{^(.*),v$};
74 my $tmpsource = $1;
75
76
77 my $log = popen qq{rlog $qsourcev};
78 shit "could not parse log header"
79     unless $log =~ s{^$log_header_re(?=$entry_separator_re)}{};
80
81 my @rev;
82
83 while ($log !~ m{^$log_end_re$}) {
84         shit "could not parse log entry"
85             unless $log =~ s{^$entry_header_re(.*?)(?=$entry_separator_re)}{}s;
86         unshift @rev, { rev => $1, date => $2, user => $3, message => $4 };
87 }
88
89 # paranoid revision number checking
90 # we don't know how to deal with branches etc.
91 my $prev = 0;
92 for my $rev (@rev) {
93         shit "bad revision number $rev->{rev}"
94             unless $rev->{rev} =~ m{^1\.(\d+)$}
95                 and $1 == ++$prev;
96 }
97
98 for my $rev (@rev) {
99         # no keyword expansion please
100         sysx 'co', '-kb', "-r$rev->{rev}",
101             $sourcev, $tmpsource;
102         rename $tmpsource, $tmptarget
103             or shite "rename $tmpsource -> $tmptarget";
104         sysx 'ci', '-f', "-d$rev->{date}", "-w$rev->{user}", "-m$rev->{message}",
105             $targetv, $tmptarget;
106         unlink $tmptarget;
107 }