--- RCS.pm 2004/04/23 12:21:44 1.3
+++ RCS.pm 2004/04/23 13:09:50 1.4
@@ -38,12 +38,16 @@
@ISA = qw(Exporter);
@EXPORT_OK = qw(new destroy DESTROY dump);
-sub new ($) {
- my $proto = shift;
+# 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',
@@ -51,23 +55,30 @@
};
$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 = shift;
+ my ($self) = @_;
return;
}
+# destroy object (implicit destructor)
sub DESTROY ($) {
- my $self = shift;
+ my ($self) = @_;
$self->destroy;
return;
}
+# dump object internals (debugging only)
sub dump ($;$) {
- my $self = shift;
- my $name = shift || "xxx";
+ my ($self, $name) = @_;
+ $name ||= "rcs";
eval {
use Data::Dumper;
};
@@ -81,9 +92,9 @@
return $dump;
}
+# get and/or set paths to external tools
sub tool ($;$) {
- my $self = shift;
- my ($tool, $path) = @_;
+ my ($self, $tool, $path) = @_;
my $old = $self->{'tool'}->{$tool};
if (not defined($old)) {
croak "tool \"$tool\" not known";
@@ -94,13 +105,15 @@
return $old;
}
-# quote/unquote a RCS string
+# 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;
@@ -108,9 +121,9 @@
return $str;
}
+# load an RCS file into object
sub load ($$) {
- my $self = shift;
- my ($file) = @_;
+ my ($self, $file) = @_;
# read RCS file into buffer
my $io = new IO::File "<$file"
@@ -119,6 +132,17 @@
$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 => [] },
@@ -266,12 +290,88 @@
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 = shift;
- my ($file) = @_;
+ 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
@@ -290,75 +390,14 @@
$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 .= $header . &_genvalue($val, $tag). ";";
$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);
+ my @revlist = &_revlist($self, 0);
foreach my $rev (@revlist) {
my $delta = $self->{'rcs'}->{'delta'}->{$rev};
$rcs .= "\n";
@@ -381,7 +420,7 @@
$rcs .= "\n\ndesc\n" . &_string_quote($desc) . "\n";
# generate deltatext section(s)
- @revlist = &revlist($self, 1);
+ @revlist = &_revlist($self, 1);
foreach my $rev (@revlist) {
my $delta = $self->{'rcs'}->{'delta'}->{$rev};
$rcs .= "\n";
@@ -391,13 +430,7 @@
$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;
+ return $rcs;
}
__END__
@@ -410,7 +443,65 @@
=head1 DESCRIPTION
-...FIXME...
+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
|
