<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">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 || $] &lt; 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-&gt;{writer} = $self-&gt;_make_writer($out);

    $self-&gt;_write_obj( '---', $obj );
    $self-&gt;_put('...');

    delete $self-&gt;{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-&gt;{writer}-&gt;( 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-&gt;_put($prefix);
                for my $key ( sort keys %$obj ) {
                    my $value = $obj-&gt;{$key};
                    $self-&gt;_write_obj(
                        $pad . $self-&gt;_enc_scalar( $key, $ESCAPE_KEY ) . ':',
                        $value, $indent + 1
                    );
                }
            }
            else {
                $self-&gt;_put( $prefix, ' {}' );
            }
        }
        elsif ( 'ARRAY' eq $ref ) {
            if (@$obj) {
                $self-&gt;_put($prefix);
                for my $value (@$obj) {
                    $self-&gt;_write_obj(
                        $pad . '-', $value,
                        $indent + 1
                    );
                }
            }
            else {
                $self-&gt;_put( $prefix, ' []' );
            }
        }
        else {
            die "Don't know how to encode $ref";
        }
    }
    else {
        $self-&gt;_put( $prefix, ' ', $self-&gt;_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 =&gt; 1,
        two =&gt; 2,
        three =&gt; [ 1, 2, 3 ],
    };
    
    my $yw = TAP::Parser::YAMLish::Writer-&gt;new;
    
    # Write to an array...
    $yw-&gt;write( $data, \@some_array );
    
    # ...an open file handle...
    $yw-&gt;write( $data, $some_file_handle );
    
    # ...a string ...
    $yw-&gt;write( $data, \$some_string );
    
    # ...or a closure
    $yw-&gt;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&lt;new&gt;

 my $writer = TAP::Parser::YAMLish::Writer-&gt;new;

The constructor C&lt;new&gt; creates and returns an empty
C&lt;TAP::Parser::YAMLish::Writer&gt; object.

=head2 Instance Methods

=head3 C&lt;write&gt;

 $writer-&gt;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 =&gt; 1,
        two =&gt; 2,
        three =&gt; [ 1, 2, 3 ],
    };
    
    my $yw = TAP::Parser::YAMLish::Writer-&gt;new;
    $yw-&gt;write( $data, $writer );


The C&lt; $output &gt; 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, &lt;andy@hexten.net&gt;

=head1 SEE ALSO

L&lt;YAML::Tiny&gt;, L&lt;YAML&gt;, L&lt;YAML::Syck&gt;, L&lt;Config::Tiny&gt;, L&lt;CSS::Tiny&gt;,
L&lt;http://use.perl.org/~Alias/journal/29427&gt;

=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

</pre></body></html>