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