Update Test-Harness to CPAN version 3.39
[perl.git] / cpan / Test-Harness / lib / TAP / Parser / YAMLish / Reader.pm
1 package TAP::Parser::YAMLish::Reader;
2
3 use strict;
4 use warnings;
5
6 use base 'TAP::Object';
7
8 our $VERSION = '3.39';
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     my $self = shift;
30     my $obj  = shift;
31
32     die "Must have a code reference to read input from"
33       unless ref $obj eq 'CODE';
34
35     $self->{reader}  = $obj;
36     $self->{capture} = [];
37
38     #┬áPrime the reader
39     $self->_next;
40     return unless $self->{next};
41
42     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     my $dots = $self->_peek;
49     die "Missing '...' at end of YAMLish"
50       unless defined $dots
51           and $dots =~ $IS_END_YAML;
52
53     delete $self->{reader};
54     delete $self->{next};
55
56     return $doc;
57 }
58
59 sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" }
60
61 sub _peek {
62     my $self = shift;
63     return $self->{next} unless wantarray;
64     my $line = $self->{next};
65     $line =~ /^ (\s*) (.*) $ /x;
66     return ( $2, length $1 );
67 }
68
69 sub _next {
70     my $self = shift;
71     die "_next called with no reader"
72       unless $self->{reader};
73     my $line = $self->{reader}->();
74     $self->{next} = $line;
75     push @{ $self->{capture} }, $line;
76 }
77
78 sub _read {
79     my $self = shift;
80
81     my $line = $self->_peek;
82
83     # Do we have a document header?
84     if ( $line =~ /^ --- (?: \s* (.+?)? \s* )? $/x ) {
85         $self->_next;
86
87         return $self->_read_scalar($1) if defined $1;    # Inline?
88
89         my ( $next, $indent ) = $self->_peek;
90
91         if ( $next =~ /^ - /x ) {
92             return $self->_read_array($indent);
93         }
94         elsif ( $next =~ $IS_HASH_KEY ) {
95             return $self->_read_hash( $next, $indent );
96         }
97         elsif ( $next =~ $IS_END_YAML ) {
98             die "Premature end of YAMLish";
99         }
100         else {
101             die "Unsupported YAMLish syntax: '$next'";
102         }
103     }
104     else {
105         die "YAMLish document header not found";
106     }
107 }
108
109 # Parse a double quoted string
110 sub _read_qq {
111     my $self = shift;
112     my $str  = shift;
113
114     unless ( $str =~ s/^ " (.*?) " $/$1/x ) {
115         die "Internal: not a quoted string";
116     }
117
118     $str =~ s/\\"/"/gx;
119     $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) ) 
120                  / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex;
121     return $str;
122 }
123
124 # Parse a scalar string to the actual scalar
125 sub _read_scalar {
126     my $self   = shift;
127     my $string = shift;
128
129     return undef if $string eq '~';
130     return {} if $string eq '{}';
131     return [] if $string eq '[]';
132
133     if ( $string eq '>' || $string eq '|' ) {
134
135         my ( $line, $indent ) = $self->_peek;
136         die "Multi-line scalar content missing" unless defined $line;
137
138         my @multiline = ($line);
139
140         while (1) {
141             $self->_next;
142             my ( $next, $ind ) = $self->_peek;
143             last if $ind < $indent;
144
145             my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : '';
146             push @multiline, $pad . $next;
147         }
148
149         return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n";
150     }
151
152     if ( $string =~ /^ ' (.*) ' $/x ) {
153         ( my $rv = $1 ) =~ s/''/'/g;
154         return $rv;
155     }
156
157     if ( $string =~ $IS_QQ_STRING ) {
158         return $self->_read_qq($string);
159     }
160
161     if ( $string =~ /^['"]/ ) {
162
163         # A quote with folding... we don't support that
164         die __PACKAGE__ . " does not support multi-line quoted scalars";
165     }
166
167     # Regular unquoted string
168     return $string;
169 }
170
171 sub _read_nested {
172     my $self = shift;
173
174     my ( $line, $indent ) = $self->_peek;
175
176     if ( $line =~ /^ -/x ) {
177         return $self->_read_array($indent);
178     }
179     elsif ( $line =~ $IS_HASH_KEY ) {
180         return $self->_read_hash( $line, $indent );
181     }
182     else {
183         die "Unsupported YAMLish syntax: '$line'";
184     }
185 }
186
187 # Parse an array
188 sub _read_array {
189     my ( $self, $limit ) = @_;
190
191     my $ar = [];
192
193     while (1) {
194         my ( $line, $indent ) = $self->_peek;
195         last
196           if $indent < $limit
197               || !defined $line
198               || $line =~ $IS_END_YAML;
199
200         if ( $indent > $limit ) {
201             die "Array line over-indented";
202         }
203
204         if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) {
205             $indent += length $1;
206             $line =~ s/-\s+//;
207             push @$ar, $self->_read_hash( $line, $indent );
208         }
209         elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) {
210             die "Unexpected start of YAMLish" if $line =~ /^---/;
211             $self->_next;
212             push @$ar, $self->_read_scalar($1);
213         }
214         elsif ( $line =~ /^ - \s* $/x ) {
215             $self->_next;
216             push @$ar, $self->_read_nested;
217         }
218         elsif ( $line =~ $IS_HASH_KEY ) {
219             $self->_next;
220             push @$ar, $self->_read_hash( $line, $indent, );
221         }
222         else {
223             die "Unsupported YAMLish syntax: '$line'";
224         }
225     }
226
227     return $ar;
228 }
229
230 sub _read_hash {
231     my ( $self, $line, $limit ) = @_;
232
233     my $indent;
234     my $hash = {};
235
236     while (1) {
237         die "Badly formed hash line: '$line'"
238           unless $line =~ $HASH_LINE;
239
240         my ( $key, $value ) = ( $self->_read_scalar($1), $2 );
241         $self->_next;
242
243         if ( defined $value ) {
244             $hash->{$key} = $self->_read_scalar($value);
245         }
246         else {
247             $hash->{$key} = $self->_read_nested;
248         }
249
250         ( $line, $indent ) = $self->_peek;
251         last
252           if $indent < $limit
253               || !defined $line
254               || $line =~ $IS_END_YAML;
255     }
256
257     return $hash;
258 }
259
260 1;
261
262 __END__
263
264 =pod
265
266 =head1 NAME
267
268 TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator
269
270 =head1 VERSION
271
272 Version 3.39
273
274 =head1 SYNOPSIS
275
276 =head1 DESCRIPTION
277
278 Note that parts of this code were derived from L<YAML::Tiny> with the
279 permission of Adam Kennedy.
280
281 =head1 METHODS
282
283 =head2 Class Methods
284
285 =head3 C<new>
286
287 The constructor C<new> creates and returns an empty
288 C<TAP::Parser::YAMLish::Reader> object.
289
290  my $reader = TAP::Parser::YAMLish::Reader->new; 
291
292 =head2 Instance Methods
293
294 =head3 C<read>
295
296  my $got = $reader->read($iterator);
297
298 Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it
299 represents.
300
301 =head3 C<get_raw>
302
303  my $source = $reader->get_source;
304
305 Return the raw YAMLish source from the most recent C<read>.
306
307 =head1 AUTHOR
308
309 Andy Armstrong, <andy@hexten.net>
310
311 Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of
312 the YAML matching regular expressions for this module.
313
314 =head1 SEE ALSO
315
316 L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
317 L<http://use.perl.org/~Alias/journal/29427>
318
319 =head1 COPYRIGHT
320
321 Copyright 2007-2011 Andy Armstrong.
322
323 Portions copyright 2006-2008 Adam Kennedy.
324
325 This program is free software; you can redistribute
326 it and/or modify it under the same terms as Perl itself.
327
328 The full text of the license can be found in the
329 LICENSE file included with this module.
330
331 =cut
332