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