← Index
NYTProf Performance Profile   « block view • line view • sub view »
For ddd2.pl
  Run on Tue May 25 16:52:24 2010
Reported on Tue May 25 16:57:02 2010

File /project/perl/lib/URI/_generic.pm
Statements Executed 7393
Statement Execution Time 113ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
13833257.2ms79.2msURI::_generic::::authorityURI::_generic::authority
18442230.9ms30.9msURI::_generic::::CORE:matchURI::_generic::CORE:match (opcode)
4611117.6ms26.6msURI::_generic::::path_queryURI::_generic::path_query
11269µs69µsURI::_generic::::CORE:regcompURI::_generic::CORE:regcomp (opcode)
22229µs29µsURI::_generic::::CORE:substURI::_generic::CORE:subst (opcode)
0000s0sURI::_generic::::BEGINURI::_generic::BEGIN
0000s0sURI::_generic::::_check_pathURI::_generic::_check_path
0000s0sURI::_generic::::_no_scheme_okURI::_generic::_no_scheme_ok
0000s0sURI::_generic::::_split_segmentURI::_generic::_split_segment
0000s0sURI::_generic::::absURI::_generic::abs
0000s0sURI::_generic::::pathURI::_generic::path
0000s0sURI::_generic::::path_segmentsURI::_generic::path_segments
0000s0sURI::_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
1package URI::_generic;
216µsrequire URI;
31196µsrequire URI::_query;
4112µs@ISA=qw(URI URI::_query);
5
63118µs124µsuse strict;
# spent 24µs making 1 call to strict::import
7388µs1184µsuse URI::Escape qw(uri_unescape);
# spent 184µs making 1 call to Exporter::import
832.92msuse Carp ();
9
10270µs119µsmy $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g;
# spent 19µs making 1 call to URI::_generic::CORE:subst
11232µs110µsmy $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g;
# spent 10µs making 1 call to URI::_generic::CORE:subst
12
13sub _no_scheme_ok { 1 }
14
15sub authority
16
# spent 79.2ms (57.2+21.9) within URI::_generic::authority which was called 1383 times, avg 57µs/call: # 461 times (21.1ms+9.60ms) by LWP::Protocol::http::_fixup_header at line 85 of LWP/Protocol/http.pm, avg 67µs/call # 461 times (19.5ms+6.87ms) by URI::_server::host at line 31 of URI/_server.pm, avg 57µs/call # 461 times (16.5ms+5.47ms) by URI::_server::_port at line 54 of URI/_server.pm, avg 48µs/call
{
1713836.47ms my $self = shift;
18138344.0ms138421.9ms $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die;
# spent 21.9ms making 1383 calls to URI::_generic::CORE:match, avg 16µs/call # spent 69µs making 1 call to URI::_generic::CORE:regcomp
19
2013837.14ms if (@_) {
21 my $auth = shift;
22 $$self = $1;
23 my $rest = $3;
24 if (defined $auth) {
25 $auth =~ s/([^$ACHAR])/$URI::Escape::escapes{$1}/go;
26 $$self .= "//$auth";
27 }
28 _check_path($rest, $$self);
29 $$self .= $rest;
30 }
31138325.0ms $2;
32}
33
34sub path
35{
36 my $self = shift;
37 $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die;
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::escapes{$1}/go;
45 _check_path($new_path, $$self);
46 $$self .= $new_path . $rest;
47 }
48 $2;
49}
50
51sub path_query
52
# spent 26.6ms (17.6+8.99) within URI::_generic::path_query which was called 461 times, avg 58µs/call: # 461 times (17.6ms+8.99ms) by LWP::Protocol::http::request at line 149 of LWP/Protocol/http.pm, avg 58µs/call
{
534612.29ms my $self = shift;
5446115.3ms4618.99ms $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die;
# spent 8.99ms making 461 calls to URI::_generic::CORE:match, avg 19µs/call
55
564612.22ms 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::escapes{$1}/go;
62 _check_path($new_path, $$self);
63 $$self .= $new_path . $rest;
64 }
654617.21ms $2;
66}
67
68sub _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
89sub 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
116sub _split_segment
117{
118 my $self = shift;
119 require URI::_segment;
120 URI::_segment->new(@_);
121}
122
123
124sub 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
184sub 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
249123µs1;
# spent 30.9ms within URI::_generic::CORE:match which was called 1844 times, avg 17µs/call: # 1383 times (21.9ms+0s) by URI::_generic::authority at line 18 of URI/_generic.pm, avg 16µs/call # 461 times (8.99ms+0s) by URI::_generic::path_query at line 54 of URI/_generic.pm, avg 19µs/call
sub URI::_generic::CORE:match; # xsub
# spent 69µs within URI::_generic::CORE:regcomp which was called # once (69µs+0s) by URI::_generic::authority at line 18 of URI/_generic.pm
sub URI::_generic::CORE:regcomp; # xsub
# spent 29µs within URI::_generic::CORE:subst which was called 2 times, avg 14µs/call: # once (19µs+0s) by URI::implementor at line 10 of URI/_generic.pm # once (10µs+0s) by URI::implementor at line 11 of URI/_generic.pm
sub URI::_generic::CORE:subst; # xsub
Report produced by the NYTProf 3.11 Perl profiler, developed by Tim Bunce and Adam Kaplan.