local-lib5/lib/perl5/TAP/Parser/YAMLish/Writer.pm

   1 package TAP::Parser::YAMLish::Writer;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA);
   5
   6 use TAP::Object ();
   7
   8 @ISA     = 'TAP::Object';
   9 $VERSION = '3.17';
  10
  11 my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
  12 my $ESCAPE_KEY  = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
  13
  14 my @UNPRINTABLE = qw(
  15   z    x01  x02  x03  x04  x05  x06  a
  16   x08  t    n    v    f    r    x0e  x0f
  17   x10  x11  x12  x13  x14  x15  x16  x17
  18   x18  x19  x1a  e    x1c  x1d  x1e  x1f
  19 );
  20
  21 # new() implementation supplied by TAP::Object
  22
  23 sub write {
  24     my $self = shift;
  25
  26     die "Need something to write"
  27       unless @_;
  28
  29     my $obj = shift;
  30     my $out = shift || \*STDOUT;
  31
  32     die "Need a reference to something I can write to"
  33       unless ref $out;
  34
  35     $self->{writer} = $self->_make_writer($out);
  36
  37     $self->_write_obj( '---', $obj );
  38     $self->_put('...');
  39
  40     delete $self->{writer};
  41 }
  42
  43 sub _make_writer {
  44     my $self = shift;
  45     my $out  = shift;
  46
  47     my $ref = ref $out;
  48
  49     if ( 'CODE' eq $ref ) {
  50         return $out;
  51     }
  52     elsif ( 'ARRAY' eq $ref ) {
  53         return sub { push @$out, shift };
  54     }
  55     elsif ( 'SCALAR' eq $ref ) {
  56         return sub { $$out .= shift() . "\n" };
  57     }
  58     elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
  59         return sub { print $out shift(), "\n" };
  60     }
  61
  62     die "Can't write to $out";
  63 }
  64
  65 sub _put {
  66     my $self = shift;
  67     $self->{writer}->( join '', @_ );
  68 }
  69
  70 sub _enc_scalar {
  71     my $self = shift;
  72     my $val  = shift;
  73     my $rule = shift;
  74
  75     return '~' unless defined $val;
  76
  77     if ( $val =~ /$rule/ ) {
  78         $val =~ s/\\/\\\\/g;
  79         $val =~ s/"/\\"/g;
  80         $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
  81         return qq{"$val"};
  82     }
  83
  84     if ( length($val) == 0 or $val =~ /\s/ ) {
  85         $val =~ s/'/''/;
  86         return "'$val'";
  87     }
  88
  89     return $val;
  90 }
  91
  92 sub _write_obj {
  93     my $self   = shift;
  94     my $prefix = shift;
  95     my $obj    = shift;
  96     my $indent = shift || 0;
  97
  98     if ( my $ref = ref $obj ) {
  99         my $pad = '  ' x $indent;
 100         if ( 'HASH' eq $ref ) {
 101             if ( keys %$obj ) {
 102                 $self->_put($prefix);
 103                 for my $key ( sort keys %$obj ) {
 104                     my $value = $obj->{$key};
 105                     $self->_write_obj(
 106                         $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':',
 107                         $value, $indent + 1
 108                     );
 109                 }
 110             }
 111             else {
 112                 $self->_put( $prefix, ' {}' );
 113             }
 114         }
 115         elsif ( 'ARRAY' eq $ref ) {
 116             if (@$obj) {
 117                 $self->_put($prefix);
 118                 for my $value (@$obj) {
 119                     $self->_write_obj(
 120                         $pad . '-', $value,
 121                         $indent + 1
 122                     );
 123                 }
 124             }
 125             else {
 126                 $self->_put( $prefix, ' []' );
 127             }
 128         }
 129         else {
 130             die "Don't know how to encode $ref";
 131         }
 132     }
 133     else {
 134         $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) );
 135     }
 136 }
 137
 138 1;
 139
 140 __END__
 141
 142 =pod
 143
 144 =head1 NAME
 145
 146 TAP::Parser::YAMLish::Writer - Write YAMLish data
 147
 148 =head1 VERSION
 149
 150 Version 3.17
 151
 152 =head1 SYNOPSIS
 153
 154     use TAP::Parser::YAMLish::Writer;
 155
 156     my $data = {
 157         one => 1,
 158         two => 2,
 159         three => [ 1, 2, 3 ],
 160     };
 161
 162     my $yw = TAP::Parser::YAMLish::Writer->new;
 163
 164     # Write to an array...
 165     $yw->write( $data, \@some_array );
 166
 167     # ...an open file handle...
 168     $yw->write( $data, $some_file_handle );
 169
 170     # ...a string ...
 171     $yw->write( $data, \$some_string );
 172
 173     # ...or a closure
 174     $yw->write( $data, sub {
 175         my $line = shift;
 176         print "$line\n";
 177     } );
 178
 179 =head1 DESCRIPTION
 180
 181 Encodes a scalar, hash reference or array reference as YAMLish.
 182
 183 =head1 METHODS
 184
 185 =head2 Class Methods
 186
 187 =head3 C<new>
 188
 189  my $writer = TAP::Parser::YAMLish::Writer->new;
 190
 191 The constructor C<new> creates and returns an empty
 192 C<TAP::Parser::YAMLish::Writer> object.
 193
 194 =head2 Instance Methods
 195
 196 =head3 C<write>
 197
 198  $writer->write($obj, $output );
 199
 200 Encode a scalar, hash reference or array reference as YAML.
 201
 202     my $writer = sub {
 203         my $line = shift;
 204         print SOMEFILE "$line\n";
 205     };
 206
 207     my $data = {
 208         one => 1,
 209         two => 2,
 210         three => [ 1, 2, 3 ],
 211     };
 212
 213     my $yw = TAP::Parser::YAMLish::Writer->new;
 214     $yw->write( $data, $writer );
 215
 216
 217 The C< $output > argument may be:
 218
 219 =over
 220
 221 =item * a reference to a scalar to append YAML to
 222
 223 =item * the handle of an open file
 224
 225 =item * a reference to an array into which YAML will be pushed
 226
 227 =item * a code reference
 228
 229 =back
 230
 231 If you supply a code reference the subroutine will be called once for
 232 each line of output with the line as its only argument. Passed lines
 233 will have no trailing newline.
 234
 235 =head1 AUTHOR
 236
 237 Andy Armstrong, <andy@hexten.net>
 238
 239 =head1 SEE ALSO
 240
 241 L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
 242 L<http://use.perl.org/~Alias/journal/29427>
 243
 244 =head1 COPYRIGHT
 245
 246 Copyright 2007-2008 Andy Armstrong.
 247
 248 This program is free software; you can redistribute
 249 it and/or modify it under the same terms as Perl itself.
 250
 251 The full text of the license can be found in the
 252 LICENSE file included with this module.
 253
 254 =cut
 255