1package TAP::Parser::YAMLish::Writer;
2
3use strict;
4use vars qw($VERSION @ISA);
5
6use TAP::Object ();
7
8@ISA     = 'TAP::Object';
9$VERSION = '3.23';
10
11my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
12my $ESCAPE_KEY  = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
13
14my @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
23sub 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
43sub _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
65sub _put {
66    my $self = shift;
67    $self->{writer}->( join '', @_ );
68}
69
70sub _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
92sub _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
1381;
139
140__END__
141
142=pod
143
144=head1 NAME
145
146TAP::Parser::YAMLish::Writer - Write YAMLish data
147
148=head1 VERSION
149
150Version 3.23
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
181Encodes 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
191The constructor C<new> creates and returns an empty
192C<TAP::Parser::YAMLish::Writer> object.
193
194=head2 Instance Methods
195
196=head3 C<write>
197
198 $writer->write($obj, $output );
199
200Encode 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
217The 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
231If you supply a code reference the subroutine will be called once for
232each line of output with the line as its only argument. Passed lines
233will have no trailing newline.
234
235=head1 AUTHOR
236
237Andy Armstrong, <andy@hexten.net>
238
239=head1 SEE ALSO
240
241L<YAML::Tiny>, L<YAML>, L<YAML::Syck>, L<Config::Tiny>, L<CSS::Tiny>,
242L<http://use.perl.org/~Alias/journal/29427>
243
244=head1 COPYRIGHT
245
246Copyright 2007-2011 Andy Armstrong.
247
248This program is free software; you can redistribute
249it and/or modify it under the same terms as Perl itself.
250
251The full text of the license can be found in the
252LICENSE file included with this module.
253
254=cut
255
256