Initial Commit
This commit is contained in:
Riley Schneider
332
database/perl/lib/TAP/Parser/YAMLish/Reader.pm
Normal file
332
database/perl/lib/TAP/Parser/YAMLish/Reader.pm
Normal file
@@ -0,0 +1,332 @@
|
||||
package TAP::Parser::YAMLish::Reader;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'TAP::Object';
|
||||
|
||||
our $VERSION = '3.42';
|
||||
|
||||
# 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.42
|
||||
|
||||
=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($iterator);
|
||||
|
||||
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-2011 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
|
||||
|
||||
254
database/perl/lib/TAP/Parser/YAMLish/Writer.pm
Normal file
254
database/perl/lib/TAP/Parser/YAMLish/Writer.pm
Normal file
@@ -0,0 +1,254 @@
|
||||
package TAP::Parser::YAMLish::Writer;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'TAP::Object';
|
||||
|
||||
our $VERSION = '3.42';
|
||||
|
||||
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.42
|
||||
|
||||
=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-2011 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
|
||||
|
||||
Reference in New Issue
Block a user