Commit | Line | Data |
3fea05b9 |
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 | |