Index: ossp-pkg/cvsfusion/RCS.pm
RCS File: /v/ossp/cvs/ossp-pkg/cvsfusion/RCS.pm,v
rcsdiff -q -kk '-r1.3' '-r1.4' -u '/v/ossp/cvs/ossp-pkg/cvsfusion/RCS.pm,v' 2>/dev/null
--- 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