File Coverage

blib/lib/YAML/XS.pm
Criterion Covered Total %
statement 56 72 77.7
branch 10 14 71.4
condition 1 3 33.3
subroutine 12 13 92.3
pod 0 2 0.0
total 79 104 75.9


line stmt bran cond sub pod time code
1 45     45   317508 use strict; use warnings;
  45     45   147  
  45         1239  
  45         243  
  45         90  
  45         2463  
2              
3             package YAML::XS;
4             our $VERSION = '0.88';
5              
6 45     45   304 use base 'Exporter';
  45         86  
  45         1727  
7              
8             @YAML::XS::EXPORT = qw(Load Dump);
9             @YAML::XS::EXPORT_OK = qw(LoadFile DumpFile);
10             %YAML::XS::EXPORT_TAGS = (
11             all => [qw(Dump Load LoadFile DumpFile)],
12             );
13             our (
14             $Boolean,
15             $DumpCode,
16             $ForbidDuplicateKeys,
17             $Indent,
18             $LoadBlessed,
19             $LoadCode,
20             $UseCode,
21             );
22             $ForbidDuplicateKeys = 0;
23             # $YAML::XS::UseCode = 0;
24             # $YAML::XS::DumpCode = 0;
25             # $YAML::XS::LoadCode = 0;
26              
27             $YAML::XS::QuoteNumericStrings = 1;
28              
29 45     45   19089 use YAML::XS::LibYAML qw(Load Dump);
  45         119  
  45         2934  
30 45     45   360 use Scalar::Util qw/ openhandle /;
  45         82  
  45         46236  
31              
32             sub DumpFile {
33 4     4 0 5865 my $OUT;
34 4         40 my $filename = shift;
35 4 100       437 if (openhandle $filename) {
36 2         10 $OUT = $filename;
37             }
38             else {
39 2         7 my $mode = '>';
40 2 50       10 if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) {
41 0         0 ($mode, $filename) = ($1, $2);
42             }
43 2 50       172 open $OUT, $mode, $filename
44             or die "Can't open '$filename' for output:\n$!";
45             }
46 4         56 local $/ = "\n"; # reset special to "sane"
47 4         799 print $OUT YAML::XS::LibYAML::Dump(@_);
48             }
49              
50             sub LoadFile {
51 5     5 0 2910 my $IN;
52 5         39 my $filename = shift;
53 5 100       419 if (openhandle $filename) {
54 2         11 $IN = $filename;
55             }
56             else {
57 3 50       137 open $IN, $filename
58             or die "Can't open '$filename' for input:\n$!";
59             }
60 5         16 return YAML::XS::LibYAML::Load(do { local $/; local $_ = <$IN> });
  5         40  
  5         1057  
61             }
62              
63              
64             # XXX The following code should be moved from Perl to C.
65             $YAML::XS::coderef2text = sub {
66             my $coderef = shift;
67             require B::Deparse;
68             my $deparse = B::Deparse->new();
69             my $text;
70             eval {
71             local $^W = 0;
72             $text = $deparse->coderef2text($coderef);
73             };
74             if ($@) {
75             warn "YAML::XS failed to dump code ref:\n$@";
76             return;
77             }
78             $text =~ s[BEGIN \{\$\{\^WARNING_BITS\} = "UUUUUUUUUUUU\\001"\}]
79             [use warnings;]g;
80              
81             return $text;
82             };
83              
84             $YAML::XS::glob2hash = sub {
85             my $hash = {};
86             for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
87             my $value = *{$_[0]}{$type};
88             $value = $$value if $type eq 'SCALAR';
89             if (defined $value) {
90             if ($type eq 'IO') {
91             my @stats = qw(device inode mode links uid gid rdev size
92             atime mtime ctime blksize blocks);
93             undef $value;
94             $value->{stat} = {};
95             map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
96             $value->{fileno} = fileno(*{$_[0]});
97             {
98             local $^W;
99             $value->{tell} = tell(*{$_[0]});
100             }
101             }
102             $hash->{$type} = $value;
103             }
104             }
105             return $hash;
106             };
107              
108 5         67 use constant _QR_MAP => {
109 0         0 '' => sub { qr{$_[0]} },
110 0         0 x => sub { qr{$_[0]}x },
111 0         0 i => sub { qr{$_[0]}i },
112 0         0 s => sub { qr{$_[0]}s },
113 0         0 m => sub { qr{$_[0]}m },
114 0         0 ix => sub { qr{$_[0]}ix },
115 0         0 sx => sub { qr{$_[0]}sx },
116 0         0 mx => sub { qr{$_[0]}mx },
117 1         14 si => sub { qr{$_[0]}si },
118 0         0 mi => sub { qr{$_[0]}mi },
119 0         0 ms => sub { qr{$_[0]}sm },
120 0         0 six => sub { qr{$_[0]}six },
121 0         0 mix => sub { qr{$_[0]}mix },
122 0         0 msx => sub { qr{$_[0]}msx },
123 2         53 msi => sub { qr{$_[0]}msi },
124 45     45   395 msix => sub { qr{$_[0]}msix },
  45         124  
  45         17301  
125             };
126              
127 11 100   11   16321 sub __qr_loader {
128 8         37 if ($_[0] =~ /\A \(\? ([\^uixsm]*) (?:- (?:[ixsm]*))? : (.*) \) \z/x) {
129 8         66 my ($flags, $re) = ($1, $2);
130 8         24 $flags =~ s/^\^//;
131 8   33     38 $flags =~ tr/u//d;
132 8         24 my $sub = _QR_MAP->{$flags} || _QR_MAP->{''};
133 8         26753 my $qr = &$sub($re);
134             return $qr;
135 3         98 }
136             return qr/$_[0]/;
137             }
138              
139 2     2   1314 sub __code_loader {
140 2     2   159 my ($string) = @_;
  2     1   665  
  2         42  
  2         63  
  1         6  
  1         2  
  1         32  
141 2 50       13 my $sub = eval "sub $string";
142 0         0 if ($@) {
143 0     0   0 warn "YAML::XS failed to load sub: $@";
144             return sub {};
145 2         35 }
146             return $sub;
147             }
148              
149             1;