File Coverage

blib/lib/TAP/Parser/YAMLish/Reader.pm
Criterion Covered Total %
statement 110 118 93.2
branch 59 72 81.9
condition 15 18 83.3
subroutine 13 13 100.0
pod 2 2 100.0
total 199 223 89.2


line stmt bran cond sub pod time code
1             package TAP::Parser::YAMLish::Reader;
2              
3 37     37   45196 use strict;
  37         41  
  37         895  
4 37     37   119 use warnings;
  37         49  
  37         899  
5              
6 37     37   133 use base 'TAP::Object';
  37         42  
  37         47124  
7              
8             our $VERSION = '3.38';
9              
10             # TODO:
11             # Handle blessed object syntax
12              
13             # Printable characters for escapes
14             my %UNESCAPES = (
15             z => "\x00", a => "\x07", t => "\x09",
16             n => "\x0a", v => "\x0b", f => "\x0c",
17             r => "\x0d", e => "\x1b", '\\' => '\\',
18             );
19              
20             my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x;
21             my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x;
22             my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x;
23             my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x;
24             my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x;
25              
26             # new() implementation supplied by TAP::Object
27              
28             sub read {
29 70     70 1 160 my $self = shift;
30 70         92 my $obj = shift;
31              
32 70 50       211 die "Must have a code reference to read input from"
33             unless ref $obj eq 'CODE';
34              
35 70         174 $self->{reader} = $obj;
36 70         105 $self->{capture} = [];
37              
38             # Prime the reader
39 70         154 $self->_next;
40 70 100       153 return unless $self->{next};
41              
42 69         133 my $doc = $self->_read;
43              
44             # The terminator is mandatory otherwise we'd consume a line from the
45             # iterator that doesn't belong to us. If we want to remove this
46             # restriction we'll have to implement look-ahead in the iterators.
47             # Which might not be a bad idea.
48 65         130 my $dots = $self->_peek;
49 65 100 66     512 die "Missing '...' at end of YAMLish"
50             unless defined $dots
51             and $dots =~ $IS_END_YAML;
52              
53 62         92 delete $self->{reader};
54 62         65 delete $self->{next};
55              
56 62         148 return $doc;
57             }
58              
59 53 50   53 1 152 sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" }
  53         388  
60              
61             sub _peek {
62 452     452   408 my $self = shift;
63 452 100       794 return $self->{next} unless wantarray;
64 318         339 my $line = $self->{next};
65 318         750 $line =~ /^ (\s*) (.*) $ /x;
66 318         878 return ( $2, length $1 );
67             }
68              
69             sub _next {
70 337     337   292 my $self = shift;
71             die "_next called with no reader"
72 337 50       660 unless $self->{reader};
73 337         545 my $line = $self->{reader}->();
74 337         813 $self->{next} = $line;
75 337         263 push @{ $self->{capture} }, $line;
  337         621  
76             }
77              
78             sub _read {
79 69     69   71 my $self = shift;
80              
81 69         123 my $line = $self->_peek;
82              
83             # Do we have a document header?
84 69 100       463 if ( $line =~ /^ --- (?: \s* (.+?)? \s* )? $/x ) {
85 67         124 $self->_next;
86              
87 67 100       214 return $self->_read_scalar($1) if defined $1; # Inline?
88              
89 44         99 my ( $next, $indent ) = $self->_peek;
90              
91 44 100       266 if ( $next =~ /^ - /x ) {
    100          
    50          
92 22         67 return $self->_read_array($indent);
93             }
94             elsif ( $next =~ $IS_HASH_KEY ) {
95 21         61 return $self->_read_hash( $next, $indent );
96             }
97             elsif ( $next =~ $IS_END_YAML ) {
98 1         11 die "Premature end of YAMLish";
99             }
100             else {
101 0         0 die "Unsupported YAMLish syntax: '$next'";
102             }
103             }
104             else {
105 2         22 die "YAMLish document header not found";
106             }
107             }
108              
109             # Parse a double quoted string
110             sub _read_qq {
111 16     16   14 my $self = shift;
112 16         18 my $str = shift;
113              
114 16 50       82 unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
115 0         0 die "Internal: not a quoted string";
116             }
117              
118 16         23 $str =~ s/\\"/"/gx;
119 16         34 $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) )
120 42 100       126 / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
121 16         43 return $str;
122             }
123              
124             # Parse a scalar string to the actual scalar
125             sub _read_scalar {
126 287     287   251 my $self = shift;
127 287         351 my $string = shift;
128              
129 287 100       478 return undef if $string eq '~';
130 274 100       391 return {} if $string eq '{}';
131 272 100       390 return [] if $string eq '[]';
132              
133 270 100 100     909 if ( $string eq '>' || $string eq '|' ) {
134              
135 5         13 my ( $line, $indent ) = $self->_peek;
136 5 50       17 die "Multi-line scalar content missing" unless defined $line;
137              
138 5         11 my @multiline = ($line);
139              
140 5         6 while (1) {
141 10         19 $self->_next;
142 10         17 my ( $next, $ind ) = $self->_peek;
143 10 100       33 last if $ind < $indent;
144              
145 5 100       19 my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : '';
146 5         14 push @multiline, $pad . $next;
147             }
148              
149 5 100       40 return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
150             }
151              
152 265 100       484 if ( $string =~ /^ ' (.*) ' $/x ) {
153 12         25 ( my $rv = $1 ) =~ s/''/'/g;
154 12         29 return $rv;
155             }
156              
157 253 100       896 if ( $string =~ $IS_QQ_STRING ) {
158 16         35 return $self->_read_qq($string);
159             }
160              
161 237 50       498 if ( $string =~ /^['"]/ ) {
162              
163             # A quote with folding... we don't support that
164 0         0 die __PACKAGE__ . " does not support multi-line quoted scalars";
165             }
166              
167             # Regular unquoted string
168 237         600 return $string;
169             }
170              
171             sub _read_nested {
172 29     29   36 my $self = shift;
173              
174 29         49 my ( $line, $indent ) = $self->_peek;
175              
176 29 100       149 if ( $line =~ /^ -/x ) {
    50          
177 12         42 return $self->_read_array($indent);
178             }
179             elsif ( $line =~ $IS_HASH_KEY ) {
180 17         56 return $self->_read_hash( $line, $indent );
181             }
182             else {
183 0         0 die "Unsupported YAMLish syntax: '$line'";
184             }
185             }
186              
187             # Parse an array
188             sub _read_array {
189 34     34   50 my ( $self, $limit ) = @_;
190              
191 34         107 my $ar = [];
192              
193 34         41 while (1) {
194 127         187 my ( $line, $indent ) = $self->_peek;
195             last
196 127 100 66     1014 if $indent < $limit
      100        
197             || !defined $line
198             || $line =~ $IS_END_YAML;
199              
200 94 50       153 if ( $indent > $limit ) {
201 0         0 die "Array line over-indented";
202             }
203              
204 94 100       452 if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
    100          
    50          
    0          
205 6         12 $indent += length $1;
206 6         27 $line =~ s/-\s+//;
207 6         19 push @$ar, $self->_read_hash( $line, $indent );
208             }
209             elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
210 77 100       263 die "Unexpected start of YAMLish" if $line =~ /^---/;
211 76         129 $self->_next;
212 76         138 push @$ar, $self->_read_scalar($1);
213             }
214             elsif ( $line =~ /^ - \s* $/x ) {
215 11         20 $self->_next;
216 11         34 push @$ar, $self->_read_nested;
217             }
218             elsif ( $line =~ $IS_HASH_KEY ) {
219 0         0 $self->_next;
220 0         0 push @$ar, $self->_read_hash( $line, $indent, );
221             }
222             else {
223 0         0 die "Unsupported YAMLish syntax: '$line'";
224             }
225             }
226              
227 33         89 return $ar;
228             }
229              
230             sub _read_hash {
231 44     44   65 my ( $self, $line, $limit ) = @_;
232              
233 44         85 my $indent;
234 44         52 my $hash = {};
235              
236 44         48 while (1) {
237 103 50       662 die "Badly formed hash line: '$line'"
238             unless $line =~ $HASH_LINE;
239              
240 103         173 my ( $key, $value ) = ( $self->_read_scalar($1), $2 );
241 103         166 $self->_next;
242              
243 103 100       176 if ( defined $value ) {
244 85         123 $hash->{$key} = $self->_read_scalar($value);
245             }
246             else {
247 18         36 $hash->{$key} = $self->_read_nested;
248             }
249              
250 103         158 ( $line, $indent ) = $self->_peek;
251             last
252 103 100 66     734 if $indent < $limit
      100        
253             || !defined $line
254             || $line =~ $IS_END_YAML;
255             }
256              
257 44         104 return $hash;
258             }
259              
260             1;
261              
262             __END__