mzs: adjust relative paths to match ipreg repo
[ipreg/sccs2rcs2cvs2git.git] / sccscheck
1 #!/usr/bin/perl
2
3 use warnings;
4 use strict;
5
6 use feature 'switch';
7
8 no warnings 'experimental::smartmatch';
9
10 use File::Find;
11 use POSIX;
12
13 unless (@ARGV) {
14         die <<USAGE;
15 usage: sccscheck [directory]
16
17 Scan the directory tree for anomalies:
18
19 gzipped files
20 backup ~ files
21 symlinks
22 SCCS files without working files
23 working files without SCCS files
24 working files which do not match the latest SCCS revision
25
26 USAGE
27 }
28
29 # case-sensitive -f
30 sub _f {
31         my $f = shift;
32         return -f $f && 1 == grep { $_ eq $f } glob "$f*";
33 }
34
35 find { wanted => \&found, no_chdir => 1}, @ARGV;
36
37 sub found {
38         given ($File::Find::name) {
39                 when (m{^(.*)/SCCS/s\.([^/]+)$}s) {
40                         when (m{~$}) {
41                                 print "SCCS BACK $_\n";
42                         }
43                         when (m{\.gz$}) {
44                                 print "SCCS GZIP $_\n";
45                         }
46                         when (! _f "$1/$2") {
47                                 print "SCCS UNGET $_\n";
48                         }
49                 }
50                 when (m{^(.*)/SCCS/p\.([^/]+)$}s) {
51                         print "SCCS LOCK $_\n";
52                 }
53                 when (m{^(.*)/([^/]+)~$}s) {
54                         my $sccs = "$1/SCCS/s.$2";
55                         when (_f $sccs) {
56                                 # was the backup checked in?
57                                 my $mtime = strftime "%Y-%m-%d.%H:%M:%S%z",
58                                     localtime((stat)[9]);
59                                 my $qsccs = quotemeta $sccs;
60                                 my $qback = quotemeta $_;
61                                 my @revs = qx{sccs prs -e -d:I: $qsccs};
62                                 for my $rev (@revs) {
63                                         chomp $rev;
64                                         system "sccs get -s -k -p -r$rev $qsccs | diff -u - $qback >/dev/null";
65                                         if ($? == 0) {
66                                                 print "BACKSCCS $rev $_\n";
67                                                 break;
68                                         }
69                                 }
70                                 my $time1 = qx{sccs prs -r1.1 -d':D:.:T:' $qsccs};
71                                 chomp $time1;
72                                 $time1 =~ s{^([789])}{19$1} or $time1 =~ s{^}{20};
73                                 if ($mtime lt $time1) {
74                                         print "BACKSCCS PREDATE $_\n";
75                                 } else {
76                                         print "BACKSCCS NOMATCH $mtime $time1 $_\n";
77                                 }
78                                 continue;
79                         }
80                         when (_f "$1/$2") {
81                                 my $qback = quotemeta $_;
82                                 my $qfile = quotemeta "$1/$2";
83                                 system "diff -u $qback $qfile >/dev/null";
84                                 if (not $?) {
85                                         print "BACKSAME $_\n"
86                                 } else {
87                                         my $backtime = (stat $_)[9];
88                                         my $filetime = (stat "$1/$2")[9];
89                                         if ($backtime < $filetime) {
90                                                 print "BACKDIFF $_\n";
91                                         } else {
92                                                 print "BACKTIMEWARP $_\n";
93                                         }
94                                 }
95                         }
96                         print "BACKLESS $_\n";
97                 }
98                 when (m{\.gz$}) {
99                         print "GZIP $_\n";
100                 }
101                 when (-l) {
102                         print "LINK $_\n";
103                 }
104                 when (-d) {
105                         # skip
106                 }
107                 default {
108                         m{^(.*)/([^/]+)$}s;
109                         my $sccs = "$1/SCCS/s.$2";
110                         when (! _f $sccs) {
111                                 print "NO SCCS $_\n";
112                         }
113                         my $qsccs = quotemeta $sccs;
114                         my $qfile = quotemeta $_;
115                         system "sccs get -s -k -p $qsccs | diff -u - $qfile >/dev/null";
116                         print "SCCS DIFF $_\n" if $?;
117                 }
118         }
119 }