Writer.pm revision 1.2 
1package TAP::Parser::YAMLish::Writer;
2
3use strict;
4use warnings;
5
6use base 'TAP::Object';
7
8our $VERSION = '3.30_01';
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.30
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