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 }