AlkantarClanX12
Your IP : 52.14.27.122
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