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 <[email protected]>.  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
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.2 $=~/\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	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	$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	$s .= "\x0A";
171
172	## delta
173	for my $rev ($self->sort_by_revision (keys %{$self->{delta}})) {
174	$s .= "\x0A$rev\x0A";
175	$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	$s .= "\x0A" if keys %{$self->{deltatext}} > 1;
228
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	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	}
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 <[email protected]>. 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	1; # $Date: 2007/08/14 09:52:34 $