57332fbd8991d3236c1ee9a0c563420e85f3773c
[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
64 my $ssrc = shift;
65 usage unless $ssrc =~ m{^(.+/)?s\.([^/]+)$}s;
66 my $qssrc = quotemeta $ssrc;
67 my $src = $2;
68
69 my $dst = $append // $src;
70 my $dstv = "$dst,v";
71 my $qdstv = quotemeta $dstv;
72
73 shit "working file must not exist: $src" if -f $src;
74 shit "working file must not exist: $dst" if -f $dst;
75 shit "RCS file must not exist: $dstv"
76 if -f $dstv and not defined $append;
77
78 # slurp commit details: date time perpetrator revision
79 my @info = popen qq{sccs prs -e -d':D: :T: :P: :I:' $qssrc};
80
81 # paranoid revision number checking
82 # we don't know how to deal with branches etc.
83 my $prev = 0;
84 for my $rev (reverse @info) {
85 shit "bad revision number $rev"
86 unless $rev =~ m{ 1\.(\d+)$}
87 and $1 == ++$prev;
88 }
89
90 # give rcs ci an empty stdin to read for empty commit messages
91 open STDIN, '<', '/dev/null'
92 or shite "open STDIN < /dev/null";
93
94 # create RCS file in binary mode (to avoid keyword expansion)
95 # with no lock enforcement (to avoid lock/unlock faff)
96 sysx qq{rcs -i -kb -U -t- $qdstv}
97 unless defined $append;
98
99 for my $info (reverse @info) {
100 my ($date,$time,$user,$rev) = split ' ', $info;
101 my $nomsg = "date and time created $date $time by $user\n";
102 $date =~ s{^([789][0-9])}{19$1} or $date =~ s{^}{20};
103 print "$date $time $user $src ";
104 # no keyword expansion please
105 sysx qq{sccs get -k -r$rev $qssrc};
106 my $message = popen qq{sccs prs -r$rev -d':C:' $qssrc};
107 $message =~ s{^\s*(.*?)\s*$}{$1\n};
108 $message = "\n" if $rev eq '1.1' and $message eq $nomsg;
109 my @flags = ("-d$date $time", "-w$user");
110 push @flags, "-m$message" unless $message eq "\n";
111 if (defined $append) {
112 if ($src ne $dst) {
113 rename $src, $dst
114 or shite "rename $src -> $dst";
115 }
116 push @flags, "-f";
117 } else {
118 push @flags, "-f$rev";
119 }
120 sysx 'ci', @flags, $dst, $dstv;
121 unlink $dst;
122 }