mzs: adjust relative paths to match ipreg repo
[ipreg/sccs2rcs2cvs2git.git] / sccs2rcs1
1 #!/usr/bin/perl
2
3 # TODO: (unimplemented features not needed for ip-register)
4 #
5 # SCCS :FD: to RCS -t file description
6 #
7 # branches
8
9 use warnings;
10 use strict;
11
12 sub usage () {
13         die <<USAGE;
14 usage: sccs2rcs1 [-afile,v] <path/to/s.file>
15
16 sccs2rcs1 creates an RCS ",v" file in the current directory
17 containing data from the given SCCS "s." file. It overwrites
18 and deletes a temporary working file in the current
19 directory with the same basname as the SCCS/RCS files.
20
21 If the -a flag is given then the revisions are added to the
22 given RCS ",v" file instead of creating a new RCS file.
23
24 Example:
25         mkdir RCS
26         cd RCS
27         for f in ../SCCS/s.*
28         do sccs2rcs1 \$f
29         done
30
31 USAGE
32 }
33
34 sub shite { die "sccs2rcs1: @_: $!\n"; }
35 sub shit  { die "sccs2rcs1: @_\n"; }
36
37 sub sysx {
38         system @_;
39         shit "failed: @_" if $?;
40 }
41
42 sub popen ($) {
43         my $cmd = shift;
44         my @out = qx{$cmd};
45         shit "failed: $cmd" if $?;
46         if (wantarray) { return @out }
47         else { return join '', @out }
48 }
49
50 my $append;
51 if ($ARGV[0] =~ m{^-a(.+)$}) {
52         $append = $1;
53         shit "destination RCS file must be in the current directory: $append"
54           if $append =~ m{/};
55         shit "destination RCS file must exist: $append"
56           unless -f $append;
57         shit "destination must be an RCS file: $append"
58           unless $append =~ s{,v$}{};
59         shift;
60 }
61
62 usage unless @ARGV == 1;
63 warn "\e[34m$0 @ARGV\e[0m\n";
64
65 my $ssrc = shift;
66 usage unless $ssrc =~ m{^(.+/)?s\.([^/]+)$}s;
67 my $qssrc = quotemeta $ssrc;
68 my $src = $2;
69
70 my $dst = $append // $src;
71 my $dstv = "$dst,v";
72 my $qdstv = quotemeta $dstv;
73
74 shit "working file must not exist: $src" if -f $src;
75 shit "working file must not exist: $dst" if -f $dst;
76 shit "RCS file must not exist: $dstv"
77   if -f $dstv and not defined $append;
78
79 # slurp commit details: date time perpetrator revision
80 my @info = popen qq{sccs prs -e -d':D: :T: :P: :I:' $qssrc};
81
82 # paranoid revision number checking
83 # we don't know how to deal with branches etc.
84 my $prev = 0;
85 for my $rev (reverse @info) {
86         shit "bad revision number $rev"
87             unless $rev =~ m{ 1\.(\d+)$}
88                 and $1 == ++$prev;
89 }
90
91 # give rcs ci an empty stdin to read for empty commit messages
92 open STDIN, '<', '/dev/null'
93     or shite "open STDIN < /dev/null";
94
95 # create RCS file in binary mode (to avoid keyword expansion)
96 # with no lock enforcement (to avoid lock/unlock faff)
97 sysx qq{rcs -i -kb -U -t- $qdstv}
98   unless defined $append;
99
100 for my $info (reverse @info) {
101         my ($date,$time,$user,$rev) = split ' ', $info;
102         my $nomsg = "date and time created $date $time by $user\n";
103         $date =~ s{^([789][0-9])}{19$1} or $date =~ s{^}{20};
104         print "$date $time $user $src ";
105         # no keyword expansion please
106         sysx qq{sccs get -k -r$rev $qssrc};
107         my $message = popen qq{sccs prs -r$rev -d':C:' $qssrc};
108         $message =~ s{^\s*(.*?)\s*$}{$1\n};
109         $message = "\n" if $rev eq '1.1' and $message eq $nomsg;
110         my @flags = ("-d$date $time", "-w$user");
111         push @flags, "-m$message" unless $message eq "\n";
112         if (defined $append) {
113                 if ($src ne $dst) {
114                         rename $src, $dst
115                             or shite "rename $src -> $dst";
116                 }
117                 push @flags, "-f";
118         } else {
119                 push @flags, "-f$rev";
120         }
121         sysx 'ci', @flags, $dst, $dstv;
122         unlink $dst;
123 }