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.2 $=~/\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";
  }
  if (defined $self->{admin}->{access}) {
    $s .= qq(access     )
       .  $self->___stringify_value ($self->{admin}->{access}, type => 'id',
                                     min => 0, max => -1)
       .  ";\x0A";
  } else {
    $s .= qq(access;\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";
  }
  $s .= "\x0A";
  
  ## delta
  for my $rev ($self->sort_by_revision (keys %{$self->{delta}})) {
    $s .= "\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 .= "\x0A" if keys %{$self->{deltatext}} > 1;
  
  $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 {
    if (@{$a->[1]} == 2 and @{$b->[1]} == 2) {
      my $r;
      for my $i (0..$#{$a->[1]}) {
        $r = $b->[1]->[$i] <=> $a->[1]->[$i];
        return $r if $r;
      }
    } else {
      my $r;
      for my $i (0..$#{$a->[1]}) {
        $r = $a->[1]->[$i] <=> $b->[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: 2007/08/14 09:52:34 $
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	wakaba	1.3	our $VERSION=do{my @r=(q$Revision: 1.2 $=~/\d+/g);sprintf "%d."."%02d" x $#r,@r};
16	wakaba	1.1
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	wakaba	1.2	if (defined $self->{admin}->{access}) {
123			$s .= qq(access )
124			. $self->___stringify_value ($self->{admin}->{access}, type => 'id',
125			min => 0, max => -1)
126			. ";\x0A";
127			} else {
128			$s .= qq(access;\x0A);
129			}
130	wakaba	1.1	$s .= qq(symbols);
131			for (@{$self->{admin}->{symbols}}) {
132			$s .= "\x0A\t"
133			. $self->___stringify_value ($_->[0], type => 'sym',
134			min => 1, max => 1)
135			. ':'
136			. $self->___stringify_value ($_->[1], type => 'num',
137			min => 1, max => 1);
138			}
139			$s .= ";\x0A";
140			$s .= qq(locks);
141			for (@{$self->{admin}->{locks}}) {
142			$s .= "\x0A\t"
143			. $self->___stringify_value ($_->[0], type => 'id',
144			min => 1, max => 1)
145			. ':'
146			. $self->___stringify_value ($_->[1], type => 'num',
147			min => 1, max => 1);
148			}
149			$s .= ";";
150			$s .= " strict;" if exists $self->{admin}->{strict};
151			$s .= "\x0A";
152			if (exists $self->{admin}->{comment}) {
153			$s .= qq(comment )
154			. $self->___stringify_value ($self->{admin}->{comment}, type => 'str',
155			min => 0, max => 1)
156			. ";\x0A";
157			}
158			if (exists $self->{admin}->{expand}) {
159			$s .= qq(expand )
160			. $self->___stringify_value ($self->{admin}->{expand}, type => 'str',
161			min => 0, max => 1)
162			. ";\x0A";
163			}
164			for (grep !{qw/head 1 branch 1 access 1 symbols 1 locks 1 strict 1 comment 1 expand 1/}->{$_},
165			keys %{$self->{admin}}) {
166			$s .= qq($_ )
167			. $self->___stringify_value ($self->{admin}->{$_})
168			. ";\x0A";
169			}
170	wakaba	1.2	$s .= "\x0A";
171	wakaba	1.1
172			## delta
173			for my $rev ($self->sort_by_revision (keys %{$self->{delta}})) {
174	wakaba	1.2	$s .= "\x0A$rev\x0A";
175	wakaba	1.1	$s .= qq(date )
176			. $self->___stringify_value ($self->{delta}->{$rev}->{date}, type => 'num',
177			min => 1, max => 1)
178			. ";\t";
179			$s .= qq(author )
180			. $self->___stringify_value ($self->{delta}->{$rev}->{author}, type => 'id',
181			min => 1, max => 1)
182			. ";\t";
183			$s .= qq(state )
184			. $self->___stringify_value ($self->{delta}->{$rev}->{state}, type => 'id',
185			min => 0, max => 1)
186			. ";\x0A";
187			$s .= qq(branches)
188			. $self->___stringify_value ($self->{delta}->{$rev}->{branches}, type => 'num',
189			min => 0, max => -1)
190			. ";\x0A";
191			$s .= qq(next )
192			. $self->___stringify_value ($self->{delta}->{$rev}->{next}, type => 'num',
193			min => 0, max => 1)
194			. ";\x0A";
195			for (grep !{qw/date 1 author 1 state 1 branches 1 next 1/}->{$_},
196			keys %{$self->{delta}->{$rev}}) {
197			$s .= qq($_ )
198			. $self->___stringify_value ($self->{delta}->{$rev}->{$_})
199			. ";\x0A";
200			}
201			}
202
203			# desc
204			$s .= qq(\x0A\x0Adesc\x0A)
205			. $self->___stringify_value ($self->{desc}, type => 'str',
206			min => 1, max => 1)
207			. "\x0A";
208
209			## deltatext
210			for my $rev ($self->sort_by_revision (keys %{$self->{deltatext}})) {
211			$s .= "\x0A\x0A$rev\x0A";
212			$s .= qq(log\x0A)
213			. $self->___stringify_value ($self->{deltatext}->{$rev}->{log}, type => 'str',
214			min => 1, max => 1)
215			. "\x0A";
216			$s .= qq(text\x0A)
217			. $self->___stringify_value ($self->{deltatext}->{$rev}->{text}, type => 'str',
218			min => 1, max => 1)
219			. "\x0A";
220			for (grep !{qw/log 1 text 1/}->{$_},
221			keys %{$self->{deltatext}->{$rev}}) {
222			$s .= qq($_ )
223			. $self->___stringify_value ($self->{deltatext}->{$rev}->{$_})
224			. ";\x0A";
225			}
226			}
227	wakaba	1.2	$s .= "\x0A" if keys %{$self->{deltatext}} > 1;
228	wakaba	1.1
229			$s;
230			}
231
232			sub ___stringify_value ($$%) {
233			my ($self, $s, %opt) = @_;
234			if ($opt{type} eq 'str') {
235			$s =~ s/\@/\@\@/g;
236			return "\@$s\@";
237			} elsif ($opt{max} == -1 or $opt{max} > 1) {
238			my $t = '';
239			for (@{$s}) {
240			$t .= "\x0A\t" . $_;
241			}
242			return $t;
243			} else {
244			return $s;
245			}
246			}
247
248			sub sort_by_revision ($@) {
249			shift;
250			map {
251			$_->[0]
252			}
253			sort {
254	wakaba	1.3	if (@{$a->[1]} == 2 and @{$b->[1]} == 2) {
255			my $r;
256			for my $i (0..$#{$a->[1]}) {
257			$r = $b->[1]->[$i] <=> $a->[1]->[$i];
258			return $r if $r;
259			}
260			} else {
261			my $r;
262			for my $i (0..$#{$a->[1]}) {
263			$r = $a->[1]->[$i] <=> $b->[1]->[$i];
264			return $r if $r;
265			}
266	wakaba	1.1	}
267			0;
268			}
269			map {
270			[$_, [split /\./, $_]]
271			}
272			@_;
273			}
274
275			=head1 SEE ALSO
276
277			rcsfile(5)
278
279			=head1 LICENSE
280
281			Copyright 2004 Wakaba <w@suika.fam.cx>. All rights reserved.
282
283			This program is free software; you can redistribute it and/or
284			modify it under the same terms as Perl itself.
285
286			=cut
287
288	wakaba	1.3	1; # $Date: 2007/08/14 09:52:34 $