1package URI::_generic; 2require URI; 3require URI::_query; 4@ISA=qw(URI URI::_query); 5 6use strict; 7use URI::Escape qw(uri_unescape); 8use Carp (); 9 10my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g; 11my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g; 12 13sub _no_scheme_ok { 1 } 14 15sub authority 16{ 17 my $self = shift; 18 $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die; 19 20 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 } 31 $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{ 53 my $self = shift; 54 $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die; 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::escapes{$1}/go; 62 _check_path($new_path, $$self); 63 $$self .= $new_path . $rest; 64 } 65 $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 2491; 250