--- RCS.pm 2004/04/22 06:56:28 1.1
+++ RCS.pm 2004/04/23 09:23:38 1.2
@@ -32,6 +32,8 @@
require 5;
require Exporter;
+use Carp;
+use IO::File;
@ISA = qw(Exporter);
@EXPORT_OK = qw(new destroy DESTROY dump);
@@ -42,8 +44,12 @@
my $self = {};
bless ($self, $class);
- $self->{'prog-rcs'} = "";
- $self->{'prog-diff'} = "";
+ $self->{'tool'} = {
+ 'rcs' => 'rcs',
+ 'co' => 'co',
+ 'diff' => 'diff',
+ };
+ $self->{'rcs'} = {};
return $self;
}
@@ -75,6 +81,238 @@
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
|
