package TAP::Parser::YAMLish::Writer; use strict; use warnings; use base 'TAP::Object'; our $VERSION = '3.44'; # No EBCDIC support on early perls *from_native = (ord "A" == 65 || $] < 5.008) ? sub { return shift } : sub { utf8::native_to_unicode(shift) }; my $ESCAPE_CHAR = qr{ [ [:cntrl:] \" ] }x; my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x; my @UNPRINTABLE; $UNPRINTABLE[$_] = sprintf("x%02x", from_native($_)) for 0 .. ord(" ") - 1; $UNPRINTABLE[ord "\0"] = 'z'; $UNPRINTABLE[ord "\a"] = 'a'; $UNPRINTABLE[ord "\t"] = 't'; $UNPRINTABLE[ord "\n"] = 'n'; $UNPRINTABLE[ord "\cK"] = 'v'; $UNPRINTABLE[ord "\f"] = 'f'; $UNPRINTABLE[ord "\r"] = 'r'; $UNPRINTABLE[ord "\e"] = 'e'; # 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/ ( [[:cntrl:]] ) / '\\' . $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.44 =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 my $writer = TAP::Parser::YAMLish::Writer->new; The constructor C creates and returns an empty C object. =head2 Instance Methods =head3 C $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, =head1 SEE ALSO L, L, L, L, L, L =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