mzs: adjust relative paths to match ipreg repo
[ipreg/sccs2rcs2cvs2git.git] / sccs2cvs
1 #!/usr/bin/perl
2
3 use warnings;
4 use strict;
5
6 use feature 'switch';
7
8 use Cwd 'realpath';
9 use File::Basename;
10 use File::Find;
11 use File::Path;
12 use POSIX;
13
14 sub usage {
15         die <<USAGE;
16 usage: sccs2cvs [-m<usermap>] [-w<user>] <source> <target>
17
18 Create a CVS repository at the target, and convert the source
19 directory tree into a module in the CVS repository.
20
21 Commits from SCCS are transferred to the CVS repository. Commits are
22 synthesized for files which are not checked in to SCCS, attribued to
23 the given user.
24
25 This is a destructive conversion, to make it easier to see what was
26 not converted.
27
28 If a file was not checked out in the SCCS working tree, a tombstone is
29 left behind in the form of a symlink pointing at 'Attic'. The caller
30 can then invoke rcsdeadify if necessary.
31
32 Names within the CVS repo are relative to the parent directory of the
33 source directory tree, so the basename of the source tree becomes the
34 module name within the repository.
35
36 USAGE
37 }
38
39 sub shite { die "sccs2cvs: @_: $!\n"; }
40 sub shit  { die "sccs2cvs: @_\n"; }
41 sub whoa  { warn "sccs2cvs: \e[32m@_\e[0m\n"; }
42
43 sub sysx {
44         system @_;
45         shit "failed: @_" if $?;
46 }
47
48 sub popen ($) {
49         my $cmd = shift;
50         my @out = qx{$cmd};
51         shit "failed: $cmd" if $?;
52         if (wantarray) { return @out }
53         else { return join '', @out }
54 }
55
56 usage unless @ARGV > 2 and @ARGV < 5;
57
58 my @useropt = ();
59 push @useropt, shift while $ARGV[0] =~ m{^-[mw]};
60
61 # because we change directory below
62 for (@useropt) {
63         $_ = "-m" . realpath($1) if m{^-m(.*)};
64 }
65
66 my $usrc = shift;
67 my $udst = shift;
68
69 my $src = realpath $usrc;
70 my $dst = realpath $udst;
71
72 shit "target $udst already exists" if -d $dst;
73
74 # almost all the CVS we need :-)
75 my $qdst = quotemeta $dst;
76 sysx "cvs -d $qdst init";
77
78 my $pdir = dirname $src;
79 my $qpdir = quotemeta $pdir;
80
81 # case-sensitive -f
82 sub _f {
83         my $f = shift;
84         return -f $f && 1 == grep { $_ eq $f } glob "$f*";
85 }
86
87 # executable by anyone?
88 sub _x {
89         my $f = shift;
90         return (_f $f) && ((stat $f)[2] & 0111)
91 }
92
93 find { wanted => \&found, no_chdir => 1}, $src;
94
95 sub found {
96         # only interested in files
97         return unless -f;
98
99         shit "unable to uplift gzip files" if m{\.gz$};
100
101         m{^$qpdir/(.+?)/(SCCS/[sp]\.)?([^/]+)~?$}
102             or shit "could not parse $_";
103         my $subdir = $1;
104         my $name = $3;
105
106         mkpath "$dst/$subdir";
107         chdir "$dst/$subdir" or shite "chdir $dst/$subdir";
108
109         my $file = "$pdir/$subdir/$name";
110         my $back = "$pdir/$subdir/$name~";
111         my $sccs = "$pdir/$subdir/SCCS/s.$name";
112         my $lock = "$pdir/$subdir/SCCS/p.$name";
113         my $qfile = quotemeta $file;
114         my $qback = quotemeta $back;
115         my $qsccs = quotemeta $sccs;
116
117         unlink $lock and whoa "deleted lock $lock";
118
119         # SCCS conversion?
120         if (_f $sccs) {
121                 whoa "converting $sccs";
122                 sysx 'sccs2rcs1', $sccs;
123                 if (_x $sccs or _x $file) {
124                         whoa "executable $file";
125                         chmod 0555, "$name,v";
126                 }
127                 # Any other files need fixups?
128                 if (_f $file) {
129                         system "sccs get -s -k -p $qsccs | diff - $qfile >/dev/null";
130                         shit "diff $sccs $file failed"
131                             if ! WIFEXITED($?) || WEXITSTATUS($?) > 1;
132                         # edit in progress
133                         if (WEXITSTATUS($?) == 1) {
134                                 whoa "merge $file";
135                                 sysx 'files2rcs', @useropt, "$name,v", $file
136                         }
137                         whoa "clean $file";
138                         unlink $file;
139                 } else {
140                         # leave a tombstone
141                         whoa "attic $file";
142                         symlink 'Attic', $file;
143                 }
144                 if (_f $back) {
145                         # does it match a revision in the SCCS file?
146                         for my $rev (popen qq{sccs prs -e -d:I: $qsccs}) {
147                                 chomp $rev;
148                                 system "sccs get -s -k -p -r$rev $qsccs | diff - $qback >/dev/null";
149                                 if ($? == 0) {
150                                         whoa "clean $back";
151                                         unlink $back;
152                                 }
153                         }
154                 }
155                 # no match in the SCCS file
156                 if (_f $back) {
157                         whoa "converting $back";
158                         sysx 'files2rcs', @useropt, "$name~,v", $back;
159                         # does it predate the SCCS file?
160                         my $mtime = strftime "%Y-%m-%d.%H:%M:%S",
161                         localtime((stat $back)[9]);
162                         my $time1 = popen qq{sccs prs -r1.1 -d':D:.:T:' $qsccs};
163                         chomp $time1;
164                         $time1 =~ s{^([789])}{19$1} or $time1 =~ s{^}{20};
165                         if ($mtime < $time1) {
166                                 whoa "append $file";
167                                 sysx 'rcsappend', "$name~,v", "$name,v";
168                                 unlink "$name,v";
169                                 rename "$name~,v", "$name,v";
170                         }
171                         whoa "clean $back";
172                         unlink $back;
173                 }
174                 whoa "clean $sccs";
175                 unlink $sccs;
176         }
177         if (_f $back) {
178                 whoa "converting $back";
179                 sysx 'files2rcs', @useropt, "$name~,v", $back;
180                 whoa "clean $back";
181                 unlink $back;
182                 # so the next files2rcs appends to the same history
183                 if (_f $file) {
184                         rename "$name~,v", "$name,v"
185                             or shite "rename $name~,v -> $name,v";
186                 }
187         }
188         if (_f $file) {
189                 whoa "converting $file";
190                 sysx 'files2rcs', @useropt, "$name,v", $file;
191                 whoa "clean $file";
192                 unlink $file;
193         }
194 }
195
196 whoa "DONE sccs2cvs W00T";