File | /usr/share/perl5/YAML/Base.pm |
Statements Executed | 160 |
Total Time | 0.0023892 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
4 | 1 | 1 | 6.11ms | 6.67ms | __ANON__[:168] | YAML::Base::
4 | 4 | 1 | 592µs | 7.36ms | field | YAML::Base::
4 | 1 | 1 | 96µs | 96µs | __ANON__[:158] | YAML::Base::
0 | 0 | 0 | 0s | 0s | BEGIN | YAML::Base::
0 | 0 | 0 | 0s | 0s | XXX | YAML::Base::
0 | 0 | 0 | 0s | 0s | __ANON__[:120] | YAML::Base::
0 | 0 | 0 | 0s | 0s | __ANON__[:129] | YAML::Base::
0 | 0 | 0 | 0s | 0s | __ANON__[:142] | YAML::Base::
0 | 0 | 0 | 0s | 0s | die | YAML::Base::
0 | 0 | 0 | 0s | 0s | new | YAML::Base::
0 | 0 | 0 | 0s | 0s | node_info | YAML::Base::
0 | 0 | 0 | 0s | 0s | warn | YAML::Base::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | package YAML::Base; | |||
2 | 6 | 43µs | 7µs | use strict; use warnings; # spent 23µs making 1 call to warnings::import
# spent 6µs making 1 call to strict::import |
3 | 3 | 542µs | 181µs | use base 'Exporter'; # spent 1.01ms making 1 call to base::import |
4 | ||||
5 | 1 | 2µs | 2µs | our @EXPORT = qw(field XXX); |
6 | ||||
7 | sub new { | |||
8 | my $class = shift; | |||
9 | $class = ref($class) || $class; | |||
10 | my $self = bless {}, $class; | |||
11 | while (@_) { | |||
12 | my $method = shift; | |||
13 | $self->$method(shift); | |||
14 | } | |||
15 | return $self; | |||
16 | } | |||
17 | ||||
18 | # Use lexical subs to reduce pollution of private methods by base class. | |||
19 | 1 | 500ns | 500ns | my ($_new_error, $_info, $_scalar_info, $parse_arguments, $default_as_code); |
20 | ||||
21 | sub XXX { | |||
22 | require Data::Dumper; | |||
23 | CORE::die(Data::Dumper::Dumper(@_)); | |||
24 | } | |||
25 | ||||
26 | 1 | 7µs | 7µs | my %code = ( |
27 | sub_start => | |||
28 | "sub {\n", | |||
29 | set_default => | |||
30 | " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", | |||
31 | init => | |||
32 | " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . | |||
33 | " unless \$#_ > 0 or defined \$_[0]->{%s};\n", | |||
34 | return_if_get => | |||
35 | " return \$_[0]->{%s} unless \$#_ > 0;\n", | |||
36 | set => | |||
37 | " \$_[0]->{%s} = \$_[1];\n", | |||
38 | sub_end => | |||
39 | " return \$_[0]->{%s};\n}\n", | |||
40 | ); | |||
41 | ||||
42 | # spent 7.36ms (592µs+6.77) within YAML::Base::field which was called 4 times, avg 1.84ms/call:
# once (162µs+6.49ms) at line 15 of /usr/share/perl5/YAML.pm
# once (157µs+88µs) at line 17 of /usr/share/perl5/YAML.pm
# once (147µs+85µs) at line 19 of /usr/share/perl5/YAML.pm
# once (127µs+103µs) at line 16 of /usr/share/perl5/YAML.pm | |||
43 | 68 | 562µs | 8µs | my $package = caller; |
44 | my ($args, @values) = &$parse_arguments( # spent 96µs making 4 calls to YAML::Base::__ANON__[/usr/share/perl5/YAML/Base.pm:158], avg 24µs/call | |||
45 | [ qw(-package -init) ], | |||
46 | @_, | |||
47 | ); | |||
48 | my ($field, $default) = @values; | |||
49 | $package = $args->{-package} if defined $args->{-package}; | |||
50 | return if defined &{"${package}::$field"}; | |||
51 | my $default_string = # spent 6.67ms making 4 calls to YAML::Base::__ANON__[/usr/share/perl5/YAML/Base.pm:168], avg 1.67ms/call | |||
52 | ( ref($default) eq 'ARRAY' and not @$default ) | |||
53 | ? '[]' | |||
54 | : (ref($default) eq 'HASH' and not keys %$default ) | |||
55 | ? '{}' | |||
56 | : &$default_as_code($default); | |||
57 | ||||
58 | my $code = $code{sub_start}; | |||
59 | if ($args->{-init}) { | |||
60 | my $fragment = $code{init}; | |||
61 | $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4; | |||
62 | } | |||
63 | $code .= sprintf $code{set_default}, $field, $default_string, $field | |||
64 | if defined $default; | |||
65 | $code .= sprintf $code{return_if_get}, $field; | |||
66 | $code .= sprintf $code{set}, $field; | |||
67 | $code .= sprintf $code{sub_end}, $field; | |||
68 | ||||
69 | 1 | 38µs | 38µs | my $sub = eval $code; |
70 | die $@ if $@; | |||
71 | 3 | 749µs | 250µs | no strict 'refs'; # spent 32µs making 1 call to strict::unimport |
72 | *{"${package}::$field"} = $sub; | |||
73 | return $code if defined wantarray; | |||
74 | } | |||
75 | ||||
76 | sub die { | |||
77 | my $self = shift; | |||
78 | my $error = $self->$_new_error(@_); | |||
79 | $error->type('Error'); | |||
80 | Carp::croak($error->format_message); | |||
81 | } | |||
82 | ||||
83 | sub warn { | |||
84 | my $self = shift; | |||
85 | return unless $^W; | |||
86 | my $error = $self->$_new_error(@_); | |||
87 | $error->type('Warning'); | |||
88 | Carp::cluck($error->format_message); | |||
89 | } | |||
90 | ||||
91 | # This code needs to be refactored to be simpler and more precise, and no, | |||
92 | # Scalar::Util doesn't DWIM. | |||
93 | # | |||
94 | # Can't handle: | |||
95 | # * blessed regexp | |||
96 | sub node_info { | |||
97 | my $self = shift; | |||
98 | my $stringify = $_[1] || 0; | |||
99 | my ($class, $type, $id) = | |||
100 | ref($_[0]) | |||
101 | ? $stringify | |||
102 | ? &$_info("$_[0]") | |||
103 | : do { | |||
104 | require overload; | |||
105 | my @info = &$_info(overload::StrVal($_[0])); | |||
106 | if (ref($_[0]) eq 'Regexp') { | |||
107 | @info[0, 1] = (undef, 'REGEXP'); | |||
108 | } | |||
109 | @info; | |||
110 | } | |||
111 | : &$_scalar_info($_[0]); | |||
112 | ($class, $type, $id) = &$_scalar_info("$_[0]") | |||
113 | unless $id; | |||
114 | return wantarray ? ($class, $type, $id) : $id; | |||
115 | } | |||
116 | ||||
117 | #------------------------------------------------------------------------------- | |||
118 | $_info = sub { | |||
119 | return (($_[0]) =~ qr{^(?:(.*)\=)?([^=]*)\(([^\(]*)\)$}o); | |||
120 | 1 | 3µs | 3µs | }; |
121 | ||||
122 | $_scalar_info = sub { | |||
123 | my $id = 'undef'; | |||
124 | if (defined $_[0]) { | |||
125 | \$_[0] =~ /\((\w+)\)$/o or CORE::die(); | |||
126 | $id = "$1-S"; | |||
127 | } | |||
128 | return (undef, undef, $id); | |||
129 | 1 | 3µs | 3µs | }; |
130 | ||||
131 | $_new_error = sub { | |||
132 | require Carp; | |||
133 | my $self = shift; | |||
134 | require YAML::Error; | |||
135 | ||||
136 | my $code = shift || 'unknown error'; | |||
137 | my $error = YAML::Error->new(code => $code); | |||
138 | $error->line($self->line) if $self->can('line'); | |||
139 | $error->document($self->document) if $self->can('document'); | |||
140 | $error->arguments([@_]); | |||
141 | return $error; | |||
142 | 1 | 15µs | 15µs | }; |
143 | ||||
144 | # spent 96µs within YAML::Base::__ANON__[/usr/share/perl5/YAML/Base.pm:158] which was called 4 times, avg 24µs/call:
# 4 times (96µs+0s) by YAML::Base::field at line 44, avg 24µs/call | |||
145 | 42 | 85µs | 2µs | my $paired_arguments = shift || []; |
146 | my ($args, @values) = ({}, ()); | |||
147 | my %pairs = map { ($_, 1) } @$paired_arguments; | |||
148 | while (@_) { | |||
149 | my $elem = shift; | |||
150 | if (defined $elem and defined $pairs{$elem} and @_) { | |||
151 | $args->{$elem} = shift; | |||
152 | } | |||
153 | else { | |||
154 | push @values, $elem; | |||
155 | } | |||
156 | } | |||
157 | return wantarray ? ($args, @values) : $args; | |||
158 | 1 | 5µs | 5µs | }; |
159 | ||||
160 | # spent 6.67ms (6.11+561µs) within YAML::Base::__ANON__[/usr/share/perl5/YAML/Base.pm:168] which was called 4 times, avg 1.67ms/call:
# 4 times (6.11ms+561µs) by YAML::Base::field at line 51, avg 1.67ms/call | |||
161 | 3 | 111µs | 37µs | no warnings 'once'; # spent 24µs making 1 call to warnings::unimport |
162 | 24 | 192µs | 8µs | require Data::Dumper; |
163 | local $Data::Dumper::Sortkeys = 1; | |||
164 | my $code = Data::Dumper::Dumper(shift); # spent 268µs making 4 calls to Data::Dumper::Dumper, avg 67µs/call | |||
165 | 1 | 20µs | 20µs | $code =~ s/^\$VAR1 = //; |
166 | $code =~ s/;$//; | |||
167 | return $code; | |||
168 | 1 | 2µs | 2µs | }; |
169 | ||||
170 | 1 | 10µs | 10µs | 1; |
171 | ||||
172 | __END__ | |||
173 | ||||
174 | =head1 NAME | |||
175 | ||||
176 | YAML::Base - Base class for YAML classes | |||
177 | ||||
178 | =head1 SYNOPSIS | |||
179 | ||||
180 | package YAML::Something; | |||
181 | use YAML::Base -base; | |||
182 | ||||
183 | =head1 DESCRIPTION | |||
184 | ||||
185 | YAML::Base is the parent of all YAML classes. | |||
186 | ||||
187 | =head1 AUTHOR | |||
188 | ||||
189 | Ingy döt Net <ingy@cpan.org> | |||
190 | ||||
191 | =head1 COPYRIGHT | |||
192 | ||||
193 | Copyright (c) 2006. Ingy döt Net. All rights reserved. | |||
194 | ||||
195 | This program is free software; you can redistribute it and/or modify it | |||
196 | under the same terms as Perl itself. | |||
197 | ||||
198 | See L<http://www.perl.com/perl/misc/Artistic.html> | |||
199 | ||||
200 | =cut |