Profile of /usr/local/lib/perl5/site_perl/5.10.1/URI/_generic.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For 01.HTTP.t
Run on Tue May 4 15:25:55 2010
Reported on Tue May 4 15:26:10 2010

File | /usr/local/lib/perl5/site_perl/5.10.1/URI/_generic.pm
Statements Executed | 125
Statement Execution Time | 1.62ms

Subroutines — ordered by exclusive time
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
21 | 4 | 3 | 171µs | 291µs | URI::_generic::::authorityURI::_generic::authority
27 | 3 | 2 | 114µs | 114µs | URI::_generic::::CORE:matchURI::_generic::CORE:match (opcode)
3 | 1 | 1 | 27µs | 36µs | URI::_generic::::pathURI::_generic::path
1 | 1 | 2 | 24µs | 24µs | URI::_generic::::CORE:regcompURI::_generic::CORE:regcomp (opcode)
3 | 1 | 1 | 21µs | 30µs | URI::_generic::::path_queryURI::_generic::path_query
1 | 1 | 1 | 15µs | 18µs | URI::_generic::::BEGIN@6URI::_generic::BEGIN@6
2 | 2 | 2 | 7µs | 7µs | URI::_generic::::CORE:substURI::_generic::CORE:subst (opcode)
1 | 1 | 1 | 7µs | 31µs | URI::_generic::::BEGIN@7URI::_generic::BEGIN@7
1 | 1 | 1 | 4µs | 4µs | URI::_generic::::BEGIN@8URI::_generic::BEGIN@8
0 | 0 | 0 | 0s | 0s | URI::_generic::::_check_pathURI::_generic::_check_path
0 | 0 | 0 | 0s | 0s | URI::_generic::::_no_scheme_okURI::_generic::_no_scheme_ok
0 | 0 | 0 | 0s | 0s | URI::_generic::::_split_segmentURI::_generic::_split_segment
0 | 0 | 0 | 0s | 0s | URI::_generic::::absURI::_generic::abs
0 | 0 | 0 | 0s | 0s | URI::_generic::::path_segmentsURI::_generic::path_segments
0 | 0 | 0 | 0s | 0s | URI::_generic::::relURI::_generic::rel

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package URI::_generic;
2 | 1 | 800ns |  |  | require URI;
3 | 1 | 79µs |  |  | require URI::_query;
4 | 1 | 11µs |  |  | @ISA=qw(URI URI::_query);
5 |  |  |  |  |
6 | 3 | 23µs | 2 | 21µs | # spent 18µs (15+3) within URI::_generic::BEGIN@6 which was called # once (15µs+3µs) by URI::implementor at line 6 use strict; # spent 18µs making 1 call to URI::_generic::BEGIN@6 # spent 3µs making 1 call to strict::import
7 | 3 | 21µs | 2 | 55µs | # spent 31µs (7+24) within URI::_generic::BEGIN@7 which was called # once (7µs+24µs) by URI::implementor at line 7 use URI::Escape qw(uri_unescape); # spent 31µs making 1 call to URI::_generic::BEGIN@7 # spent 24µs making 1 call to Exporter::import
8 | 3 | 1.08ms | 1 | 4µs | # spent 4µs within URI::_generic::BEGIN@8 which was called # once (4µs+0s) by URI::implementor at line 8 use Carp (); # spent 4µs making 1 call to URI::_generic::BEGIN@8
9 |  |  |  |  |
10 | 2 | 13µs | 1 | 6µs | my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g; # spent 6µs making 1 call to URI::_generic::CORE:subst
11 | 2 | 4µs | 1 | 1µs | my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g; # spent 1µs making 1 call to URI::_generic::CORE:subst
12 |  |  |  |  |
13 |  |  |  |  | sub _no_scheme_ok { 1 }
14 |  |  |  |  |
15 |  |  |  |  | sub authority
16 |  |  |  |  | # spent 291µs (171+120) within URI::_generic::authority which was called 21 times, avg 14µs/call: # 9 times (94µs+68µs) by URI::_server::host at line 67 of URI/_server.pm, avg 18µs/call # 6 times (29µs+16µs) by URI::_server::_port at line 107 of URI/_server.pm, avg 8µs/call # 3 times (31µs+26µs) by LWP::Protocol::http::_fixup_header at line 87 of LWP/Protocol/http.pm, avg 19µs/call # 3 times (18µs+9µs) by URI::http::canonical at line 15 of URI/http.pm, avg 9µs/call {
17 | 84 | 308µs |  |  | my $self = shift;
18 |  |  |  |  | $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die; # spent 96µs making 21 calls to URI::_generic::CORE:match, avg 5µs/call # spent 24µs making 1 call to URI::_generic::CORE:regcomp
19 |  |  |  |  |
20 |  |  |  |  | if (@_) {
21 |  |  |  |  | my $auth = shift;
22 |  |  |  |  | $$self = $1;
23 |  |  |  |  | my $rest = $3;
24 |  |  |  |  | if (defined $auth) {
25 |  |  |  |  | $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego;
26 |  |  |  |  | $$self .= "//$auth";
27 |  |  |  |  | }
28 |  |  |  |  | _check_path($rest, $$self);
29 |  |  |  |  | $$self .= $rest;
30 |  |  |  |  | }
31 |  |  |  |  | $2;
32 |  |  |  |  | }
33 |  |  |  |  |
34 |  |  |  |  | sub path
35 |  |  |  |  | # spent 36µs (27+9) within URI::_generic::path which was called 3 times, avg 12µs/call: # 3 times (27µs+9µs) by URI::http::canonical at line 15 of URI/http.pm, avg 12µs/call {
36 | 12 | 38µs |  |  | my $self = shift;
37 |  |  |  |  | $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die; # spent 9µs making 3 calls to URI::_generic::CORE:match, avg 3µs/call
38 |  |  |  |  |
39 |  |  |  |  | if (@_) {
40 |  |  |  |  | $$self = $1;
41 |  |  |  |  | my $rest = $3;
42 |  |  |  |  | my $new_path = shift;
43 |  |  |  |  | $new_path = "" unless defined $new_path;
44 |  |  |  |  | $new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego;
45 |  |  |  |  | _check_path($new_path, $$self);
46 |  |  |  |  | $$self .= $new_path . $rest;
47 |  |  |  |  | }
48 |  |  |  |  | $2;
49 |  |  |  |  | }
50 |  |  |  |  |
51 |  |  |  |  | sub path_query
52 |  |  |  |  | # spent 30µs (21+9) within URI::_generic::path_query which was called 3 times, avg 10µs/call: # 3 times (21µs+9µs) by LWP::Protocol::http::request at line 150 of LWP/Protocol/http.pm, avg 10µs/call {
53 | 12 | 33µs |  |  | my $self = shift;
54 |  |  |  |  | $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die; # spent 8µs making 3 calls to URI::_generic::CORE:match, avg 3µs/call
55 |  |  |  |  |
56 |  |  |  |  | if (@_) {
57 |  |  |  |  | $$self = $1;
58 |  |  |  |  | my $rest = $3;
59 |  |  |  |  | my $new_path = shift;
60 |  |  |  |  | $new_path = "" unless defined $new_path;
61 |  |  |  |  | $new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
62 |  |  |  |  | _check_path($new_path, $$self);
63 |  |  |  |  | $$self .= $new_path . $rest;
64 |  |  |  |  | }
65 |  |  |  |  | $2;
66 |  |  |  |  | }
67 |  |  |  |  |
68 |  |  |  |  | sub _check_path
69 |  |  |  |  | {
70 |  |  |  |  | my($path, $pre) = @_;
71 |  |  |  |  | my $prefix;
72 |  |  |  |  | if ($pre =~ m,/,) { # authority present
73 |  |  |  |  | $prefix = "/" if length($path) && $path !~ m,^[/?\#],;
74 |  |  |  |  | }
75 |  |  |  |  | else {
76 |  |  |  |  | if ($path =~ m,^//,) {
77 |  |  |  |  | Carp::carp("Path starting with double slash is confusing")
78 |  |  |  |  | if $^W;
79 |  |  |  |  | }
80 |  |  |  |  | elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
81 |  |  |  |  | Carp::carp("Path might look like scheme, './' prepended")
82 |  |  |  |  | if $^W;
83 |  |  |  |  | $prefix = "./";
84 |  |  |  |  | }
85 |  |  |  |  | }
86 |  |  |  |  | substr($_[0], 0, 0) = $prefix if defined $prefix;
87 |  |  |  |  | }
88 |  |  |  |  |
89 |  |  |  |  | sub path_segments
90 |  |  |  |  | {
91 |  |  |  |  | my $self = shift;
92 |  |  |  |  | my $path = $self->path;
93 |  |  |  |  | if (@_) {
94 |  |  |  |  | my @arg = @_; # make a copy
95 |  |  |  |  | for (@arg) {
96 |  |  |  |  | if (ref($_)) {
97 |  |  |  |  | my @seg = @$_;
98 |  |  |  |  | $seg[0] =~ s/%/%25/g;
99 |  |  |  |  | for (@seg) { s/;/%3B/g; }
100 |  |  |  |  | $_ = join(";", @seg);
101 |  |  |  |  | }
102 |  |  |  |  | else {
103 |  |  |  |  | s/%/%25/g; s/;/%3B/g;
104 |  |  |  |  | }
105 |  |  |  |  | s,/,%2F,g;
106 |  |  |  |  | }
107 |  |  |  |  | $self->path(join("/", @arg));
108 |  |  |  |  | }
109 |  |  |  |  | return $path unless wantarray;
110 |  |  |  |  | map {/;/ ? $self->_split_segment($_)
111 |  |  |  |  | : uri_unescape($_) }
112 |  |  |  |  | split('/', $path, -1);
113 |  |  |  |  | }
114 |  |  |  |  |
115 |  |  |  |  |
116 |  |  |  |  | sub _split_segment
117 |  |  |  |  | {
118 |  |  |  |  | my $self = shift;
119 |  |  |  |  | require URI::_segment;
120 |  |  |  |  | URI::_segment->new(@_);
121 |  |  |  |  | }
122 |  |  |  |  |
123 |  |  |  |  |
124 |  |  |  |  | sub abs
125 |  |  |  |  | {
126 |  |  |  |  | my $self = shift;
127 |  |  |  |  | my $base = shift || Carp::croak("Missing base argument");
128 |  |  |  |  |
129 |  |  |  |  | if (my $scheme = $self->scheme) {
130 |  |  |  |  | return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
131 |  |  |  |  | $base = URI->new($base) unless ref $base;
132 |  |  |  |  | return $self unless $scheme eq $base->scheme;
133 |  |  |  |  | }
134 |  |  |  |  |
135 |  |  |  |  | $base = URI->new($base) unless ref $base;
136 |  |  |  |  | my $abs = $self->clone;
137 |  |  |  |  | $abs->scheme($base->scheme);
138 |  |  |  |  | return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
139 |  |  |  |  | $abs->authority($base->authority);
140 |  |  |  |  |
141 |  |  |  |  | my $path = $self->path;
142 |  |  |  |  | return $abs if $path =~ m,^/,;
143 |  |  |  |  |
144 |  |  |  |  | if (!length($path)) {
145 |  |  |  |  | my $abs = $base->clone;
146 |  |  |  |  | my $query = $self->query;
147 |  |  |  |  | $abs->query($query) if defined $query;
148 |  |  |  |  | $abs->fragment($self->fragment);
149 |  |  |  |  | return $abs;
150 |  |  |  |  | }
151 |  |  |  |  |
152 |  |  |  |  | my $p = $base->path;
153 |  |  |  |  | $p =~ s,[^/]+$,,;
154 |  |  |  |  | $p .= $path;
155 |  |  |  |  | my @p = split('/', $p, -1);
156 |  |  |  |  | shift(@p) if @p && !length($p[0]);
157 |  |  |  |  | my $i = 1;
158 |  |  |  |  | while ($i < @p) {
159 |  |  |  |  | #print "$i ", join("/", @p), " ($p[$i])\n";
160 |  |  |  |  | if ($p[$i-1] eq ".") {
161 |  |  |  |  | splice(@p, $i-1, 1);
162 |  |  |  |  | $i-- if $i > 1;
163 |  |  |  |  | }
164 |  |  |  |  | elsif ($p[$i] eq ".." && $p[$i-1] ne "..") {
165 |  |  |  |  | splice(@p, $i-1, 2);
166 |  |  |  |  | if ($i > 1) {
167 |  |  |  |  | $i--;
168 |  |  |  |  | push(@p, "") if $i == @p;
169 |  |  |  |  | }
170 |  |  |  |  | }
171 |  |  |  |  | else {
172 |  |  |  |  | $i++;
173 |  |  |  |  | }
174 |  |  |  |  | }
175 |  |  |  |  | $p[-1] = "" if @p && $p[-1] eq "."; # trailing "/."
176 |  |  |  |  | if ($URI::ABS_REMOTE_LEADING_DOTS) {
177 |  |  |  |  | shift @p while @p && $p[0] =~ /^\.\.?$/;
178 |  |  |  |  | }
179 |  |  |  |  | $abs->path("/" . join("/", @p));
180 |  |  |  |  | $abs;
181 |  |  |  |  | }
182 |  |  |  |  |
183 |  |  |  |  | # The oposite of $url->abs. Return a URI which is as relative as possible
184 |  |  |  |  | sub rel {
185 |  |  |  |  | my $self = shift;
186 |  |  |  |  | my $base = shift || Carp::croak("Missing base argument");
187 |  |  |  |  | my $rel = $self->clone;
188 |  |  |  |  | $base = URI->new($base) unless ref $base;
189 |  |  |  |  |
190 |  |  |  |  | #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)};
191 |  |  |  |  | my $scheme = $rel->scheme;
192 |  |  |  |  | my $auth = $rel->canonical->authority;
193 |  |  |  |  | my $path = $rel->path;
194 |  |  |  |  |
195 |  |  |  |  | if (!defined($scheme) && !defined($auth)) {
196 |  |  |  |  | # it is already relative
197 |  |  |  |  | return $rel;
198 |  |  |  |  | }
199 |  |  |  |  |
200 |  |  |  |  | #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)};
201 |  |  |  |  | my $bscheme = $base->scheme;
202 |  |  |  |  | my $bauth = $base->canonical->authority;
203 |  |  |  |  | my $bpath = $base->path;
204 |  |  |  |  |
205 |  |  |  |  | for ($bscheme, $bauth, $auth) {
206 |  |  |  |  | $_ = '' unless defined
207 |  |  |  |  | }
208 |  |  |  |  |
209 |  |  |  |  | unless ($scheme eq $bscheme && $auth eq $bauth) {
210 |  |  |  |  | # different location, can't make it relative
211 |  |  |  |  | return $rel;
212 |  |  |  |  | }
213 |  |  |  |  |
214 |  |  |  |  | for ($path, $bpath) { $_ = "/$_" unless m,^/,; }
215 |  |  |  |  |
216 |  |  |  |  | # Make it relative by eliminating scheme and authority
217 |  |  |  |  | $rel->scheme(undef);
218 |  |  |  |  | $rel->authority(undef);
219 |  |  |  |  |
220 |  |  |  |  | # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>.
221 |  |  |  |  | # First we calculate common initial path components length ($li).
222 |  |  |  |  | my $li = 1;
223 |  |  |  |  | while (1) {
224 |  |  |  |  | my $i = index($path, '/', $li);
225 |  |  |  |  | last if $i < 0 ||
226 |  |  |  |  | $i != index($bpath, '/', $li) ||
227 |  |  |  |  | substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
228 |  |  |  |  | $li=$i+1;
229 |  |  |  |  | }
230 |  |  |  |  | # then we nuke it from both paths
231 |  |  |  |  | substr($path, 0,$li) = '';
232 |  |  |  |  | substr($bpath,0,$li) = '';
233 |  |  |  |  |
234 |  |  |  |  | if ($path eq $bpath &&
235 |  |  |  |  | defined($rel->fragment) &&
236 |  |  |  |  | !defined($rel->query)) {
237 |  |  |  |  | $rel->path("");
238 |  |  |  |  | }
239 |  |  |  |  | else {
240 |  |  |  |  | # Add one "../" for each path component left in the base path
241 |  |  |  |  | $path = ('../' x $bpath =~ tr|/|/|) . $path;
242 |  |  |  |  | $path = "./" if $path eq "";
243 |  |  |  |  | $rel->path($path);
244 |  |  |  |  | }
245 |  |  |  |  |
246 |  |  |  |  | $rel;
247 |  |  |  |  | }
248 |  |  |  |  |
249 | 1 | 10µs |  |  | 1;
|  |  |  |  | # spent 114µs within URI::_generic::CORE:match which was called 27 times, avg 4µs/call: # 21 times (96µs+0s) by URI::_generic::authority at line 18 of URI/_generic.pm, avg 5µs/call # 3 times (9µs+0s) by URI::_generic::path at line 37 of URI/_generic.pm, avg 3µs/call # 3 times (8µs+0s) by URI::_generic::path_query at line 54 of URI/_generic.pm, avg 3µs/call sub URI::_generic::CORE:match; # xsub
|  |  |  |  | # spent 24µs within URI::_generic::CORE:regcomp which was called # once (24µs+0s) by URI::_generic::authority at line 18 of URI/_generic.pm sub URI::_generic::CORE:regcomp; # xsub
|  |  |  |  | # spent 7µs within URI::_generic::CORE:subst which was called 2 times, avg 4µs/call: # once (6µs+0s) by URI::implementor at line 10 of URI/_generic.pm # once (1µs+0s) by URI::implementor at line 11 of URI/_generic.pm sub URI::_generic::CORE:subst; # xsub