File Coverage

blib/lib/TAP/Parser/YAMLish/Writer.pm
Criterion Covered Total %
statement 62 66 93.9
branch 22 28 78.5
condition 5 10 50.0
subroutine 10 11 90.9
pod 1 1 100.0
total 100 116 86.2


line stmt bran cond sub pod time code
1             package TAP::Parser::YAMLish::Writer;
2              
3 10     10   25947 use strict;
  10         11  
  10         259  
4 10     10   36 use warnings;
  10         13  
  10         289  
5              
6 10     10   41 use base 'TAP::Object';
  10         13  
  10         6672  
7              
8             our $VERSION = '3.38';
9              
10             my $ESCAPE_CHAR = qr{ [ \x00-\x1f \" ] }x;
11             my $ESCAPE_KEY = qr{ (?: ^\W ) | $ESCAPE_CHAR }x;
12              
13             my @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              
22             sub write {
23 20     20 1 20 my $self = shift;
24              
25 20 50       39 die "Need something to write"
26             unless @_;
27              
28 20         18 my $obj = shift;
29 20   50     33 my $out = shift || \*STDOUT;
30              
31 20 50       37 die "Need a reference to something I can write to"
32             unless ref $out;
33              
34 20         29 $self->{writer} = $self->_make_writer($out);
35              
36 20         32 $self->_write_obj( '---', $obj );
37 20         61 $self->_put('...');
38              
39 20         64 delete $self->{writer};
40             }
41              
42             sub _make_writer {
43 20     20   27 my $self = shift;
44 20         13 my $out = shift;
45              
46 20         25 my $ref = ref $out;
47              
48 20 100 0     38 if ( 'CODE' eq $ref ) {
    100          
    50          
    0          
49 18         31 return $out;
50             }
51             elsif ( 'ARRAY' eq $ref ) {
52 1     26   5 return sub { push @$out, shift };
  26         53  
53             }
54             elsif ( 'SCALAR' eq $ref ) {
55 1     26   6 return sub { $$out .= shift() . "\n" };
  26         64  
56             }
57             elsif ( 'GLOB' eq $ref || 'IO::Handle' eq $ref ) {
58 0     0   0 return sub { print $out shift(), "\n" };
  0         0  
59             }
60              
61 0         0 die "Can't write to $out";
62             }
63              
64             sub _put {
65 168     168   115 my $self = shift;
66 168         348 $self->{writer}->( join '', @_ );
67             }
68              
69             sub _enc_scalar {
70 212     212   182 my $self = shift;
71 212         133 my $val = shift;
72 212         129 my $rule = shift;
73              
74 212 100       263 return '~' unless defined $val;
75              
76 209 100       632 if ( $val =~ /$rule/ ) {
77 19         22 $val =~ s/\\/\\\\/g;
78 19         16 $val =~ s/"/\\"/g;
79 19         38 $val =~ s/ ( [\x00-\x1f] ) / '\\' . $UNPRINTABLE[ ord($1) ] /gex;
  16         40  
80 19         50 return qq{"$val"};
81             }
82              
83 190 100 66     619 if ( length($val) == 0 or $val =~ /\s/ ) {
84 3         3 $val =~ s/'/''/;
85 3         8 return "'$val'";
86             }
87              
88 187         379 return $val;
89             }
90              
91             sub _write_obj {
92 148     148   106 my $self = shift;
93 148         100 my $prefix = shift;
94 148         110 my $obj = shift;
95 148   100     218 my $indent = shift || 0;
96              
97 148 100       202 if ( my $ref = ref $obj ) {
98 41         46 my $pad = ' ' x $indent;
99 41 100       61 if ( 'HASH' eq $ref ) {
    50          
100 30 100       54 if ( keys %$obj ) {
101 28         34 $self->_put($prefix);
102 28         121 for my $key ( sort keys %$obj ) {
103 105         239 my $value = $obj->{$key};
104 105         117 $self->_write_obj(
105             $pad . $self->_enc_scalar( $key, $ESCAPE_KEY ) . ':',
106             $value, $indent + 1
107             );
108             }
109             }
110             else {
111 2         3 $self->_put( $prefix, ' {}' );
112             }
113             }
114             elsif ( 'ARRAY' eq $ref ) {
115 11 100       17 if (@$obj) {
116 9         15 $self->_put($prefix);
117 9         26 for my $value (@$obj) {
118 23         61 $self->_write_obj(
119             $pad . '-', $value,
120             $indent + 1
121             );
122             }
123             }
124             else {
125 2         4 $self->_put( $prefix, ' []' );
126             }
127             }
128             else {
129 0         0 die "Don't know how to encode $ref";
130             }
131             }
132             else {
133 107         119 $self->_put( $prefix, ' ', $self->_enc_scalar( $obj, $ESCAPE_CHAR ) );
134             }
135             }
136              
137             1;
138              
139             __END__