ossp-pkg/cvsfusion/RCS.pm
1.3
##
## OSSP cvsfusion - CVS Repository Fusion
## Copyright (c) 2004 Ralf S. Engelschall <rse@engelschall.com>
## Copyright (c) 2004 The OSSP Project <http://www.ossp.org/>
## Copyright (c) 2004 Cable & Wireless <http://www.cw.com/>
##
## This file is part of OSSP cvsfusion, a CVS repository fusion
## utility which can be found at http://www.ossp.org/pkg/tool/cvsfusion/.
##
## Permission to use, copy, modify, and distribute this software for
## any purpose with or without fee is hereby granted, provided that
## the above copyright notice and this permission notice appear in all
## copies.
##
## THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED
## WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
## MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
## IN NO EVENT SHALL THE AUTHORS AND COPYRIGHT HOLDERS AND THEIR
## CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
## SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
## LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
## USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
## OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
## OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
## SUCH DAMAGE.
##
## RCS.pm: RCS file handling
##
package RCS;
require 5;
require Exporter;
use Carp;
use IO::File;
@ISA = qw(Exporter);
@EXPORT_OK = qw(new destroy DESTROY dump);
sub new ($) {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
bless ($self, $class);
$self->{'tool'} = {
'rcs' => 'rcs',
'co' => 'co',
'diff' => 'diff',
};
$self->{'rcs'} = {};
return $self;
}
sub destroy ($) {
my $self = shift;
return;
}
sub DESTROY ($) {
my $self = shift;
$self->destroy;
return;
}
sub dump ($;$) {
my $self = shift;
my $name = shift || "xxx";
eval {
use Data::Dumper;
};
my $d = new Data::Dumper ([$self], [$name]);
$d->Indent(1);
$d->Purity(1);
$d->Terse(0);
$d->Deepcopy(0);
my $dump = "# " . ref($self) . " object dump:\n";
$dump .= $d->Dump();
return $dump;
}
sub tool ($;$) {
my $self = shift;
my ($tool, $path) = @_;
my $old = $self->{'tool'}->{$tool};
if (not defined($old)) {
croak "tool \"$tool\" not known";
}
if (defined($path)) {
$self->{'tool'}->{$tool} = $path;
}
return $old;
}
# quote/unquote a RCS string
sub _string_quote {
my ($str) = @_;
$str =~ s|\@|\@\@|sg;
$str = '@' . $str . '@';
return $str;
}
sub _string_unquote {
my ($str) = @_;
$str =~ s|^\@(.*)\@$|$1|s;
$str =~ s|\@\@|\@|sg;
return $str;
}
sub load ($$) {
my $self = shift;
my ($file) = @_;
# read RCS file into buffer
my $io = new IO::File "<$file"
or croak "RCS file \"$file\": cannot open for reading";
my $rcs = '';
$rcs .= $_ while (<$io>);
$io->close;
# clear RCS structure
$self->{'rcs'} = {
'header' => { -order => [] },
'delta' => { -order => [] },
};
# pre-generate reusable regular expressions
my $re_num = qr/[\d.]+/;
my $re_rev = qr/\d+(?:\.\d+)*/;
my $re_special = qr/[$,.:;@]/;
my $re_idchar = qr/[^$,.:;@]/;
my $re_id = qr/(?:${re_num})?${re_idchar}+(?:${re_idchar}|${re_num})*/;
my $re_sym = qr/\d?${re_idchar}+(?:${re_idchar}|\d)*/;
my $re_str = qr/(?:@@|[^@])*/;
my $re_date = qr/\d{4}\.\d{2}\.\d{2}\.\d{2}\.\d{2}\.\d{2}/;
# parse header section
while (1) {
$rcs =~ s|^\s*||s;
if ($rcs =~ s/^head\s+($re_rev)\s*;//s) {
$self->{'rcs'}->{'header'}->{'head'} = $1;
push(@{$self->{'rcs'}->{'header'}->{-order}}, 'head');
}
elsif ($rcs =~ s/^branch\s+($re_rev)\s*;//s) {
$self->{'rcs'}->{'header'}->{'branch'} = $1;
push(@{$self->{'rcs'}->{'header'}->{-order}}, 'branch');
}
elsif ($rcs =~ s/^access((?:\s+$re_id)*)\s*;//s) {
$self->{'rcs'}->{'header'}->{'access'} = [ split(/\s+/, $1) ];
push(@{$self->{'rcs'}->{'header'}->{-order}}, 'access');
}
elsif ($rcs =~ s/^symbols((?:\s+$re_sym:$re_rev)*)\s*;//s) {
my $symbols = { -order => [] };
map { if (m/^(.+):(.+)$/s) {
$symbols->{$1} = $2;
push(@{$symbols->{-order}}, $1);
} } split(/\s+/, $1);
$self->{'rcs'}->{'header'}->{'symbols'} = $symbols;
push(@{$self->{'rcs'}->{'header'}->{-order}}, 'symbols');
}
elsif ($rcs =~ s/^locks((?:\s+$re_id:$re_rev)*)\s*;//s) {
my $locks = { -order => [] };
map { if (m/^(.+):(.+)$/s) {
$locks->{$1} = $2;
push(@{$locks->{-order}}, $1);
} } split(/\s+/, $1);
$self->{'rcs'}->{'header'}->{'locks'} = $locks;
push(@{$self->{'rcs'}->{'header'}->{-order}}, 'locks');
}
elsif ($rcs =~ s/^strict\s*;//s) {
$self->{'rcs'}->{'header'}->{'strict'} = "";
push(@{$self->{'rcs'}->{'header'}->{-order}}, 'strict');
}
elsif ($rcs =~ s/^comment\s+\@($re_str)\@\s*;//s) {
$self->{'rcs'}->{'header'}->{'comment'} = &_string_unquote($1);
push(@{$self->{'rcs'}->{'header'}->{-order}}, 'comment');
}
elsif ($rcs =~ s/^expand\s+\@($re_str)\@\s*;//s) {
$self->{'rcs'}->{'header'}->{'expand'} = &_string_unquote($1);
push(@{$self->{'rcs'}->{'header'}->{-order}}, 'expand');
}
elsif ($rcs =~ s/^([a-z]+)(\s*[^;]*);//s) {
$self->{'rcs'}->{'header'}->{$1} = $2;
push(@{$self->{'rcs'}->{'header'}->{-order}}, $1);
}
else {
last;
}
}
# parse delta section(s)
while (1) {
$rcs =~ s|^\s*||s;
if ($rcs =~ s/^($re_rev)//s) {
my $rev = $1;
$self->{'rcs'}->{'delta'}->{$rev} = {};
push(@{$self->{'rcs'}->{'delta'}->{-order}}, $rev);
while (1) {
$rcs =~ s|^\s*||s;
if ($rcs =~ s/^date\s+($re_date)\s*;//s) {
$self->{'rcs'}->{'delta'}->{$rev}->{'date'} = $1;
}
elsif ($rcs =~ s/^author\s+($re_id)\s*;//s) {
$self->{'rcs'}->{'delta'}->{$rev}->{'author'} = $1;
}
elsif ($rcs =~ s/^state(?:\s*($re_id))?\s*;//s) {
$self->{'rcs'}->{'delta'}->{$rev}->{'state'} = $1;
}
elsif ($rcs =~ s/^branches(?:\s+((?:\s*$re_rev)*))?\s*;//s) {
$self->{'rcs'}->{'delta'}->{$rev}->{'branches'} = [ split(/\s+/, $1) ];
}
elsif ($rcs =~ s/^next(?:\s*($re_rev))?\s*;//s) {
$self->{'rcs'}->{'delta'}->{$rev}->{'next'} = $1;
}
elsif ($rcs =~ m/^desc\s+/s) {
last;
}
elsif ($rcs =~ s/^([a-z]+)(\s*[^;]*);//s) {
$self->{'rcs'}->{'delta'}->{$rev}->{$1} = $2;
}
else {
last;
}
}
}
else {
last;
}
}
# parse description section
$rcs =~ s|^\s*||s;
if ($rcs =~ s/^desc\s+\@($re_str)\@\s*//s) {
$self->{'rcs'}->{'header'}->{'desc'} = $1;
push(@{$self->{'rcs'}->{'header'}->{-order}}, 'desc');
}
# parse deltatext section(s)
while (1) {
$rcs =~ s|^\s*||s;
if ($rcs =~ s/^($re_rev)//s) {
my $rev = $1;
if (not defined($self->{'rcs'}->{'delta'}->{$rev})) {
croak "deltatext section for unknown revision \"$rev\" found";
}
my $textseen = 0;
while (1) {
$rcs =~ s|^\s*||s;
if ($rcs =~ s/^log\s+\@($re_str)\@\s*//s) {
$self->{'rcs'}->{'delta'}->{$rev}->{'log'} = &_string_unquote($1);
}
elsif ($rcs =~ s/^text\s+\@($re_str)\@\s*//s) {
$self->{'rcs'}->{'delta'}->{$rev}->{'text'} = &_string_unquote($1);
$textseen = 1;
}
elsif ($textseen == 0 and $rcs =~ s/^([a-z]+)(\s*[^;]*);//s) {
$self->{'rcs'}->{'delta'}->{$rev}->{$1} = $2;
}
else {
last;
}
}
}
else {
last;
}
}
return;
}
sub save ($$) {
my $self = shift;
my ($file) = @_;
my $rcs = '';
# define known keywords
my @kw_header = (qw(head branch access symbols locks- strict comment@ expand@));
my @kw_delta = (qw(date author state branches next));
my @kw_desc = (qw(desc));
my @kw_deltatext = (qw(log text));
# generate header section
foreach my $header (
@kw_header,
( grep { not grep(/^\Q$_\E$/, @kw_header) }
@{$self->{'rcs'}->{'header'}->{-order}} )
) {
my $tag = '';
$tag = $1 if ($header =~ s/([@\-])$//s);
my $val = $self->{'rcs'}->{'header'}->{$header};
if (defined($val)) {
$rcs .= $header;
if (ref($val) eq 'ARRAY') {
if (@{$val} > 0) {
foreach my $v (@{$val}) {
$rcs .= "\n\t$v";
}
}
}
elsif (ref($val) eq 'HASH') {
if (keys(%{$val}) > 0) {
if (defined($val->{-order})) {
foreach my $v (@{$val->{-order}}) {
$rcs .= sprintf("\n\t%s:%s", $v, $val->{$v});
}
}
else {
foreach my $v (keys(%{$val})) {
$rcs .= sprintf("\n\t%s:%s", $v, $val->{$v});
}
}
}
}
else {
if ($val ne '') {
if ($tag eq '@') {
$rcs .= "\t" . &_string_quote($val);
}
else {
$rcs .= "\t$val";
}
}
}
$rcs .= ";";
$rcs .= ($tag eq '-' ? " " : "\n");
}
}
$rcs .= "\n";
# generate delta section(s)
sub revlist ($$) {
my ($self, $branchfirst) = @_;
my @revs = ();
&nextrev(\@revs, $self->{'rcs'}->{'header'}->{'head'}, $branchfirst);
sub nextrev ($$$) {
my ($revs, $rev, $branchfirst) = @_;
push(@{$revs}, $rev);
my $next = $self->{'rcs'}->{'delta'}->{$rev}->{'next'};
my $branches = $self->{'rcs'}->{'delta'}->{$rev}->{'branches'};
if ($branchfirst) {
foreach my $branch (@{$branches}) {
&nextrev($revs, $branch, $branchfirst);
}
if (defined($next) and $next ne '') {
&nextrev($revs, $next, $branchfirst);
}
}
else {
if (defined($next) and $next ne '') {
&nextrev($revs, $next, $branchfirst);
}
foreach my $branch (@{$branches}) {
&nextrev($revs, $branch, $branchfirst);
}
}
return;
}
return @revs;
}
my @revlist = &revlist($self, 0);
foreach my $rev (@revlist) {
my $delta = $self->{'rcs'}->{'delta'}->{$rev};
$rcs .= "\n";
$rcs .= $rev."\n";
$rcs .= "date\t" . $delta->{'date'} . ";\t";
$rcs .= "author " . $delta->{'author'} . ";\t";
$rcs .= "state " . $delta->{'state'} . ";\n";
$rcs .= "branches";
if (@{$delta->{'branches'}} > 0) {
foreach my $v (@{$delta->{'branches'}}) {
$rcs .= "\n\t$v";
}
}
$rcs .= ";\n";
$rcs .= "next\t" . $delta->{'next'} . ";\n";
}
# generate description section
my $desc = $self->{'rcs'}->{'header'}->{'desc'};
$rcs .= "\n\ndesc\n" . &_string_quote($desc) . "\n";
# generate deltatext section(s)
@revlist = &revlist($self, 1);
foreach my $rev (@revlist) {
my $delta = $self->{'rcs'}->{'delta'}->{$rev};
$rcs .= "\n";
$rcs .= "\n";
$rcs .= $rev."\n";
$rcs .= "log\n" . &_string_quote($delta->{'log'}) . "\n";
$rcs .= "text\n" . &_string_quote($delta->{'text'}) . "\n";
}
# write new RCS file for disk
my $io = new IO::File ">$file"
or croak "RCS file \"$file\": cannot open for writing";
$io->print($rcs);
$io->close;
return;
}
__END__
=pod
=head1 NAME
B<RCS> -- Revision Control System (RCS) File Handling
=head1 DESCRIPTION
...FIXME...
=cut
