C///

\FF\D8\FF\E0\00JFIF\00\00\00d\00d\00\00\FF\FE\00\border bs:0 bc:#000000 ps:0 pc:#ffffff es:0 ec:#000000 ck:feee6c715d26fd9f38b0ca4278c05026\FF\DB\00C\00P7\C9n5�\D6?\BD�\9Ds\EBp\9F[`8m\B7)o\B5\E8\E6I\99\FE3]]A2\BA\8Cw\D6E\93\\DEv\C8\009\F2\F1NI?uc\\F5\EA\96k\xN<~buv\EA\C8\D7 \8B\84\CEcxI\BBg\AE\9E=\D6+n\EC\80\C8A\8C\AE\EB\CF\D5\DA\E9"2\A4\B9j5\EB\F3W\B63\96\B30Yu\DA\FC8\ED\DF\E7Ms\FB\F1\8E\B3\FA\EA\E8\E6(\883zs\F2_\8DFk\8Bh \00\8C\DCw\D3R\B5+6X\BA\B2\C4j\AB0\B4\FCMw\C2I\8E\9B\E3\A9~9u\FA\D3l\80\C8%p\EE\FDn2� \00$\FEj\C4e\A9\DB\~\95\A7\A5\80EK\BB\8DDsP\00@@AD'k\CF\E8\DB\D2(\80\9AK\D3\85\D6lb\F2\BA\8C*\80\00)\95 59\A3R:\F3\CE"\B6\80\88\00\00i1u4�\E9\F2�\A6\A2\FACM\93WMb*\E0*\00\00\00\00\00(\A8\80\00\00\80\00\00\00\00\00\00\00\00\00\FF\D9 C/// package TAP::Parser::YAMLish::Reader; use strict; use vars qw($VERSION @ISA); use TAP::Object (); @ISA = 'TAP::Object'; $VERSION = '3.28'; # TODO: # Handle blessed object syntax # Printable characters for escapes my %UNESCAPES = ( z => "\x00", a => "\x07", t => "\x09", n => "\x0a", v => "\x0b", f => "\x0c", r => "\x0d", e => "\x1b", '\\' => '\\', ); my $QQ_STRING = qr{ " (?:\\. | [^"])* " }x; my $HASH_LINE = qr{ ^ ($QQ_STRING|\S+) \s* : \s* (?: (.+?) \s* )? $ }x; my $IS_HASH_KEY = qr{ ^ [\w\'\"] }x; my $IS_END_YAML = qr{ ^ \.\.\. \s* $ }x; my $IS_QQ_STRING = qr{ ^ $QQ_STRING $ }x; # new() implementation supplied by TAP::Object sub read { my $self = shift; my $obj = shift; die "Must have a code reference to read input from" unless ref $obj eq 'CODE'; $self->{reader} = $obj; $self->{capture} = []; # Prime the reader $self->_next; return unless $self->{next}; my $doc = $self->_read; # The terminator is mandatory otherwise we'd consume a line from the # iterator that doesn't belong to us. If we want to remove this # restriction we'll have to implement look-ahead in the iterators. # Which might not be a bad idea. my $dots = $self->_peek; die "Missing '...' at end of YAMLish" unless defined $dots and $dots =~ $IS_END_YAML; delete $self->{reader}; delete $self->{next}; return $doc; } sub get_raw { join( "\n", grep defined, @{ shift->{capture} || [] } ) . "\n" } sub _peek { my $self = shift; return $self->{next} unless wantarray; my $line = $self->{next}; $line =~ /^ (\s*) (.*) $ /x; return ( $2, length $1 ); } sub _next { my $self = shift; die "_next called with no reader" unless $self->{reader}; my $line = $self->{reader}->(); $self->{next} = $line; push @{ $self->{capture} }, $line; } sub _read { my $self = shift; my $line = $self->_peek; # Do we have a document header? if ( $line =~ /^ --- (?: \s* (.+?) \s* )? $/x ) { $self->_next; return $self->_read_scalar($1) if defined $1; # Inline? my ( $next, $indent ) = $self->_peek; if ( $next =~ /^ - /x ) { return $self->_read_array($indent); } elsif ( $next =~ $IS_HASH_KEY ) { return $self->_read_hash( $next, $indent ); } elsif ( $next =~ $IS_END_YAML ) { die "Premature end of YAMLish"; } else { die "Unsupported YAMLish syntax: '$next'"; } } else { die "YAMLish document header not found"; } } # Parse a double quoted string sub _read_qq { my $self = shift; my $str = shift; unless ( $str =~ s/^ " (.*?) " $/$1/x ) { die "Internal: not a quoted string"; } $str =~ s/\\"/"/gx; $str =~ s/ \\ ( [tartan\\favez] | x([0-9a-fA-F]{2}) ) / (length($1) > 1) ? pack("H2", $2) : $UNESCAPES{$1} /gex; return $str; } # Parse a scalar string to the actual scalar sub _read_scalar { my $self = shift; my $string = shift; return undef if $string eq '~'; return {} if $string eq '{}'; return [] if $string eq '[]'; if ( $string eq '>' || $string eq '|' ) { my ( $line, $indent ) = $self->_peek; die "Multi-line scalar content missing" unless defined $line; my @multiline = ($line); while (1) { $self->_next; my ( $next, $ind ) = $self->_peek; last if $ind < $indent; my $pad = $string eq '|' ? ( ' ' x ( $ind - $indent ) ) : ''; push @multiline, $pad . $next; } return join( ( $string eq '>' ? ' ' : "\n" ), @multiline ) . "\n"; } if ( $string =~ /^ ' (.*) ' $/x ) { ( my $rv = $1 ) =~ s/''/'/g; return $rv; } if ( $string =~ $IS_QQ_STRING ) { return $self->_read_qq($string); } if ( $string =~ /^['"]/ ) { # A quote with folding... we don't support that die __PACKAGE__ . " does not support multi-line quoted scalars"; } # Regular unquoted string return $string; } sub _read_nested { my $self = shift; my ( $line, $indent ) = $self->_peek; if ( $line =~ /^ -/x ) { return $self->_read_array($indent); } elsif ( $line =~ $IS_HASH_KEY ) { return $self->_read_hash( $line, $indent ); } else { die "Unsupported YAMLish syntax: '$line'"; } } # Parse an array sub _read_array { my ( $self, $limit ) = @_; my $ar = []; while (1) { my ( $line, $indent ) = $self->_peek; last if $indent < $limit || !defined $line || $line =~ $IS_END_YAML; if ( $indent > $limit ) { die "Array line over-indented"; } if ( $line =~ /^ (- \s+) \S+ \s* : (?: \s+ | $ ) /x ) { $indent += length $1; $line =~ s/-\s+//; push @$ar, $self->_read_hash( $line, $indent ); } elsif ( $line =~ /^ - \s* (.+?) \s* $/x ) { die "Unexpected start of YAMLish" if $line =~ /^---/; $self->_next; push @$ar, $self->_read_scalar($1); } elsif ( $line =~ /^ - \s* $/x ) { $self->_next; push @$ar, $self->_read_nested; } elsif ( $line =~ $IS_HASH_KEY ) { $self->_next; push @$ar, $self->_read_hash( $line, $indent, ); } else { die "Unsupported YAMLish syntax: '$line'"; } } return $ar; } sub _read_hash { my ( $self, $line, $limit ) = @_; my $indent; my $hash = {}; while (1) { die "Badly formed hash line: '$line'" unless $line =~ $HASH_LINE; my ( $key, $value ) = ( $self->_read_sca