| 8 |
|
# Interface |
| 9 |
|
# --------- |
| 10 |
|
# new(url) : A new URLclass object |
| 11 |
< |
# origurl() : retunr the original url without any expansion |
| 11 |
> |
# origurl() : return the original url as originally provided in new |
| 12 |
|
# url() : return the full url name with all expansion |
| 13 |
< |
# expandurl(URLbase) : expand the url to include the given base |
| 13 |
> |
# path() : return the path (all after server name - no vars) |
| 14 |
|
# file() : return the filename from the end of the path |
| 15 |
|
# param(var) : return the value of a url parameter |
| 16 |
< |
# |
| 17 |
< |
# -- specialised use methods |
| 16 |
> |
# servername() : return/set the name of the server |
| 17 |
> |
# equals(URLclass) : compare with another URLclass object for equality |
| 18 |
> |
# 0=false 1=true |
| 19 |
> |
# merge(URLclass) : merge the given URL into the current one according to the |
| 20 |
> |
# following rules - |
| 21 |
> |
# - types are identical |
| 22 |
> |
# - servername is taken only if not set locally |
| 23 |
> |
# - the local path is appended to that passed in the arg |
| 24 |
> |
# - variables are added only if they dont already exist |
| 25 |
|
# type() : get/set the url type |
| 26 |
< |
# vars() : get/set the vars hash |
| 20 |
< |
# base(base) : push a base into the url path if it dosnt already mactch |
| 26 |
> |
# vars() : get/set the url parameter hash |
| 27 |
|
# transfervars(varhash) : transfer any variables from varhash into vars |
| 28 |
|
# only if they do not already exist |
| 29 |
|
|
| 34 |
|
my $class=shift; |
| 35 |
|
$self={}; |
| 36 |
|
bless $self, $class; |
| 31 |
– |
$self->{vars}={}; |
| 37 |
|
$self->{origurl}=shift; |
| 38 |
+ |
$self->_init(); |
| 39 |
|
$self->_url($self->{origurl}); |
| 40 |
|
return $self; |
| 41 |
|
} |
| 42 |
|
|
| 43 |
+ |
sub _init { |
| 44 |
+ |
my $self=shift; |
| 45 |
+ |
$self->{vars}={}; |
| 46 |
+ |
$self->{servername}=""; |
| 47 |
+ |
$self->{path}=""; |
| 48 |
+ |
$self->{type}=""; |
| 49 |
+ |
} |
| 50 |
+ |
|
| 51 |
|
sub origurl { |
| 52 |
|
my $self=shift; |
| 53 |
|
return $self->{origurl}; |
| 54 |
|
} |
| 55 |
|
|
| 56 |
|
|
| 57 |
+ |
sub servername { |
| 58 |
+ |
my $self=shift; |
| 59 |
+ |
@_?$self->{servername}=shift |
| 60 |
+ |
:$self->{servername}; |
| 61 |
+ |
} |
| 62 |
+ |
|
| 63 |
+ |
sub path { |
| 64 |
+ |
my $self=shift; |
| 65 |
+ |
@_?$self->{path}=shift |
| 66 |
+ |
:$self->{path}; |
| 67 |
+ |
} |
| 68 |
+ |
|
| 69 |
|
sub type { |
| 70 |
|
my $self=shift; |
| 71 |
|
@_?$self->{type}=shift |
| 78 |
|
:$self->{vars}; |
| 79 |
|
} |
| 80 |
|
|
| 81 |
< |
sub expandurl { |
| 81 |
> |
sub url { |
| 82 |
|
my $self=shift; |
| 57 |
– |
my $base=shift; |
| 83 |
|
|
| 84 |
< |
$self->{vars}={}; |
| 85 |
< |
$self->_url($self->{origurl}); # reset the current url; |
| 86 |
< |
$self->transfervars($base->cmds()); |
| 87 |
< |
$self->base($base->base()); |
| 84 |
> |
my $vars=$self->_vartostring(); |
| 85 |
> |
my $server=$self->servername(); |
| 86 |
> |
my $fullurl=$self->type().":".(($server ne "")?"//".$server."/":""). |
| 87 |
> |
$self->path().(($vars ne "")?"\?".$vars:""); |
| 88 |
> |
return $fullurl; |
| 89 |
|
} |
| 90 |
|
|
| 91 |
< |
sub base { |
| 92 |
< |
my $self=shift; |
| 93 |
< |
if ( @_ ) { |
| 94 |
< |
my $server=shift; |
| 95 |
< |
if ( ($server ne "") && ($self->{server}!~/\/\//) && |
| 96 |
< |
($self->{server}!~/$server/) ) { |
| 97 |
< |
# only set if not already in there |
| 98 |
< |
$self->{server}=$server."/".$self->{server}; |
| 99 |
< |
} |
| 91 |
> |
sub merge { |
| 92 |
> |
my $self=shift; |
| 93 |
> |
my $url=shift; |
| 94 |
> |
|
| 95 |
> |
my $rv=1; |
| 96 |
> |
# -- can only merge url's of the same type |
| 97 |
> |
if ( (defined $url) && ($self->type() eq $url->type()) ) { |
| 98 |
> |
# -- merge server only if it dosnt exist locally |
| 99 |
> |
if ( (! defined $self->{servername}) || ($self->{servername} eq "") ) { |
| 100 |
> |
$self->servername($url->servername()); |
| 101 |
> |
} |
| 102 |
> |
# -- merge path - insert at beginning of existing path |
| 103 |
> |
if ( defined $url->{path} ) { |
| 104 |
> |
$self->{path}=$url->{path}.$self->{path}; |
| 105 |
> |
} |
| 106 |
> |
|
| 107 |
> |
# -- now merge vars |
| 108 |
> |
$self->transfervars($url->vars()); |
| 109 |
> |
$rv=0; |
| 110 |
|
} |
| 111 |
< |
return $self->{server}; |
| 111 |
> |
|
| 112 |
> |
return $rv; |
| 113 |
|
} |
| 114 |
|
|
| 115 |
< |
sub url { |
| 115 |
> |
sub equals { |
| 116 |
|
my $self=shift; |
| 117 |
< |
|
| 118 |
< |
my $vars=$self->_vartostring(); |
| 119 |
< |
my $fullurl=$self->type()."://".$self->{server}. |
| 120 |
< |
(($vars ne "")?"\?".$vars:""); |
| 121 |
< |
return $fullurl; |
| 117 |
> |
my $testurl=shift; |
| 118 |
> |
|
| 119 |
> |
my $rv=0; |
| 120 |
> |
if ( $self->servername() eq $testurl->servername() ) { |
| 121 |
> |
if ( $self->path() eq $testurl->path() ) { |
| 122 |
> |
# -- check the passed variables |
| 123 |
> |
my @testkeys=keys %{$testurl->vars()}; |
| 124 |
> |
if ( $#{keys %{$self->{vars}}} == $#testkeys ) { |
| 125 |
> |
my $okvar=-1; |
| 126 |
> |
foreach $var ( @testkeys ) { |
| 127 |
> |
if ( exists $self->{vars}{$var} ) { |
| 128 |
> |
if ( $self->{vars}{$var} eq $testurl->{vars}{$var} ) { |
| 129 |
> |
$okvar++; |
| 130 |
> |
} |
| 131 |
> |
} |
| 132 |
> |
} |
| 133 |
> |
# if we get this far and all the testvars have been tested then |
| 134 |
> |
if ( $okvar == $#{keys %{$self->{vars}}} ) { |
| 135 |
> |
$rv=1; |
| 136 |
> |
} |
| 137 |
> |
} |
| 138 |
> |
} |
| 139 |
> |
} |
| 140 |
> |
return $rv; |
| 141 |
|
} |
| 142 |
|
|
| 143 |
|
sub transfervars { |
| 155 |
|
my $self=shift; |
| 156 |
|
my $file; |
| 157 |
|
|
| 158 |
< |
if ( $self->{server}=~/\// ) { |
| 159 |
< |
($file=$self->{server})=~s/.*\///g; |
| 158 |
> |
if ( $self->{path}=~/\// ) { |
| 159 |
> |
($file=$self->{path})=~s/.*\///g; |
| 160 |
|
} |
| 161 |
|
else { |
| 162 |
< |
$file=$self->{server}; |
| 162 |
> |
$file=$self->{path}; |
| 163 |
|
} |
| 164 |
|
return $file; |
| 165 |
|
} |
| 174 |
|
# |
| 175 |
|
# --- Support Routines |
| 176 |
|
# |
| 177 |
+ |
|
| 178 |
|
sub _vartostring { |
| 179 |
|
my $self=shift; |
| 180 |
|
|
| 196 |
|
} |
| 197 |
|
} |
| 198 |
|
|
| 199 |
+ |
# process a url string into its component parts |
| 200 |
|
sub _url { |
| 201 |
|
my $self=shift; |
| 202 |
|
my $url=shift; |
| 145 |
– |
my @rest; |
| 203 |
|
|
| 204 |
< |
($self->{type}, @rest)= split ":", $url; |
| 204 |
> |
if ( $url!~/:/ ) { |
| 205 |
> |
$self->error("Invalid URL specification - no type: in $url"); |
| 206 |
> |
} |
| 207 |
> |
else { |
| 208 |
> |
# -- split out type and lowercase it |
| 209 |
> |
my ($type, @rest)= split ":", $url; |
| 210 |
> |
($self->{type}=$type)=~tr[A-Z][a-z]; |
| 211 |
> |
|
| 212 |
> |
# -- sort out variables |
| 213 |
|
my $tmp=join ':' ,@rest; |
| 214 |
< |
($self->{server}, @varsarray)=split /\?/, $tmp; |
| 214 |
> |
my($path, @varsarray)=split /\?/, $tmp; |
| 215 |
|
my $varstring=join '?' ,@varsarray; |
| 151 |
– |
$self->{server}=~s/^\/\///; |
| 216 |
|
if ( $varstring ) { $self->_splitvarstring($varstring);} |
| 217 |
+ |
|
| 218 |
+ |
# -- extract servername from path |
| 219 |
+ |
if ( ! defined $path ) { |
| 220 |
+ |
$path=""; |
| 221 |
+ |
} |
| 222 |
+ |
elsif ( $path=~/^\/\// ) { |
| 223 |
+ |
my $server; |
| 224 |
+ |
($server,$path)=($path=~/^\/\/(.*?)\/(.*)/); |
| 225 |
+ |
$self->servername($server); |
| 226 |
+ |
} |
| 227 |
+ |
$self->path($path); |
| 228 |
+ |
} |
| 229 |
+ |
} |
| 230 |
+ |
|
| 231 |
+ |
sub error { |
| 232 |
+ |
my $self=shift; |
| 233 |
+ |
my $string=shift; |
| 234 |
+ |
print "URLClass: ".$string."\n"; |
| 235 |
+ |
die; |
| 236 |
|
} |
