ossp-pkg/cvsfusion/RCS.pm
1.2
##
## 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;
}
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 = {};
map { $symbols->{$1} = $2 if (m/^(.+):(.+)$/s); } 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 = {};
map { $locks->{$1} = $2 if (m/^(.+):(.+)$/); } 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'} = $1;
push(@{$self->{'rcs'}->{'header'}->{-order}}, 'comment');
}
elsif ($rcs =~ s/^expand\s+\@($re_str)\@\s*;//s) {
$self->{'rcs'}->{'header'}->{'expand'} = $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'} = $1;
}
elsif ($rcs =~ s/^text\s+\@($re_str)\@\s*//s) {
$self->{'rcs'}->{'delta'}->{$rev}->{'text'} = $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) {
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) {
foreach my $v (keys(%{$val})) {
$rcs .= sprintf("\n\t%s:%s", $v, $val->{$v});
}
}
}
else {
if ($val ne '') {
if ($tag eq '@') {
$val =~ s|\@|\@\@|sg;
$rcs .= "\t\@$val\@";
}
else {
$rcs .= "\t$val";
}
}
}
$rcs .= ";";
$rcs .= ($tag eq '-' ? " " : "\n");
}
}
$rcs .= "\n";
# generate delta section(s)
foreach my $rev (@{$self->{'rcs'}->{'delta'}->{-order}}) {
my $delta = $self->{'rcs'}->{'delta'}->{$rev};
$rcs .= $rev."\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