File Coverage

blib/lib/VCS/SCCS.pm

Criterion	Covered	Total	%
statement	175	177	98.8
branch	86	104	82.6
condition	10	17	58.8
subroutine	20	20	100.0
pod	14	14	100.0
total	305	332	91.8

#!/pro/bin/perl

# Copyright (c) 2007-2020 H.Merijn Brand.  All rights reserved.

package VCS::SCCS;

use strict;
use warnings;

use POSIX  qw(mktime);
use Carp;

use vars qw( $VERSION );
$VERSION = "0.26";

### ###########################################################################

# 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
    $rev or return $self->{current}[1];

    # $self->revision (12) returns version for that revision
    exists $self->{delta}{$rev} and
	return $self->{delta}{$rev}{version};

    return;
    } # version

sub revision {
    my ($self, $vsn) = @_;
    $self->{current} or return;

    # $self->revision () returns most recent revision
    $vsn or return $self->{current}[0];

    # $self->revision (12) returns version for that revision
    exists $self->{vsn}{$vsn} and
	return $self->{vsn}{$vsn};

    return;
    } # revision

sub revision_map {
    my $self = shift;
    $self->{current} or return;

    return [ map { [ $_ => $self->{delta}{$_}{version} ] }
	sort { $a <=> $b }
	    keys %{$self->{delta}} ];
    } # revision

my %tran = (
    SCCS	=> {	# Documentation only
	},
    RCS		=> {
#	"%W%[ \t]*%G%"			=> '$""Id""$',
#	"%W%[ \t]*%E%"			=> '$""Id""$',
#	"%W%"				=> '$""Id""$',
#	"%Z%%M%[ \t]*%I%[ \t]*%G%"	=> '$""SunId""$',
#	"%Z%%M%[ \t]*%I%[ \t]*%E%"	=> '$""SunId""$',
#	"%M%[ \t]*%I%[ \t]*%G%"		=> '$""Id""$',
#	"%M%[ \t]*%I%[ \t]*%E%"		=> '$""Id""$',
#	"%M%"				=> '$""RCSfile""$',
#	"%I%"				=> '$""Revision""$',
#	"%G%"				=> '$""Date""$',
#	"%E%"				=> '$""Date""$',
#	"%U%"				=> '',
	},
    );

sub set_translate {
    my ($self, $type) = @_;

    if (ref $type eq "HASH") {
	$self->{tran} = "CUSTOM";
	$tran{CUSTOM} = $type;
	}
    elsif (exists $tran{uc $type}) {
	$self->{tran} = uc $type;
	}
    else {
	$self->{tran} = undef;
	}
    } # set_translate

sub _tran {
    my ($self, $line) = @_;
    my $tt = $self->{tran} or return $line;
    my $tr = $tran{$tt}    or return $line;
    my $re = $tr->{re};
    $line =~ s{($re)}{$tr->{$1}}g;
    return $line;
    } # _tran

sub translate {
    my ($self, $rev, $line) = @_;

    my $type = $self->{tran}    or return $line;
    exists $self->{delta}{$rev} or return $line;

    (my $def_M = $self->file ()) =~ s{.*/}{};

    # TODO (or don't): %D%, %H%, %T%, %G%, %F%, %P%, %C%
    my %delta = %{$self->delta ($rev)};
    my $I = $delta{version};
    my $Z = "@(#)";
    my $M = exists $self->{flags}{"m"} ? $self->{flags}{"m"} : $def_M;
    my $Q = exists $self->{flags}{"q"} ? $self->{flags}{"q"} : "";
    my $Y = exists $self->{flags}{"t"} ? $self->{flags}{"t"} : "";
    $tran{SCCS}{"%U%"} = $delta{"time"};
    $tran{SCCS}{"%E%"} = $delta{"date"};
    $tran{SCCS}{"%R%"} = $delta{"release"};
    $tran{SCCS}{"%L%"} = $delta{"level"};
    $tran{SCCS}{"%B%"} = $delta{"branch"};
    $tran{SCCS}{"%S%"} = $delta{"sequence"};
    $tran{SCCS}{"%I%"} = $I;
    $tran{SCCS}{"%Z%"} = $Z;
    $tran{SCCS}{"%M%"} = $M;
    $tran{SCCS}{"%W%"} = "$Z$M\t$I";
    $tran{SCCS}{"%A%"} = "$Z$Y $M $I$Z";
    $tran{SCCS}{"%Q%"} = $Q;
    $tran{SCCS}{"%Y%"} = $Y;

    unless (exists $tran{$type}{re}) {
	my $kw = join "|", reverse sort keys %{$tran{$type}};
	$tran{$type}{re} = $kw ? qr{$kw} : undef;
	}

    return $self->_tran ($line);
    } # translate

sub body {
    my $self = shift;

    $self->{body} && $self->{current} or return;
    my $r = shift || $self->{current}[0];

    exists $self->{vsn}{$r} and $r = $self->{vsn}{$r};

    my @lvl = ([ 1, "I", 0 ]);
    my @body;

#   my $v = sub {
#	join " ", map { sprintf "%s:%02d", $_->[1], $_->[2] } @lvl[1..$#lvl];
#	}; # v

    $self->translate ($r, "");	# Initialize translate hash

    my $want = 1;
    for (@{$self->{body}}) {
	if (m/^\cAE\s+(\d+)$/) {
	    my $e = $1;
#	    print STDERR $v->(), " END $e (@{$lvl[-1]})\n";
	    # SCCS has a seriously ill design so that chunks can overlap
	    # Below example is from actual code
	    # D 9
	    # E 9
	    # 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, [ $r >= $1 ? 1 : 0, "I", $1 ];
	    $want = (grep { $_->[0] == 0 } @lvl) ? 0 : 1;
	    next;
	    }
	if (m/^\cAD\s+(\d+)$/) {
	    push @lvl, [ $r >= $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__