File Coverage

web/cgi-bin/yatt.lib/YATT/XHF.pm
Criterion Covered Total %
statement 101 106 95.2
branch 34 48 70.8
condition 8 9 88.8
subroutine 19 19 100.0
pod 0 12 0.0
total 162 194 83.5


line stmt bran cond sub pod time code
1             package YATT::XHF;
2              
3             =head1 NAME
4              
5             YATT::XHF - Extended Header Fields format.
6              
7             =cut
8              
9 3     3   5669 use strict;
  3         5  
  3         109  
10 3     3   16 use warnings qw(FATAL all NONFATAL misc);
  3         7  
  3         156  
11              
12 3     3   14 use base qw(YATT::Class::Configurable);
  3         5  
  3         290  
13 3     3   14 use YATT::Fields qw(cf_FH cf_filename cf_tokens);
  3         6  
  3         23  
14 3     3   14 use Carp;
  3         6  
  3         223  
15              
16 3     3   1827 use YATT::Util::Enum -prefix => '_', qw(NAME VALUE SIGIL);
  3         8  
  3         26  
17              
18             our $cc_name = qr{\w|[\.\-%/]};
19             our $cc_sigil = qr{[:\#,\-\[\]\{\}]};
20             our $cc_tabsp = qr{[\ \t]};
21              
22             our %OPN = qw([ array { hash);
23              
24             sub configure_filename {
25 15     15 0 26 (my MY $self, my ($fn)) = @_;
26 15 50       624 open $self->{cf_FH}, '<', $fn
27             or croak "Can't open file '$fn': $!";
28 15         35 $self->{cf_filename} = $fn;
29 15         56 $self;
30             }
31              
32             sub configure_string {
33 7     7 0 11 (my MY $self, my ($string)) = @_;
34 7 50   1   91 open $self->{cf_FH}, '<', \$string
  1         6  
  1         2  
  1         7  
35             or croak "Can't create string stream: $!";
36 7         1244 $self;
37             }
38              
39             sub read_as_hashlist {
40 1     1 0 2 my MY $reader = shift;
41 1         4 local $/ = "";
42 1         2 my $fh = $$reader{cf_FH};
43 1         3 my @result;
44 1         10 while (defined (my $paragraph = <$fh>)) {
45 2 50       7 @{$$reader{cf_tokens}} = $reader->tokenize($paragraph)
  2         9  
46             or next;
47 2         6 push @result, $reader->organize_as_hash($reader->{cf_tokens});
48              
49             }
50 1 50       8 wantarray ? @result : \@result;
51             }
52              
53             sub read_as_hash {
54 203     203 0 471 shift->read_as(hash => @_);
55             }
56              
57             sub read_as {
58 205     205 0 289 (my MY $reader, my ($type)) = @_;
59 205 50       892 my $sub = $reader->can("organize_as_$type")
60             or croak "Unknown read_as type: $type";
61              
62 205         649 local $/ = "";
63 205         309 my $fh = $$reader{cf_FH};
64 205   100     554 until ($$reader{cf_tokens} && @{$$reader{cf_tokens}}) {
  390         1527  
65 219 100       1109 defined (my $paragraph = <$fh>) or last;
66 206         403 @{$$reader{cf_tokens}} = $reader->tokenize($paragraph)
  206         882  
67             }
68 205 100 66     552 return unless $$reader{cf_tokens} && @{$$reader{cf_tokens}};
  205         738  
69 192         433 $sub->($reader, $reader->{cf_tokens});
70             }
71              
72             sub organize_as_pairlist {
73 2     2 0 5 (my MY $reader, my ($tokens)) = @_;
74 2         9 my $hash = $reader->organize_as_hash($tokens);
75 2         18 %$hash;
76             }
77              
78             sub organize_as_hash {
79 198     198 0 279 (my MY $reader, my ($tokens)) = @_;
80 198         230 my %result;
81 198         398 while (@$tokens) {
82 639         849 my $desc = shift @$tokens;
83 639         1007 my $sigil = pop @$desc;
84 639 100       1756 if (my $type = $OPN{$sigil}) {
    100          
85 94         369 $desc->[_VALUE] = $reader->can("organize_as_$type")
86             ->($reader, $tokens);
87             } elsif ($sigil eq '}') {
88 4         10 last;
89             }
90 635         1338 $reader->add_value($result{$reader->decode_name($desc->[_NAME])}
91             , $desc->[_VALUE]);
92             }
93 198         1032 \%result;
94             }
95              
96             sub organize_as_array {
97 114     114 0 202 (my MY $reader, my ($tokens)) = @_;
98 114         119 my @result;
99 114         229 while (@$tokens) {
100 313         399 my $desc = shift @$tokens;
101 313         446 my $sigil = pop @$desc;
102 313 50       1112 unless ($desc->[_NAME] eq '') {
    100          
    100          
103 0         0 croak "Array can not have name: $desc->[_NAME]";
104             } elsif (my $type = $OPN{$sigil}) {
105 24         104 $desc->[_VALUE] = $reader->can("organize_as_$type")
106             ->($reader, $tokens);
107             } elsif ($sigil eq ']') {
108 114         211 last;
109             }
110 199         639 push @result, $desc->[_VALUE];
111             }
112 114         257 \@result;
113             }
114              
115             sub add_value {
116 635     635 0 771 my MY $reader = shift;
117 635 100       1295 unless (defined $_[0]) {
    50          
118 634         2945 $_[0] = $_[1];
119             } elsif (ref $_[0] ne 'ARRAY') {
120 1         5 $_[0] = [$_[0], $_[1]];
121             } else {
122 0         0 push @{$_[0]}, $_[1];
  0         0  
123             }
124             }
125              
126             sub tokenize {
127 212     212 0 268 my MY $reader = shift;
128 212         225 my ($ncomments, @result);
129 212         556 foreach my $token ($reader->split(my $record = shift)) {
130 1027 100       2150 if ($token =~ s{^(?:\#[^\n]*(?:\n|$))+}{}) {
131 49         58 $ncomments++;
132 49 50       132 next if $token eq '';
133             }
134              
135 978 50       6423 unless ($token =~ s{^($cc_name*) ($cc_sigil) (?:($cc_tabsp)|(\n|$))}{}x) {
136             croak "Invalid XHF token: $token"
137 0 0       0 . (defined $reader->{cf_filename} ? " in $reader->{cf_filename}" : "");
138             }
139 978         2575 my ($name, $sigil, $tabsp, $eol) = ($1, $2, $3, $4);
140              
141             # Comment fields are ignored.
142 978 50       1986 $ncomments++, next if $sigil eq "#";
143              
144             # Line continuation.
145 978         2147 $token =~ s/\n[\ \t]/\n/g;
146              
147 978 100       2119 unless (defined $eol) {
    100          
148             # Values are trimmed unless $eol
149 462         2471 $token =~ s/^\s+|\s+$//gs;
150             } elsif ($OPN{$sigil}) {
151             # Prohibit:
152             # name{ foo
153             # name[ foo
154             croak "Invalid XHF token(container with value): "
155 122 50       277 . join("", grep {defined $_} $name, $sigil, $tabsp, $token)
  0         0  
156             if $token ne "";
157             } else {
158             # Trim leading space for $tabsp eq "\n".
159 394         864 $token =~ s/^[\ \t]//;
160             }
161 978         3149 push @result, [$name, $token, $sigil];
162             }
163              
164             # Comment only paragraph should return nothing.
165 212 100 100     670 return if $ncomments && !@result;
166              
167 198 50       662 wantarray ? @result : \@result;
168             }
169              
170             sub split {
171 212     212 0 326 (my MY $reader, my ($record)) = @_;
172             # XXX: Can avoid copy.
173 212         1341 $record =~ s{\n+$}{\n}s;
174 212         4665 split /(?<=\n)(?=[^\ \t])/, $record;
175             }
176              
177             sub decode_name {
178 635     635 0 916 (my MY $reader, my ($name)) = @_;
179 635         808 $name =~ s{%([\da-f]{2})}{pack("C", hex($1))}egxi;
  2         17  
180 635         2144 $name;
181             }
182              
183             1;
184             __END__