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