1package TAP::Parser::YAMLish::Reader; 2 3use strict; 4use warnings; 5 6use base 'TAP::Object'; 7 8our $VERSION = '3.30_01'; 9 10# TODO: 11# Handle blessed object syntax 12 13# Printable characters for escapes 14my %UNESCAPES = ( 15 z => "\x00", a => "\x07", t => "\x09", 16 n => "\x0a", v => "\x0b", f => "\x0c", 17 r => "\x0d", e => "\x1b", '\\' => '\\', 18); 19 20my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x; 21my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x; 22my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x; 23my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x; 24my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x; 25 26# new() implementation supplied by TAP::Object 27 28sub 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 59sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" } 60 61sub _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 69sub _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 78sub _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 110sub _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 125sub _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 171sub _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 188sub _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 230sub _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 2601; 261 262__END__ 263 264=pod 265 266=head1 NAME 267 268TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator 269 270=head1 VERSION 271 272Version 3.30 273 274=head1 SYNOPSIS 275 276=head1 DESCRIPTION 277 278Note that parts of this code were derived from L<YAML::Tiny> with the 279permission of Adam Kennedy. 280 281=head1 METHODS 282 283=head2 Class Methods 284 285=head3 C<new> 286 287The constructor C<new> creates and returns an empty 288C<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 298Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it 299represents. 300 301=head3 C<get_raw> 302 303 my $source = $reader->get_source; 304 305Return the raw YAMLish source from the most recent C<read>. 306 307=head1 AUTHOR 308 309Andy Armstrong, <andy@hexten.net> 310 311Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of 312the YAML matching regular expressions for this module. 313 314=head1 SEE ALSO 315 316L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>, 317L<http://use.perl.org/~Alias/journal/29427> 318 319=head1 COPYRIGHT 320 321Copyright 2007-2011 Andy Armstrong. 322 323Portions copyright 2006-2008 Adam Kennedy. 324 325This program is free software; you can redistribute 326it and/or modify it under the same terms as Perl itself. 327 328The full text of the license can be found in the 329LICENSE file included with this module. 330 331=cut 332 333