VCS-SCCS
view release on metacpan or search on metacpan
use warnings;
use POSIX qw(mktime);
use Carp;
use vars qw( $VERSION );
$VERSION = "0.29";
### ###########################################################################
# We can safely use \d instead of [0-9] for this ancient format
sub new {
my $proto = shift;
my $class = ref ($proto) || $proto or return;
# We can safely rule out "0" as a valid filename, ans 99.9999% of
# SCCS source files start with s.
my $fn = shift or croak ("SCCS needs a valid file name");
-e $fn or croak ("$fn does not exist");
-f $fn or croak ("$fn is not a file");
-s $fn or croak ("$fn is empty");
(my $filename = $fn) =~ s{\b(?:SCCS|sccs)/s\.(?=[^/]+$)}{};
open my $fh, "<", $fn or croak ("Cannot open '$fn': $!");
# Checksum
# ^Ah checksum
<$fh> =~ m/^\cAh(\d+)$/ or croak ("SCCS file $fn is supposed to start with a checksum");
my %sccs = (
file => $filename,
checksum => $1,
delta => {},
users => [],
flags => {},
comment => "",
body => undef,
current => undef,
vsn => {}, # version to revision map
tran => undef,
);
# Delta's At least one! ^A[ixg] ignored
# ^As inserted/deleted/unchanged
# ^Ad D version date time user v_new v_old
# ^Am MR
# ^Ac comment
# ^Ae
$_ = <$fh>;
while (m{^\cAs (\d+)/(\d+)/(\d+)$}) {
my @delta;
my ($l_ins, $l_del, $l_unc) = map { $_ + 0 } $1, $2, $3;
{ local $/ = "\cAe\n";
@delta = split m/\n/, scalar <$fh>;
}
my ($type, $vsn, $v_r, $v_l, $v_b, $v_s,
$date, $y, $m, $d, $time, $H, $M, $S,
$user, $rev, $prv) =
(shift (@delta) =~ m{
\cAd # Delta
\s+ ([DR]) # Type Delta/Remove?
\s+ ((\d+)\.(\d+)
(?:\.(\d+)(?:\.(\d+))?)?) # Vsn %R%.%L%[.%B%[.%S%]]
\s+ ((\d\d)/(\d\d)/(\d\d)) # Date %E%
\s+ ((\d\d):(\d\d):(\d\d)) # Time %U%
\s+ (\S+) # User
\s+ (\d+) # current rev
\s+ (\d+) # new rev
\s*$
}x);
$y += $y < 70 ? 2000 : 1900; # SCCS is not Y2k safe!
# Type R rev's are removed/overridden deltas:
# D 4.21 22 21
# D 4.20 21 19
# R 4.20 20 19
# D 4.19 19 18
my @mr = grep { s/^\cAm\s*// } @delta; # MR number(s)
my @cmnt = grep { s/^\cAc\s*// } @delta; # Comment
$sccs{current} ||= [ $rev, $vsn, $v_r, $v_l, $v_b, $v_s ];
$sccs{delta}{$rev} = {
lines_ins => $l_ins,
lines_del => $l_del,
lines_unc => $l_unc,
type => $type,
version => $vsn, # %I%
release => $v_r, # %R%
level => $v_l, # %L%
branch => $v_b, # %B%
sequence => $v_s, # %S%
date => $date, # %E%
time => $time, # %U%
stamp => mktime ($S, $M, $H, $d, $m - 1, $y - 1900, -1, -1, -1),
committer => $user,
mr => join (", ", @mr),
comment => join ("\n", @cmnt),
prev_rev => $prv,
};
exists $sccs{vsn}{$vsn} or $sccs{vsn}{$vsn} = $rev;
$_ = <$fh>;
}
# Users
# ^Au
# user1
# user2
# ...
# ^AU
if (m{^\cAu}) {
{ local $/ = "\cAU\n";
$sccs{users} = [ (<$fh> =~ m{^([A-Za-z].*)$}gm) ];
}
$_ = <$fh>;
}
# Flags
# ^Af q Project name
# ^Af v ...
# ^Af e 1
while (m/^\cAf \s+ (\S) \s* (.+)?$/x) {
$sccs{flags}{$1} = $2;
$_ = <$fh>;
}
# Comment
# ^At comment
while (s/^\cA[tT]\s*//) {
m/\S/ and $sccs{comment} .= $_;
$_ = <$fh>;
}
# Body
local $/ = undef;
$sccs{body} = [ split m/\n/, $_ . <$fh> ];
close $fh;
return bless \%sccs, $class;
} # new
sub file {
my $self = shift;
return $self->{file};
} # file
sub checksum {
my $self = shift;
return $self->{checksum};
} # checksum
sub users {
my $self = shift;
return @{$self->{users}};
} # users
sub flags {
my $self = shift;
return { %{$self->{flags}} };
} # flags
sub comment {
my $self = shift;
return $self->{comment};
} # comment
sub current {
my $self = shift;
$self->{current} or return;
wantarray ? @{$self->{current}} : $self->{current}[0];
} # current
sub delta {
my ($self, $rev) = @_;
$self->{current} or return;
if (!defined $rev) {
$rev = $self->{current}[0];
}
elsif (exists $self->{delta}{$rev}) {
#$rev = $rev;
}
elsif (exists $self->{vsn}{$rev}) {
$rev = $self->{vsn}{$rev};
}
else {
return;
}
return { %{ $self->{delta}{$rev} } };
} # delta
sub version {
my ($self, $rev) = @_;
ref $self eq __PACKAGE__ or return $VERSION;
$self->{current} or return;
# $self->version () returns most recent version
# I 9
# D 10
# E 10
# I 10
# D 53
# E 53
# I 53
# E 53
# I 23
# D 31
# E 31
# I 31
# D 45
# E 45
# I 45
# E 45
# D 53 ---+
# E 31 |
# E 23 |
# E 10 |
# E 9 |
# D 7 |
# E 7 |
# I 7 |
# E 53 <--+
# I 53
# E 53
# D 53
# E 53
# I 53
# E 53
# E 7
foreach my $x (reverse 0 .. $#lvl) {
$lvl[$x][2] == $e or next;
splice @lvl, $x, 1;
last;
}
$want = (grep { $_->[0] == 0 } @lvl) ? 0 : 1;
next;
}
if (m/^\cAI\s+(\d+)$/) {
push @lvl, [ $rseq{$1} ? 1 : 0, "I", $1 ];
$want = (grep { $_->[0] == 0 } @lvl) ? 0 : 1;
next;
}
if (m/^\cAD\s+(\d+)$/) {
push @lvl, [ $rseq{$1} ? 0 : 1, "D", $1 ];
$want = (grep { $_->[0] == 0 } @lvl) ? 0 : 1;
next;
}
if (m/^\cA(.*)/) {
carp "Unsupported SCCS control: ^A$1, line skipped";
next;
}
$want and push @body, $self->_tran ($_);
# printf STDERR "%2d.%04d/%s: %-29.29s |%s\n", $r, scalar @body, $want, $v->(), $_;
}
if ($self->{flags}{e} && @body && $body[0] =~ m/^[\x20-\x60]{1,61}$/) {
my $body = unpack "u" => join "\n" => @body;
$body and @body = split m/\n/ => $body;
}
return wantarray ? @body : join "\n", @body, "";
} # body
1;
__END__
=head1 NAME
VCS::SCCS - OO Interface to SCCS files
=head1 SYNOPSIS
use VCS::SCCS;
my $sccs = VCS::SCCS->new ("SCCS/s.file.pl"); # Read and parse
# Meta info
my $fn = $sccs->file (); # file.pl
my $cs = $sccs->checksum (); # 52534
my @us = $sccs->users (); # qw( merijn user )
my $fl = $sccs->flags (); # { q => "Test applic", v => undef }
my $cm = $sccs->comment (); # ""
my $cr = $sccs->current (); # 70
my @cr = $sccs->current (); # ( 70, "5.39", 5, 39 )
# Delta related
my $vs = $sccs->version (); # "5.39"
my $vs = $sccs->version (69); # "5.38"
my $rv = $sccs->revision (); # 70
my $rv = $sccs->revision ("5.37"); # 68
my $rm = $sccs->revision_map (); # [ [ 1, "4.1" ], ... [ 70, "5.39" ]]
my $dd = $sccs->delta (17); # none, revision or version as arg
# Content related
my $body_70 = $sccs->body (); # file.pl @70 incl NL's
my @body_70 = $sccs->body (); # file.pl @70 list of chomped lines
my @body_69 = $sccs->body (69); # same for file.pl at revision 69
my @body_69 = $sccs->body ("5.38"); # same
$sccs->set_translate ("SCCS");
print $sccs->translate ($rev, $line);
-- NYI --
my $diff = $sccs->diff (67); # unified diff between rev 67 and 70
my $diff = $sccs->diff (63, "5.37");# unified diff between rev 63 and 68
=head1 DESCRIPTION
SCCS was the dominant version control system until the release of the
Revision Control System. Today, SCCS is generally considered obsolete.
However, its file format is still used internally by a few other revision
control programs, including BitKeeper and TeamWare. Sablime[1] also allows
the use of SCCS files. The SCCS file format uses a storage technique called
interleaved deltas (or the weave). This storage technique is now considered
by many revision control system developers as key to some advanced merging
techniques, such as the "Precise Codeville" ("pcdv") merge.
( run in 1.788 second using v1.01-cache-2.11-cpan-71847e10f99 )