diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish')
-rw-r--r-- | Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm | 333 | ||||
-rw-r--r-- | Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm | 255 |
2 files changed, 588 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm new file mode 100644 index 00000000000..524d7dca8df --- /dev/null +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Reader.pm @@ -0,0 +1,333 @@ +package TAP::Parser::YAMLish::Reader; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Object (); + +@ISA = 'TAP::Object'; +$VERSION = '3.17'; + +# 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_scalar($1), $2 ); + $self->_next; + + if ( defined $value ) { + $hash->{$key} = $self->_read_scalar($value); + } + else { + $hash->{$key} = $self->_read_nested; + } + + ( $line, $indent ) = $self->_peek; + last + if $indent < $limit + || !defined $line + || $line =~ $IS_END_YAML; + } + + return $hash; +} + +1; + +__END__ + +=pod + +=head1 NAME + +TAP::Parser::YAMLish::Reader - Read YAMLish data from iterator + +=head1 VERSION + +Version 3.17 + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Note that parts of this code were derived from L<YAML::Tiny> with the +permission of Adam Kennedy. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + +The constructor C<new> creates and returns an empty +C<TAP::Parser::YAMLish::Reader> object. + + my $reader = TAP::Parser::YAMLish::Reader->new; + +=head2 Instance Methods + +=head3 C<read> + + my $got = $reader->read($stream); + +Read YAMLish from a L<TAP::Parser::Iterator> and return the data structure it +represents. + +=head3 C<get_raw> + + my $source = $reader->get_source; + +Return the raw YAMLish source from the most recent C<read>. + +=head1 AUTHOR + +Andy Armstrong, <andy@hexten.net> + +Adam Kennedy wrote L<YAML::Tiny> which provided the template and many of +the YAML matching regular expressions for this module. + +=head1 SEE ALSO + +L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>, +L<http://use.perl.org/~Alias/journal/29427> + +=head1 COPYRIGHT + +Copyright 2007-2008 Andy Armstrong. + +Portions copyright 2006-2008 Adam Kennedy. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut + diff --git a/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm new file mode 100644 index 00000000000..ed81f6d8191 --- /dev/null +++ b/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm @@ -0,0 +1,255 @@ +package TAP::Parser::YAMLish::Writer; + +use strict; +use vars qw($VERSION @ISA); + +use TAP::Object (); + +@ISA = 'TAP::Object'; +$VERSION = '3.17'; + +my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x; +my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; + +my @UNPRINTABLE = qw( + z x01 x02 x03 x04 x05 x06 a + x08 t n v f r x0e x0f + x10 x11 x12 x13 x14 x15 x16 x17 + x18 x19 x1a e x1c x1d x1e x1f +); + +# new() implementation supplied by TAP::Object + +sub write { + my $self = shift; + + die "Need something to write" + unless @_; + + my $obj = shift; + my $out = shift || \*STDOUT; + + die "Need a reference to something I can write to" + unless ref $out; + + $self->{writer} = $self->_make_writer($out); + + $self->_write_obj( '---', $obj ); + $self->_put('...'); + + delete $self->{writer}; +} + +sub _make_writer { + my $self = shift; + my $out = shift; + + my $ref = ref $out; + + if ( 'CODE' eq $ref ) { + return $out; + } + elsif ( 'ARRAY' eq $ref ) { + return sub { push @$out, shift }; + } + elsif ( 'SCALAR' eq $ref ) { + return sub { $$out .= shift() . "\n" }; + } + elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) { + return sub { print $out shift(), "\n" }; + } + + die "Can't write to $out"; +} + +sub _put { + my $self = shift; + $self->{writer}->( join '', @_ ); +} + +sub _enc_scalar { + my $self = shift; + my $val = shift; + my $rule = shift; + + return '~' unless defined $val; + + if ( $val =~ /$rule/ ) { + $val =~ s/\\/\\\\/g; + $val =~ s/"/\\"/g; + $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex; + return qq{"$val"}; + } + + if ( length($val) == 0 or $val =~ /\s/ ) { + $val =~ s/'/''/; + return "'$val'"; + } + + return $val; +} + +sub _write_obj { + my $self = shift; + my $prefix = shift; + my $obj = shift; + my $indent = shift || 0; + + if ( my $ref = ref $obj ) { + my $pad = ' ' x $indent; + if ( 'HASH' eq $ref ) { + if ( keys %$obj ) { + $self->_put($prefix); + for my $key ( sort keys %$obj ) { + my $value = $obj->{$key}; + $self->_write_obj( + $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':', + $value, $indent + 1 + ); + } + } + else { + $self->_put( $prefix, ' {}' ); + } + } + elsif ( 'ARRAY' eq $ref ) { + if (@$obj) { + $self->_put($prefix); + for my $value (@$obj) { + $self->_write_obj( + $pad . '-', $value, + $indent + 1 + ); + } + } + else { + $self->_put( $prefix, ' []' ); + } + } + else { + die "Don't know how to encode $ref"; + } + } + else { + $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) ); + } +} + +1; + +__END__ + +=pod + +=head1 NAME + +TAP::Parser::YAMLish::Writer - Write YAMLish data + +=head1 VERSION + +Version 3.17 + +=head1 SYNOPSIS + + use TAP::Parser::YAMLish::Writer; + + my $data = { + one => 1, + two => 2, + three => [ 1, 2, 3 ], + }; + + my $yw = TAP::Parser::YAMLish::Writer->new; + + # Write to an array... + $yw->write( $data, \@some_array ); + + # ...an open file handle... + $yw->write( $data, $some_file_handle ); + + # ...a string ... + $yw->write( $data, \$some_string ); + + # ...or a closure + $yw->write( $data, sub { + my $line = shift; + print "$line\n"; + } ); + +=head1 DESCRIPTION + +Encodes a scalar, hash reference or array reference as YAMLish. + +=head1 METHODS + +=head2 Class Methods + +=head3 C<new> + + my $writer = TAP::Parser::YAMLish::Writer->new; + +The constructor C<new> creates and returns an empty +C<TAP::Parser::YAMLish::Writer> object. + +=head2 Instance Methods + +=head3 C<write> + + $writer->write($obj, $output ); + +Encode a scalar, hash reference or array reference as YAML. + + my $writer = sub { + my $line = shift; + print SOMEFILE "$line\n"; + }; + + my $data = { + one => 1, + two => 2, + three => [ 1, 2, 3 ], + }; + + my $yw = TAP::Parser::YAMLish::Writer->new; + $yw->write( $data, $writer ); + + +The C< $output > argument may be: + +=over + +=item * a reference to a scalar to append YAML to + +=item * the handle of an open file + +=item * a reference to an array into which YAML will be pushed + +=item * a code reference + +=back + +If you supply a code reference the subroutine will be called once for +each line of output with the line as its only argument. Passed lines +will have no trailing newline. + +=head1 AUTHOR + +Andy Armstrong, <andy@hexten.net> + +=head1 SEE ALSO + +L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>, +L<http://use.perl.org/~Alias/journal/29427> + +=head1 COPYRIGHT + +Copyright 2007-2008 Andy Armstrong. + +This program is free software; you can redistribute +it and/or modify it under the same terms as Perl itself. + +The full text of the license can be found in the +LICENSE file included with this module. + +=cut + |