Filename | /usr/share/perl5/YAML/Types.pm |
Statements | Executed 32 statements in 3.58ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 49.4ms | 52.5ms | BEGIN@137 | YAML::Type::code::
1 | 1 | 1 | 79µs | 184µs | BEGIN@200 | YAML::Type::regexp::
1 | 1 | 1 | 33µs | 43µs | BEGIN@3 | YAML::Types::
1 | 1 | 1 | 31µs | 66µs | BEGIN@4 | YAML::Types::
1 | 1 | 1 | 26µs | 82µs | BEGIN@6 | YAML::Types::
1 | 1 | 1 | 21µs | 84µs | BEGIN@16 | YAML::Type::blessed::
1 | 1 | 1 | 19µs | 95µs | BEGIN@5 | YAML::Types::
1 | 1 | 1 | 18µs | 42µs | BEGIN@97 | YAML::Type::glob::
1 | 1 | 1 | 18µs | 50µs | BEGIN@22 | YAML::Type::blessed::
0 | 0 | 0 | 0s | 0s | yaml_dump | YAML::Type::blessed::
0 | 0 | 0 | 0s | 0s | __ANON__[:163] | YAML::Type::code::
0 | 0 | 0 | 0s | 0s | __ANON__[:171] | YAML::Type::code::
0 | 0 | 0 | 0s | 0s | __ANON__[:172] | YAML::Type::code::
0 | 0 | 0 | 0s | 0s | yaml_dump | YAML::Type::code::
0 | 0 | 0 | 0s | 0s | yaml_load | YAML::Type::code::
0 | 0 | 0 | 0s | 0s | yaml_dump | YAML::Type::glob::
0 | 0 | 0 | 0s | 0s | yaml_load | YAML::Type::glob::
0 | 0 | 0 | 0s | 0s | yaml_dump | YAML::Type::ref::
0 | 0 | 0 | 0s | 0s | yaml_load | YAML::Type::ref::
0 | 0 | 0 | 0s | 0s | __ANON__[:201] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:202] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:203] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:204] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:205] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:206] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:207] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:208] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:209] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:210] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:211] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:212] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:213] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:214] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:215] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:216] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | __ANON__[:225] | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | yaml_dump | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | yaml_load | YAML::Type::regexp::
0 | 0 | 0 | 0s | 0s | yaml_dump | YAML::Type::undef::
0 | 0 | 0 | 0s | 0s | yaml_load | YAML::Type::undef::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package YAML::Types; | ||||
2 | |||||
3 | 3 | 63µs | 2 | 53µs | # spent 43µs (33+10) within YAML::Types::BEGIN@3 which was called:
# once (33µs+10µs) by YAML::Loader::BEGIN@7 at line 3 # spent 43µs making 1 call to YAML::Types::BEGIN@3
# spent 10µs making 1 call to strict::import |
4 | 3 | 62µs | 2 | 101µs | # spent 66µs (31+35) within YAML::Types::BEGIN@4 which was called:
# once (31µs+35µs) by YAML::Loader::BEGIN@7 at line 4 # spent 66µs making 1 call to YAML::Types::BEGIN@4
# spent 35µs making 1 call to warnings::import |
5 | 3 | 51µs | 2 | 170µs | # spent 95µs (19+76) within YAML::Types::BEGIN@5 which was called:
# once (19µs+76µs) by YAML::Loader::BEGIN@7 at line 5 # spent 95µs making 1 call to YAML::Types::BEGIN@5
# spent 76µs making 1 call to Exporter::import |
6 | 3 | 133µs | 2 | 138µs | # spent 82µs (26+56) within YAML::Types::BEGIN@6 which was called:
# once (26µs+56µs) by YAML::Loader::BEGIN@7 at line 6 # spent 82µs making 1 call to YAML::Types::BEGIN@6
# spent 56µs making 1 call to Exporter::import |
7 | |||||
8 | 1 | 2µs | our $VERSION = '0.71'; | ||
9 | 1 | 29µs | our @ISA = 'YAML::Base'; | ||
10 | |||||
11 | # XXX These classes and their APIs could still use some refactoring, | ||||
12 | # but at least they work for now. | ||||
13 | #------------------------------------------------------------------------------- | ||||
14 | package YAML::Type::blessed; | ||||
15 | |||||
16 | 3 | 112µs | 2 | 146µs | # spent 84µs (21+63) within YAML::Type::blessed::BEGIN@16 which was called:
# once (21µs+63µs) by YAML::Loader::BEGIN@7 at line 16 # spent 84µs making 1 call to YAML::Type::blessed::BEGIN@16
# spent 63µs making 1 call to Exporter::import |
17 | |||||
18 | sub yaml_dump { | ||||
19 | my $self = shift; | ||||
20 | my ($value) = @_; | ||||
21 | my ($class, $type) = YAML::Base->node_info($value); | ||||
22 | 3 | 827µs | 2 | 82µs | # spent 50µs (18+32) within YAML::Type::blessed::BEGIN@22 which was called:
# once (18µs+32µs) by YAML::Loader::BEGIN@7 at line 22 # spent 50µs making 1 call to YAML::Type::blessed::BEGIN@22
# spent 32µs making 1 call to strict::unimport |
23 | my $kind = lc($type) . ':'; | ||||
24 | my $tag = ${$class . '::ClassTag'} || | ||||
25 | "!perl/$kind$class"; | ||||
26 | if ($type eq 'REF') { | ||||
27 | YAML::Node->new( | ||||
28 | {(&YAML::VALUE, ${$_[0]})}, $tag | ||||
29 | ); | ||||
30 | } | ||||
31 | elsif ($type eq 'SCALAR') { | ||||
32 | $_[1] = $$value; | ||||
33 | YAML::Node->new($_[1], $tag); | ||||
34 | } else { | ||||
35 | YAML::Node->new($value, $tag); | ||||
36 | } | ||||
37 | } | ||||
38 | |||||
39 | #------------------------------------------------------------------------------- | ||||
40 | package YAML::Type::undef; | ||||
41 | |||||
42 | sub yaml_dump { | ||||
43 | my $self = shift; | ||||
44 | } | ||||
45 | |||||
46 | sub yaml_load { | ||||
47 | my $self = shift; | ||||
48 | } | ||||
49 | |||||
50 | #------------------------------------------------------------------------------- | ||||
51 | package YAML::Type::glob; | ||||
52 | |||||
53 | sub yaml_dump { | ||||
54 | my $self = shift; | ||||
55 | my $ynode = YAML::Node->new({}, '!perl/glob:'); | ||||
56 | for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) { | ||||
57 | my $value = *{$_[0]}{$type}; | ||||
58 | $value = $$value if $type eq 'SCALAR'; | ||||
59 | if (defined $value) { | ||||
60 | if ($type eq 'IO') { | ||||
61 | my @stats = qw(device inode mode links uid gid rdev size | ||||
62 | atime mtime ctime blksize blocks); | ||||
63 | undef $value; | ||||
64 | $value->{stat} = YAML::Node->new({}); | ||||
65 | map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]}); | ||||
66 | $value->{fileno} = fileno(*{$_[0]}); | ||||
67 | { | ||||
68 | local $^W; | ||||
69 | $value->{tell} = tell(*{$_[0]}); | ||||
70 | } | ||||
71 | } | ||||
72 | $ynode->{$type} = $value; | ||||
73 | } | ||||
74 | } | ||||
75 | return $ynode; | ||||
76 | } | ||||
77 | |||||
78 | sub yaml_load { | ||||
79 | my $self = shift; | ||||
80 | my ($node, $class, $loader) = @_; | ||||
81 | my ($name, $package); | ||||
82 | if (defined $node->{NAME}) { | ||||
83 | $name = $node->{NAME}; | ||||
84 | delete $node->{NAME}; | ||||
85 | } | ||||
86 | else { | ||||
87 | $loader->warn('YAML_LOAD_WARN_GLOB_NAME'); | ||||
88 | return undef; | ||||
89 | } | ||||
90 | if (defined $node->{PACKAGE}) { | ||||
91 | $package = $node->{PACKAGE}; | ||||
92 | delete $node->{PACKAGE}; | ||||
93 | } | ||||
94 | else { | ||||
95 | $package = 'main'; | ||||
96 | } | ||||
97 | 3 | 420µs | 2 | 66µs | # spent 42µs (18+24) within YAML::Type::glob::BEGIN@97 which was called:
# once (18µs+24µs) by YAML::Loader::BEGIN@7 at line 97 # spent 42µs making 1 call to YAML::Type::glob::BEGIN@97
# spent 24µs making 1 call to strict::unimport |
98 | if (exists $node->{SCALAR}) { | ||||
99 | *{"${package}::$name"} = \$node->{SCALAR}; | ||||
100 | delete $node->{SCALAR}; | ||||
101 | } | ||||
102 | for my $elem (qw(ARRAY HASH CODE IO)) { | ||||
103 | if (exists $node->{$elem}) { | ||||
104 | if ($elem eq 'IO') { | ||||
105 | $loader->warn('YAML_LOAD_WARN_GLOB_IO'); | ||||
106 | delete $node->{IO}; | ||||
107 | next; | ||||
108 | } | ||||
109 | *{"${package}::$name"} = $node->{$elem}; | ||||
110 | delete $node->{$elem}; | ||||
111 | } | ||||
112 | } | ||||
113 | for my $elem (sort keys %$node) { | ||||
114 | $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem); | ||||
115 | } | ||||
116 | return *{"${package}::$name"}; | ||||
117 | } | ||||
118 | |||||
119 | #------------------------------------------------------------------------------- | ||||
120 | package YAML::Type::code; | ||||
121 | |||||
122 | 1 | 700ns | my $dummy_warned = 0; | ||
123 | 1 | 1µs | my $default = '{ "DUMMY" }'; | ||
124 | |||||
125 | sub yaml_dump { | ||||
126 | my $self = shift; | ||||
127 | my $code; | ||||
128 | my ($dumpflag, $value) = @_; | ||||
129 | my ($class, $type) = YAML::Base->node_info($value); | ||||
130 | my $tag = "!perl/code"; | ||||
131 | $tag .= ":$class" if defined $class; | ||||
132 | if (not $dumpflag) { | ||||
133 | $code = $default; | ||||
134 | } | ||||
135 | else { | ||||
136 | bless $value, "CODE" if $class; | ||||
137 | 3 | 1.53ms | 2 | 52.5ms | # spent 52.5ms (49.4+3.10) within YAML::Type::code::BEGIN@137 which was called:
# once (49.4ms+3.10ms) by YAML::Loader::BEGIN@7 at line 137 # spent 52.5ms making 1 call to YAML::Type::code::BEGIN@137
# spent 8µs making 1 call to UNIVERSAL::import |
138 | return if $@; | ||||
139 | my $deparse = B::Deparse->new(); | ||||
140 | eval { | ||||
141 | local $^W = 0; | ||||
142 | $code = $deparse->coderef2text($value); | ||||
143 | }; | ||||
144 | if ($@) { | ||||
145 | warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W; | ||||
146 | $code = $default; | ||||
147 | } | ||||
148 | bless $value, $class if $class; | ||||
149 | chomp $code; | ||||
150 | $code .= "\n"; | ||||
151 | } | ||||
152 | $_[2] = $code; | ||||
153 | YAML::Node->new($_[2], $tag); | ||||
154 | } | ||||
155 | |||||
156 | sub yaml_load { | ||||
157 | my $self = shift; | ||||
158 | my ($node, $class, $loader) = @_; | ||||
159 | if ($loader->load_code) { | ||||
160 | my $code = eval "package main; sub $node"; | ||||
161 | if ($@) { | ||||
162 | $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@); | ||||
163 | return sub {}; | ||||
164 | } | ||||
165 | else { | ||||
166 | CORE::bless $code, $class if $class; | ||||
167 | return $code; | ||||
168 | } | ||||
169 | } | ||||
170 | else { | ||||
171 | return CORE::bless sub {}, $class if $class; | ||||
172 | return sub {}; | ||||
173 | } | ||||
174 | } | ||||
175 | |||||
176 | #------------------------------------------------------------------------------- | ||||
177 | package YAML::Type::ref; | ||||
178 | |||||
179 | sub yaml_dump { | ||||
180 | my $self = shift; | ||||
181 | YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref') | ||||
182 | } | ||||
183 | |||||
184 | sub yaml_load { | ||||
185 | my $self = shift; | ||||
186 | my ($node, $class, $loader) = @_; | ||||
187 | $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr') | ||||
188 | unless exists $node->{&YAML::VALUE}; | ||||
189 | return \$node->{&YAML::VALUE}; | ||||
190 | } | ||||
191 | |||||
192 | #------------------------------------------------------------------------------- | ||||
193 | package YAML::Type::regexp; | ||||
194 | |||||
195 | # XXX Be sure to handle blessed regexps (if possible) | ||||
196 | sub yaml_dump { | ||||
197 | die "YAML::Type::regexp::yaml_dump not currently implemented"; | ||||
198 | } | ||||
199 | |||||
200 | # spent 184µs (79+105) within YAML::Type::regexp::BEGIN@200 which was called:
# once (79µs+105µs) by YAML::Loader::BEGIN@7 at line 217 | ||||
201 | '' => sub { qr{$_[0]} }, | ||||
202 | x => sub { qr{$_[0]}x }, | ||||
203 | i => sub { qr{$_[0]}i }, | ||||
204 | s => sub { qr{$_[0]}s }, | ||||
205 | m => sub { qr{$_[0]}m }, | ||||
206 | ix => sub { qr{$_[0]}ix }, | ||||
207 | sx => sub { qr{$_[0]}sx }, | ||||
208 | mx => sub { qr{$_[0]}mx }, | ||||
209 | si => sub { qr{$_[0]}si }, | ||||
210 | mi => sub { qr{$_[0]}mi }, | ||||
211 | ms => sub { qr{$_[0]}sm }, | ||||
212 | six => sub { qr{$_[0]}six }, | ||||
213 | mix => sub { qr{$_[0]}mix }, | ||||
214 | msx => sub { qr{$_[0]}msx }, | ||||
215 | msi => sub { qr{$_[0]}msi }, | ||||
216 | msix => sub { qr{$_[0]}msix }, | ||||
217 | 3 | 336µs | 2 | 289µs | }; # spent 184µs making 1 call to YAML::Type::regexp::BEGIN@200
# spent 105µs making 1 call to constant::import |
218 | |||||
219 | sub yaml_load { | ||||
220 | my $self = shift; | ||||
221 | my ($node, $class) = @_; | ||||
222 | return qr{$node} unless $node =~ /^\(\?([\-xism]*):(.*)\)\z/s; | ||||
223 | my ($flags, $re) = ($1, $2); | ||||
224 | $flags =~ s/-.*//; | ||||
225 | my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} }; | ||||
226 | my $qr = &$sub($re); | ||||
227 | bless $qr, $class if length $class; | ||||
228 | return $qr; | ||||
229 | } | ||||
230 | |||||
231 | 1 | 8µs | 1; | ||
232 | |||||
233 | __END__ |