ossp-pkg/cvsfusion/RCS.pm
1.4
##
## 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);
# create new object
sub new ($;$) {
my ($proto, $file) = @_;
# create new object
my $class = ref($proto) || $proto;
my $self = {};
bless ($self, $class);
# initialize object
$self->{'tool'} = {
'rcs' => 'rcs',
'co' => 'co',
'diff' => 'diff',
};
$self->{'rcs'} = {};
# optionally load file into object
$rcs->load($file) if (defined($file));
# return new object
return $self;
}
# destroy object (explicit destructor)
sub destroy ($) {
my ($self) = @_;
return;
}
# destroy object (implicit destructor)
sub DESTROY ($) {
my ($self) = @_;
$self->destroy;
return;
}
# dump object internals (debugging only)
sub dump ($;$) {
my ($self, $name) = @_;
$name ||= "rcs";
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;
}
# get and/or set paths to external tools
sub tool ($;$) {
my ($self, $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;
}
# INTERNAL: quote a RCS string
sub _string_quote {
my ($str) = @_;
$str =~ s|\@|\@\@|sg;
$str = '@' . $str . '@';
return $str;
}
# INTERNAL: unquote a RCS string
sub _string_unquote {
my ($str) = @_;
$str =~ s|^\@(.*)\@$|$1|s;
$str =~ s|\@\@|\@|sg;
return $str;
}
# load an RCS file into object
sub load ($$) {
my ($self, $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;
# parse RCS file content into object
$self->parse($rcs);
return;
}
# parse a RCS file content into object
# (see rcsfile(5) for reference)
sub parse ($$) {
my ($self, $rcs) = @_;
# 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;
}
# INTERNAL: return ordered list of revisions
# (either in branch-first or next-first traversal order)
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);
}
&nextrev($revs, $next, $branchfirst) if (defined($next) and $next ne '');
}
else {
&nextrev($revs, $next, $branchfirst) if (defined($next) and $next ne '');
foreach my $branch (@{$branches}) {
&nextrev($revs, $branch, $branchfirst);
}
}
return;
}
return @revs;
}
# INTERNAL: generate output of a value in RCS syntax and layout
sub _genvalue ($$) {
my ($val, $tag) = @_;
my $rcs = '';
if (ref($val) eq 'ARRAY' and @{$val} > 0) {
foreach my $v (@{$val}) {
$rcs .= "\n\t$v";
}
}
elsif (ref($val) eq 'HASH' and 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});
}
}
}
elsif (not ref($val) and $val ne '') {
if ($tag eq '@') {
$rcs .= "\t" . &_string_quote($val);
}
else {
$rcs .= "\t$val";
}
}
return $rcs;
}
# save object into RCS file
# (see rcsfile(5) for reference)
sub save ($$) {
my ($self, $file) = @_;
# format object as RCS file content
my $rcs = $self->format();
# write RCS file content to RCS file
my $io = new IO::File ">$file"
or croak "RCS file \"$file\": cannot open for writing";
$io->print($rcs);
$io->close;
}
# format object as RCS file content
sub format ($) {
my ($self) = @_;
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 . &_genvalue($val, $tag). ";";
$rcs .= ($tag eq '-' ? " " : "\n");
}
}
$rcs .= "\n";
# generate delta section(s)
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";
}
return $rcs;
}
__END__
=pod
=head1 NAME
B<RCS> -- Revision Control System (RCS) File Handling
=head1 DESCRIPTION
This is a Perl API for reading and writing RCS files (I<filename>C<,v>).
It understands the syntax as documented in rcsfile(5) of GNU RCS version
5.7. It tries hard to save RCS files in a determined internal keyword
and revision order.
=head1 METHODS
=over 4
=item C<my $rcs = >B<new>C< RCS>[C< $filename>]C<;>
This creates a new RCS object and (for convinience reasons) optionally
loads an RCS file via C<$rcs-E<gt>>B<load>C<($filename)> into it.
=item C<$rcs-E<gt>>B<destroy>C<;>
=item C<undef $rcs;>
This destroys the RCS object.
=item [C<my $old_path = >]C<$rcs-E<gt>>B<tool>C<(">I<tool>C<", $path);>
=item C<my $path = $rcs-E<gt>>B<tool>C<(">I<tool>C<");>
This sets and/or gets the path to the external command I<tool>. Used
I<tool>s are C<rcs>, C<co> and C<diff> from GNU RCS and GNU DiffUtils.
=item C<$rcs-E<gt>>B<parse>C<($filename, $rcstext);>
This parses the RCS file content in C<$rcstext> and
and stores the result in RCS object C<$rcs>.
=item C<my $rcstext = $rcs-E<gt>>B<format>C<($filename);>
This formats and returns the RCS file content in C<$rcs>.
=item C<$rcs-E<gt>>B<load>C<($filename);>
This loads the RCS file under C<$filename> into RCS object C<$rcs>.
=item C<$rcs-E<gt>>B<save>C<($filename);>
This saves the RCS file content from RCS object C<$rcs> under C<$filename>.
=back
=head1 SEE ALSO
rcsfile(5).
=head1 HISTORY
The Perl B<RCS> module was implemented in April 2004 for use in B<OSSP
cvsfusion> in order to support the fusion of two CVS repositories on the
RCS file level.
=head1 AUTHOR
Ralf S. Engelschall E<lt>rse@engelschall.comE<gt>
=cut
