| 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 | YAML::Base::__ANON__[:168] |
| 4 | 4 | 1 | 592µs | 7.36ms | YAML::Base::field |
| 4 | 1 | 1 | 96µs | 96µs | YAML::Base::__ANON__[:158] |
| 0 | 0 | 0 | 0s | 0s | YAML::Base::BEGIN |
| 0 | 0 | 0 | 0s | 0s | YAML::Base::XXX |
| 0 | 0 | 0 | 0s | 0s | YAML::Base::__ANON__[:120] |
| 0 | 0 | 0 | 0s | 0s | YAML::Base::__ANON__[:129] |
| 0 | 0 | 0 | 0s | 0s | YAML::Base::__ANON__[:142] |
| 0 | 0 | 0 | 0s | 0s | YAML::Base::die |
| 0 | 0 | 0 | 0s | 0s | YAML::Base::new |
| 0 | 0 | 0 | 0s | 0s | YAML::Base::node_info |
| 0 | 0 | 0 | 0s | 0s | YAML::Base::warn |
| 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 | 64 | 551µs | 9µ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 | 4 | 10µs | 3µs | 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 | 20 | 48µs | 2µs | my $paired_arguments = shift || []; |
| 146 | my ($args, @values) = ({}, ()); | |||
| 147 | my %pairs = map { ($_, 1) } @$paired_arguments; | |||
| 148 | while (@_) { | |||
| 149 | 16 | 32µs | 2µs | my $elem = shift; |
| 150 | 6 | 5µs | 817ns | 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 |