Current File : //usr/share/perl/5.38/TAP/Parser/YAMLish/Writer.pm
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<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
Mini Shell