tool/lib/RCSFormat.pm


=head1 NAME

RCSFormat - Low-level Interface to RCS Format

=head1 DESCRIPTION

RCS format is widely used to manage revision history of files by tools such as
RCS and CVS.  This module provides some low-level interface to RCS format.

=cut

package RCSFormat;
use strict;
our $VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};

sub new ($;%) {
  my $self = bless {}, shift;
  $self;
}

{
my $WSP = qr/[\x08-\x0D\x20]+/;
my $NUM = qr/[0-9.]+/;
my $IDNONUM = qr/[^\x08-\x0D\x200-9\$,:;\@]+/;
my $SYM = qr/[^\x08-\x0D\x20\$,.:;\@]+/;
my $STR = qr/\@[^\@]*(?>[^\@]+|\@\@)*\@/;
sub parse_text ($$;%) {
  my ($self, $s) = @_;
  $s = \$_[1] unless ref $s;
  delete $self->{admin};
  delete $self->{desc};
  delete $self->{delta};
  
  $$s =~ /\G$WSP/gco;
  ## admin
  $self->___parse_fields ($s, hash => $self->{admin} ||= {}, context => 'admin');
  $self->{admin}->{access} ||= [];
  $self->{admin}->{symbols} ||= [];
  $self->{admin}->{locks} ||= [];
  
  ## delta
  unless (exists $self->{desc}) {
  while ($$s =~ /\G($NUM)/gco) {
    my $rev = $1;
    $$s =~ /\G$WSP/gco;
    $self->___parse_fields ($s, hash => $self->{delta}->{$rev} ||= {}, context => qq'delta[$rev]');
    $self->{delta}->{$rev}->{branches} ||= [];
    last if exists $self->{desc};
  }}
  
  ## deltatext
  while ($$s =~ /\G($NUM)/gco) {
    my $rev = $1;
    $$s =~ /\G$WSP/gco;
    $self->___parse_fields ($s, hash => $self->{deltatext}->{$rev} ||= {}, context => qq'deltatext[$rev]');
  }
}

sub ___parse_fields ($$%) {
  my ($self, $s, %opt) = @_;
  while ($$s =~ /\G((?>$NUM)?$IDNONUM(?>$IDNONUM|$NUM)*)/gco) {
    my $keyword = $1;
    $$s =~ /\G$WSP/gco;
    if ({qw/desc 1 log 1 text 1/}->{$keyword}) {
      warn "$opt{cotnext}/$keyword: invalid" if $keyword eq 'desc' and exists $self->{$keyword};
      if ($$s =~ /\G($STR)/gco) {
        my $t = $1;
        $t =~ s/^\@//;
        $t =~ s/\@$//;
        $t =~ s/\@\@/\@/g;
        ($keyword eq 'desc' ? $self->{desc} : $opt{hash}->{$keyword}) = $t;
      } else {
        warn "$keyword: value required";
        ($keyword eq 'desc' ? $self->{desc} : $opt{hash}->{$keyword}) = "";
      }
      $$s =~ /\G$WSP/gco;
      ($keyword eq 'desc' ? return : next);
    } elsif ($$s =~ /\G([^;\@]*(?>[^;\@]+|$STR)*)/gco) {
      my $val = $1;
      $val =~ /$WSP$/o;
      if (exists $opt{hash}->{$keyword}) {
        warn "$opt{context}/$keyword: duplicate";
      }
      $opt{hash}->{$keyword} = length $val ? $val : undef;
    } else {
      $opt{hash}->{$keyword} = undef;
    }
    if ({qw/symbols 1 locks 1/}->{$keyword}) {
      $opt{hash}->{$keyword} = [map {[split /(?:$WSP)?:(?:$WSP)?/]} split m#$WSP#o, $opt{hash}->{$keyword}];
    } elsif ({qw/comment 1 expand 1/}->{$keyword}) {
      $opt{hash}->{$keyword} =~ s/^\@//;
      $opt{hash}->{$keyword} =~ s/\@$//;
      $opt{hash}->{$keyword} =~ s/\@\@/\@/g;
    } elsif ({qw/access 1 branches 1/}->{$keyword}) {
      $opt{hash}->{$keyword} = [split m#$WSP#o, $opt{hash}->{$keyword}];
    }
    if ($$s =~ /\G[^;]+/gc) {
      warn "$opt{context}/$keyword: extra data";
    }
    $$s =~ /\G;/gc or warn "$opt{context}/$keyword: semicoron required";
    $$s =~ /\G$WSP/gco;
  }
}
}

sub stringify ($;%) {
  my $self = shift;
  my $s = '';
  
  ## admin
  $s .= qq(head )
     .  $self->___stringify_value ($self->{admin}->{head}, type => 'number',
                                   min => 0, max => 1)
     .  ";\x0A";
  if (exists $self->{admin}->{branch}) {
    $s .= qq(branch     )
       .  $self->___stringify_value ($self->{admin}->{branch}, type => 'num',
                                     min => 0, max => 1)
       .  ";\x0A";
  }
  $s .= qq(access       )
     .  $self->___stringify_value ($self->{admin}->{access}, type => 'id',
                                   min => 0, max => -1)
     .  ";\x0A";
  $s .= qq(symbols);
  for (@{$self->{admin}->{symbols}}) {
     $s .= "\x0A\t"
        .  $self->___stringify_value ($_->[0], type => 'sym',
                                      min => 1, max => 1)
        .  ':'
        .  $self->___stringify_value ($_->[1], type => 'num',
                                      min => 1, max => 1);
  }
  $s .= ";\x0A";
  $s .= qq(locks);
  for (@{$self->{admin}->{locks}}) {
     $s .= "\x0A\t"
        .  $self->___stringify_value ($_->[0], type => 'id',
                                      min => 1, max => 1)
        .  ':'
        .  $self->___stringify_value ($_->[1], type => 'num',
                                      min => 1, max => 1);
  }
  $s .= ";";
  $s .= " strict;" if exists $self->{admin}->{strict};
  $s .= "\x0A";
  if (exists $self->{admin}->{comment}) {
    $s .= qq(comment    )
       .  $self->___stringify_value ($self->{admin}->{comment}, type => 'str',
                                     min => 0, max => 1)
       .  ";\x0A";
  }
  if (exists $self->{admin}->{expand}) {
    $s .= qq(expand     )
       .  $self->___stringify_value ($self->{admin}->{expand}, type => 'str',
                                     min => 0, max => 1)
       .  ";\x0A";
  }
  for (grep !{qw/head 1 branch 1 access 1 symbols 1 locks 1 strict 1 comment 1 expand 1/}->{$_},
       keys %{$self->{admin}}) {
    $s .= qq($_ )
       .  $self->___stringify_value ($self->{admin}->{$_})
       .  ";\x0A";
  }
  
  ## delta
  for my $rev ($self->sort_by_revision (keys %{$self->{delta}})) {
    $s .= "\x0A\x0A$rev\x0A";
    $s .= qq(date       )
       .  $self->___stringify_value ($self->{delta}->{$rev}->{date}, type => 'num',
                                     min => 1, max => 1)
       .  ";\t";
    $s .= qq(author )
       .  $self->___stringify_value ($self->{delta}->{$rev}->{author}, type => 'id',
                                     min => 1, max => 1)
       .  ";\t";
    $s .= qq(state )
       .  $self->___stringify_value ($self->{delta}->{$rev}->{state}, type => 'id',
                                     min => 0, max => 1)
       .  ";\x0A";
    $s .= qq(branches)
       .  $self->___stringify_value ($self->{delta}->{$rev}->{branches}, type => 'num',
                                     min => 0, max => -1)
       .  ";\x0A";
    $s .= qq(next       )
       .  $self->___stringify_value ($self->{delta}->{$rev}->{next}, type => 'num',
                                     min => 0, max => 1)
       .  ";\x0A";
    for (grep !{qw/date 1 author 1 state 1 branches 1 next 1/}->{$_},
         keys %{$self->{delta}->{$rev}}) {
      $s .= qq($_       )
         .  $self->___stringify_value ($self->{delta}->{$rev}->{$_})
         .  ";\x0A";
    }
  }
  
  # desc
  $s .= qq(\x0A\x0Adesc\x0A)
     .  $self->___stringify_value ($self->{desc}, type => 'str',
                                   min => 1, max => 1)
     .  "\x0A";
  
  ## deltatext
  for my $rev ($self->sort_by_revision (keys %{$self->{deltatext}})) {
    $s .= "\x0A\x0A$rev\x0A";
    $s .= qq(log\x0A)
       .  $self->___stringify_value ($self->{deltatext}->{$rev}->{log}, type => 'str',
                                     min => 1, max => 1)
       .  "\x0A";
    $s .= qq(text\x0A)
       .  $self->___stringify_value ($self->{deltatext}->{$rev}->{text}, type => 'str',
                                     min => 1, max => 1)
       .  "\x0A";
    for (grep !{qw/log 1 text 1/}->{$_},
         keys %{$self->{deltatext}->{$rev}}) {
      $s .= qq($_       )
         .  $self->___stringify_value ($self->{deltatext}->{$rev}->{$_})
         .  ";\x0A";
    }
  }
  
  $s;
}

sub ___stringify_value ($$%) {
  my ($self, $s, %opt) = @_;
  if ($opt{type} eq 'str') {
    $s =~ s/\@/\@\@/g;
    return "\@$s\@";
  } elsif ($opt{max} == -1 or $opt{max} > 1) {
    my $t = '';
    for (@{$s}) {
      $t .= "\x0A\t" . $_;
    }
    return $t;
  } else {
    return $s;
  }
}

sub sort_by_revision ($@) {
  shift;
  map {
    $_->[0]
  }
  sort {
    my $r;
    for my $i (0..$#{$a->[1]}) {
      $r = $b->[1]->[$i] <=> $a->[1]->[$i];
      return $r if $r;
    }
    0;
  }
  map {
    [$_, [split /\./, $_]]
  }
  @_;
}

=head1 SEE ALSO

rcsfile(5)

=head1 LICENSE

Copyright 2004 Wakaba <w@suika.fam.cx>.  All rights reserved.

This program is free software; you can redistribute it and/or 
modify it under the same terms as Perl itself.

=cut

1; # $Date:$
1	wakaba	1.1
2			=head1 NAME
3
4			RCSFormat - Low-level Interface to RCS Format
5
6			=head1 DESCRIPTION
7
8			RCS format is widely used to manage revision history of files by tools such as
9			RCS and CVS. This module provides some low-level interface to RCS format.
10
11			=cut
12
13			package RCSFormat;
14			use strict;
15			our $VERSION=do{my @r=(q$Revision: 1.1 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
16
17			sub new ($;%) {
18			my $self = bless {}, shift;
19			$self;
20			}
21
22			{
23			my $WSP = qr/[\x08-\x0D\x20]+/;
24			my $NUM = qr/[0-9.]+/;
25			my $IDNONUM = qr/[^\x08-\x0D\x200-9\$,:;\@]+/;
26			my $SYM = qr/[^\x08-\x0D\x20\$,.:;\@]+/;
27			my $STR = qr/\@[^\@](?>[^\@]+\|\@\@)\@/;
28			sub parse_text ($$;%) {
29			my ($self, $s) = @_;
30			$s = \$_[1] unless ref $s;
31			delete $self->{admin};
32			delete $self->{desc};
33			delete $self->{delta};
34
35			$$s =~ /\G$WSP/gco;
36			## admin
37			$self->___parse_fields ($s, hash => $self->{admin} \|\|= {}, context => 'admin');
38			$self->{admin}->{access} \|\|= [];
39			$self->{admin}->{symbols} \|\|= [];
40			$self->{admin}->{locks} \|\|= [];
41
42			## delta
43			unless (exists $self->{desc}) {
44			while ($$s =~ /\G($NUM)/gco) {
45			my $rev = $1;
46			$$s =~ /\G$WSP/gco;
47			$self->___parse_fields ($s, hash => $self->{delta}->{$rev} \|\|= {}, context => qq'delta[$rev]');
48			$self->{delta}->{$rev}->{branches} \|\|= [];
49			last if exists $self->{desc};
50			}}
51
52			## deltatext
53			while ($$s =~ /\G($NUM)/gco) {
54			my $rev = $1;
55			$$s =~ /\G$WSP/gco;
56			$self->___parse_fields ($s, hash => $self->{deltatext}->{$rev} \|\|= {}, context => qq'deltatext[$rev]');
57			}
58			}
59
60			sub ___parse_fields ($$%) {
61			my ($self, $s, %opt) = @_;
62			while ($$s =~ /\G((?>$NUM)?$IDNONUM(?>$IDNONUM\|$NUM)*)/gco) {
63			my $keyword = $1;
64			$$s =~ /\G$WSP/gco;
65			if ({qw/desc 1 log 1 text 1/}->{$keyword}) {
66			warn "$opt{cotnext}/$keyword: invalid" if $keyword eq 'desc' and exists $self->{$keyword};
67			if ($$s =~ /\G($STR)/gco) {
68			my $t = $1;
69			$t =~ s/^\@//;
70			$t =~ s/\@$//;
71			$t =~ s/\@\@/\@/g;
72			($keyword eq 'desc' ? $self->{desc} : $opt{hash}->{$keyword}) = $t;
73			} else {
74			warn "$keyword: value required";
75			($keyword eq 'desc' ? $self->{desc} : $opt{hash}->{$keyword}) = "";
76			}
77			$$s =~ /\G$WSP/gco;
78			($keyword eq 'desc' ? return : next);
79			} elsif ($$s =~ /\G([^;\@](?>[^;\@]+\|$STR))/gco) {
80			my $val = $1;
81			$val =~ /$WSP$/o;
82			if (exists $opt{hash}->{$keyword}) {
83			warn "$opt{context}/$keyword: duplicate";
84			}
85			$opt{hash}->{$keyword} = length $val ? $val : undef;
86			} else {
87			$opt{hash}->{$keyword} = undef;
88			}
89			if ({qw/symbols 1 locks 1/}->{$keyword}) {
90			$opt{hash}->{$keyword} = [map {[split /(?:$WSP)?:(?:$WSP)?/]} split m#$WSP#o, $opt{hash}->{$keyword}];
91			} elsif ({qw/comment 1 expand 1/}->{$keyword}) {
92			$opt{hash}->{$keyword} =~ s/^\@//;
93			$opt{hash}->{$keyword} =~ s/\@$//;
94			$opt{hash}->{$keyword} =~ s/\@\@/\@/g;
95			} elsif ({qw/access 1 branches 1/}->{$keyword}) {
96			$opt{hash}->{$keyword} = [split m#$WSP#o, $opt{hash}->{$keyword}];
97			}
98			if ($$s =~ /\G[^;]+/gc) {
99			warn "$opt{context}/$keyword: extra data";
100			}
101			$$s =~ /\G;/gc or warn "$opt{context}/$keyword: semicoron required";
102			$$s =~ /\G$WSP/gco;
103			}
104			}
105			}
106
107			sub stringify ($;%) {
108			my $self = shift;
109			my $s = '';
110
111			## admin
112			$s .= qq(head )
113			. $self->___stringify_value ($self->{admin}->{head}, type => 'number',
114			min => 0, max => 1)
115			. ";\x0A";
116			if (exists $self->{admin}->{branch}) {
117			$s .= qq(branch )
118			. $self->___stringify_value ($self->{admin}->{branch}, type => 'num',
119			min => 0, max => 1)
120			. ";\x0A";
121			}
122			$s .= qq(access )
123			. $self->___stringify_value ($self->{admin}->{access}, type => 'id',
124			min => 0, max => -1)
125			. ";\x0A";
126			$s .= qq(symbols);
127			for (@{$self->{admin}->{symbols}}) {
128			$s .= "\x0A\t"
129			. $self->___stringify_value ($_->[0], type => 'sym',
130			min => 1, max => 1)
131			. ':'
132			. $self->___stringify_value ($_->[1], type => 'num',
133			min => 1, max => 1);
134			}
135			$s .= ";\x0A";
136			$s .= qq(locks);
137			for (@{$self->{admin}->{locks}}) {
138			$s .= "\x0A\t"
139			. $self->___stringify_value ($_->[0], type => 'id',
140			min => 1, max => 1)
141			. ':'
142			. $self->___stringify_value ($_->[1], type => 'num',
143			min => 1, max => 1);
144			}
145			$s .= ";";
146			$s .= " strict;" if exists $self->{admin}->{strict};
147			$s .= "\x0A";
148			if (exists $self->{admin}->{comment}) {
149			$s .= qq(comment )
150			. $self->___stringify_value ($self->{admin}->{comment}, type => 'str',
151			min => 0, max => 1)
152			. ";\x0A";
153			}
154			if (exists $self->{admin}->{expand}) {
155			$s .= qq(expand )
156			. $self->___stringify_value ($self->{admin}->{expand}, type => 'str',
157			min => 0, max => 1)
158			. ";\x0A";
159			}
160			for (grep !{qw/head 1 branch 1 access 1 symbols 1 locks 1 strict 1 comment 1 expand 1/}->{$_},
161			keys %{$self->{admin}}) {
162			$s .= qq($_ )
163			. $self->___stringify_value ($self->{admin}->{$_})
164			. ";\x0A";
165			}
166
167			## delta
168			for my $rev ($self->sort_by_revision (keys %{$self->{delta}})) {
169			$s .= "\x0A\x0A$rev\x0A";
170			$s .= qq(date )
171			. $self->___stringify_value ($self->{delta}->{$rev}->{date}, type => 'num',
172			min => 1, max => 1)
173			. ";\t";
174			$s .= qq(author )
175			. $self->___stringify_value ($self->{delta}->{$rev}->{author}, type => 'id',
176			min => 1, max => 1)
177			. ";\t";
178			$s .= qq(state )
179			. $self->___stringify_value ($self->{delta}->{$rev}->{state}, type => 'id',
180			min => 0, max => 1)
181			. ";\x0A";
182			$s .= qq(branches)
183			. $self->___stringify_value ($self->{delta}->{$rev}->{branches}, type => 'num',
184			min => 0, max => -1)
185			. ";\x0A";
186			$s .= qq(next )
187			. $self->___stringify_value ($self->{delta}->{$rev}->{next}, type => 'num',
188			min => 0, max => 1)
189			. ";\x0A";
190			for (grep !{qw/date 1 author 1 state 1 branches 1 next 1/}->{$_},
191			keys %{$self->{delta}->{$rev}}) {
192			$s .= qq($_ )
193			. $self->___stringify_value ($self->{delta}->{$rev}->{$_})
194			. ";\x0A";
195			}
196			}
197
198			# desc
199			$s .= qq(\x0A\x0Adesc\x0A)
200			. $self->___stringify_value ($self->{desc}, type => 'str',
201			min => 1, max => 1)
202			. "\x0A";
203
204			## deltatext
205			for my $rev ($self->sort_by_revision (keys %{$self->{deltatext}})) {
206			$s .= "\x0A\x0A$rev\x0A";
207			$s .= qq(log\x0A)
208			. $self->___stringify_value ($self->{deltatext}->{$rev}->{log}, type => 'str',
209			min => 1, max => 1)
210			. "\x0A";
211			$s .= qq(text\x0A)
212			. $self->___stringify_value ($self->{deltatext}->{$rev}->{text}, type => 'str',
213			min => 1, max => 1)
214			. "\x0A";
215			for (grep !{qw/log 1 text 1/}->{$_},
216			keys %{$self->{deltatext}->{$rev}}) {
217			$s .= qq($_ )
218			. $self->___stringify_value ($self->{deltatext}->{$rev}->{$_})
219			. ";\x0A";
220			}
221			}
222
223			$s;
224			}
225
226			sub ___stringify_value ($$%) {
227			my ($self, $s, %opt) = @_;
228			if ($opt{type} eq 'str') {
229			$s =~ s/\@/\@\@/g;
230			return "\@$s\@";
231			} elsif ($opt{max} == -1 or $opt{max} > 1) {
232			my $t = '';
233			for (@{$s}) {
234			$t .= "\x0A\t" . $_;
235			}
236			return $t;
237			} else {
238			return $s;
239			}
240			}
241
242			sub sort_by_revision ($@) {
243			shift;
244			map {
245			$_->[0]
246			}
247			sort {
248			my $r;
249			for my $i (0..$#{$a->[1]}) {
250			$r = $b->[1]->[$i] <=> $a->[1]->[$i];
251			return $r if $r;
252			}
253			0;
254			}
255			map {
256			[$_, [split /\./, $_]]
257			}
258			@_;
259			}
260
261			=head1 SEE ALSO
262
263			rcsfile(5)
264
265			=head1 LICENSE
266
267			Copyright 2004 Wakaba <w@suika.fam.cx>. All rights reserved.
268
269			This program is free software; you can redistribute it and/or
270			modify it under the same terms as Perl itself.
271
272			=cut
273
274			1; # $Date:$