summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/TAP/Parser/YAMLish/Writer.pm255
1 files changed, 255 insertions, 0 deletions
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
+