| Revision: | 1.12 |
| Committed: | Fri Aug 4 07:47:43 2000 UTC (24 years, 9 months ago) by williamc |
| Content type: | text/plain |
| Branch: | MAIN |
| CVS Tags: | V1_2_1b, V1_2_1a, V1_2_3, V1_2_2, V1_2_2_relcand2, V1_2_1, V1_2_0, V1_2_0-cand11, V1_1_7, V1_1_6, V1_2_0-cand10, V1_1_5, V1_2_0-cand9, V1_2_0-cand8, V1_2_0-cand7, V1_2_0-cand6, V1_2_0-cand5, V1_2_0-cand4, V1_2_0-cand3, V1_2_0-cand2, V1_2_0-cand1, V1_1_4, V1_1_3, V1_1_2, V1_1_0_reltag8, V1_1_0_reltag7, V1_1_0_reltag6, V1_1_1, V1_1_0_reltag5, V1_1_0_reltag4, V1_1_0_reltag3, V1_1_0_reltag2, V1_1_0_reltag1, V1_1_0_reltag, V1_0_3-p4, V1_1_0_cand3, V1_1_0_cand2, V1_1_0_cand1, HEAD_SM_071214, forV1_1_0, v103_xml_071106, V1_0_3-p3, V1_0_3-p2, V1_1_0, v110p1, V110p6, V110p5, V110p4, V110p3, before110xmlBRmerge, V110p2, V110p1, V1_0_4p1, V1_0_3-p1, V1_0_3, V1_0_2, V1_0_2_p1, v102p1, V1_0_1, V1_0_0, V1_pre0, SCRAM_V1, SCRAMV1_IMPORT, V0_19_7, V0_19_6, V0_19_6p1, V0_19_5, SFATEST, V0_19_4, V0_19_4_pre3, V0_19_4_pre2, V0_19_4_pre1, V0_19_3, V0_19_2, V0_19_1, V0_19_0, V0_18_5, V0_18_4, V_18_3_TEST, VO_18_3, V0_18_2, V0_18_1, ProtoEnd |
| Branch point for: | forBinLess_SCRAM, HEAD_BRANCH_SM_071214, v200branch, v103_with_xml, v103_branch, V1_pre1, SCRAM_V1_BRANCH, V0_19_4_B, HPWbranch |
| Changes since 1.11: | +17 -2 lines |
| Log Message: | working versions |
| # | Content |
|---|---|
| 1 | # |
| 2 | # URLclass.pm |
| 3 | # |
| 4 | # Originally Written by Christopher Williams |
| 5 | # |
| 6 | # Description |
| 7 | # |
| 8 | # Interface |
| 9 | # --------- |
| 10 | # new(url) : A new URLclass object |
| 11 | # origurl() : return the original url as originally provided in new |
| 12 | # url() : return the full url name with all expansion |
| 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 | # 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 url parameter hash |
| 27 | # transfervars(varhash) : transfer any variables from varhash into vars |
| 28 | # only if they do not already exist |
| 29 | |
| 30 | package URL::URLclass; |
| 31 | require 5.004; |
| 32 | |
| 33 | sub new { |
| 34 | my $class=shift; |
| 35 | $self={}; |
| 36 | bless $self, $class; |
| 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 |
| 72 | :$self->{type}; |
| 73 | } |
| 74 | |
| 75 | sub vars { |
| 76 | my $self=shift; |
| 77 | @_?$self->{vars}=shift |
| 78 | :$self->{vars}; |
| 79 | } |
| 80 | |
| 81 | sub url { |
| 82 | my $self=shift; |
| 83 | |
| 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 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 | |
| 112 | return $rv; |
| 113 | } |
| 114 | |
| 115 | sub equals { |
| 116 | my $self=shift; |
| 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 { |
| 144 | my $self=shift; |
| 145 | my $basevars=shift; |
| 146 | |
| 147 | foreach $key ( keys %$basevars ) { |
| 148 | if ( ! exists $self->{vars}{$key} ) { |
| 149 | $self->{vars}{$key}=$$basevars{$key}; |
| 150 | } |
| 151 | } |
| 152 | } |
| 153 | |
| 154 | sub file { |
| 155 | my $self=shift; |
| 156 | my $file; |
| 157 | |
| 158 | if ( $self->{path}=~/\// ) { |
| 159 | ($file=$self->{path})=~s/.*\///g; |
| 160 | } |
| 161 | else { |
| 162 | $file=$self->{path}; |
| 163 | } |
| 164 | return $file; |
| 165 | } |
| 166 | |
| 167 | sub param { |
| 168 | my $self=shift; |
| 169 | my $param=shift; |
| 170 | |
| 171 | $self->{vars}{$param}; |
| 172 | } |
| 173 | |
| 174 | # |
| 175 | # --- Support Routines |
| 176 | # |
| 177 | |
| 178 | sub _vartostring { |
| 179 | my $self=shift; |
| 180 | |
| 181 | my $string=""; |
| 182 | foreach $key ( sort(keys %{$self->{vars}}) ) { |
| 183 | $string=$string.(($string eq "")?"":"\&").$key."=".$self->{vars}{$key}; |
| 184 | } |
| 185 | return $string; |
| 186 | } |
| 187 | |
| 188 | sub _splitvarstring { |
| 189 | my $self=shift; |
| 190 | my $varstring=shift; |
| 191 | |
| 192 | my @pairs=split /\&/, $varstring; |
| 193 | foreach $pair ( @pairs ) { |
| 194 | my ($var,$val)= split /=/, $pair; |
| 195 | $self->{vars}{$var}=$val; |
| 196 | } |
| 197 | } |
| 198 | |
| 199 | # process a url string into its component parts |
| 200 | sub _url { |
| 201 | my $self=shift; |
| 202 | my $url=shift; |
| 203 | |
| 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 | my($path, @varsarray)=split /\?/, $tmp; |
| 215 | my $varstring=join '?' ,@varsarray; |
| 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 | } |