src/URL/URLclass.pm

#
# URLclass.pm
#
# Originally Written by Christopher Williams
#
# Description
#
# Interface
# ---------
# new(url)      : A new URLclass object
# origurl()     : return the original url as originally provided in new
# url()         : return the full url name with all expansion
# path()        : return the path (all after server name - no vars)
# file()        : return the filename from the end of the path
# param(var)    : return the value of a url parameter
# servername()  : return/set the name of the server
# equals(URLclass) : compare with another URLclass object for equality
#                       0=false 1=true
# merge(URLclass) : merge the given URL into the current one according to the
#                   following rules -
#                    - types are identical
#                    - servername is taken only if not set locally
#                    - the local path is appended to that passed in the arg
#                    - variables are added only if they dont already exist
# type()        : get/set the url type
# vars()        : get/set the url parameter hash
# transfervars(varhash)  : transfer any variables from varhash into vars
#                          only if they do not already exist

package URL::URLclass;
require 5.004;

sub new {
        my $class=shift;
        $self={};
        bless $self, $class;
        $self->{origurl}=shift;
        $self->_init();
        $self->_url($self->{origurl});
        return $self;
}

sub _init {
        my $self=shift;
        $self->{vars}={};
        $self->{servername}="";
        $self->{path}="";
        $self->{type}="";
}

sub origurl {
        my $self=shift;
        return $self->{origurl};
}


sub servername {
        my $self=shift;
        @_?$self->{servername}=shift
          :$self->{servername};
}

sub path {
        my $self=shift;
        @_?$self->{path}=shift
          :$self->{path};
}

sub type {
        my $self=shift;
        @_?$self->{type}=shift
          :$self->{type};
}

sub vars {
        my $self=shift;
        @_?$self->{vars}=shift
          :$self->{vars};
}

sub url {
        my $self=shift;
        
        my $vars=$self->_vartostring();
        my $server=$self->servername();
        my $fullurl=$self->type().":".(($server ne "")?"//".$server."/":"").
                        $self->path().(($vars ne "")?"\?".$vars:"");
        return $fullurl;
}

sub merge {
        my $self=shift;
        my $url=shift;

        my $rv=1;
        # -- can only merge url's of the same type
        if ( (defined $url) && ($self->type() eq $url->type()) ) {
         # -- merge server only if it dosnt exist locally
         if ( (! defined $self->{servername}) || ($self->{servername} eq "") ) {
          $self->servername($url->servername());
         }
         # -- merge  path - insert at beginning of existing path
         if ( defined $url->{path} ) {
           $self->{path}=$url->{path}.$self->{path};
         }
         
         # -- now merge vars
         $self->transfervars($url->vars());
         $rv=0;
        }
        
        return $rv;
}

sub equals {
        my $self=shift;
        my $testurl=shift;

        my $rv=0;
        if ( $self->servername() eq $testurl->servername() ) {
          if ( $self->path() eq $testurl->path() ) {
           #  -- check the passed variables
           my @testkeys=keys %{$testurl->vars()}; 
           if ( $#{keys %{$self->{vars}}} == $#testkeys ) {
            my $okvar=-1;
            foreach $var ( @testkeys ) {
             if ( exists $self->{vars}{$var} ) {
              if ( $self->{vars}{$var} eq $testurl->{vars}{$var} ) {
                $okvar++;
              } 
             }
            }
            # if we get this far and all the testvars have been tested then
            if ( $okvar == $#{keys %{$self->{vars}}} ) {
             $rv=1;
            }
           }
          }
        }
        return $rv;
}

sub transfervars {
        my $self=shift;
        my $basevars=shift;

        foreach $key ( keys %$basevars ) {
          if ( ! exists $self->{vars}{$key} ) {
                $self->{vars}{$key}=$$basevars{$key};
          }
        }
}

sub file {
        my $self=shift;
        my $file;

        if ( $self->{path}=~/\// ) {
          ($file=$self->{path})=~s/.*\///g;
        }
        else {
          $file=$self->{path};
        }
        return $file;
}

sub param {
        my $self=shift;
        my $param=shift;

        $self->{vars}{$param};
}

#
# --- Support Routines
#

sub _vartostring {
        my $self=shift;

        my $string="";
        foreach $key ( sort(keys %{$self->{vars}}) ) {
          $string=$string.(($string eq "")?"":"\&").$key."=".$self->{vars}{$key};
        }
        return $string;
}

sub _splitvarstring {
        my $self=shift;
        my $varstring=shift;
        
        my @pairs=split /\&/, $varstring;
        foreach $pair ( @pairs ) {
          my ($var,$val)= split /=/, $pair;
          $self->{vars}{$var}=$val;
        }
}

# process a url string into its component parts
sub _url {
        my $self=shift;
        my $url=shift;

        if ( $url!~/:/ ) {
          $self->error("Invalid URL specification - no type: in $url");
        }
        else {
        # -- split out type and lowercase it
        my ($type, @rest)= split ":", $url;
        ($self->{type}=$type)=~tr[A-Z][a-z];

        # -- sort out variables
        my $tmp=join ':' ,@rest;
        my($path, @varsarray)=split /\?/, $tmp;
        my $varstring=join '?' ,@varsarray;
        if ( $varstring ) { $self->_splitvarstring($varstring);}

        # -- extract servername from path
        if ( ! defined $path ) {
          $path="";
        }
        elsif ( $path=~/^\/\// ) {
          my $server;
         ($server,$path)=($path=~/^\/\/(.*?)\/(.*)/);
         $self->servername($server);
        }
        $self->path($path);
        }
}

sub error {
        my $self=shift;
        my $string=shift;
        print "URLClass: ".$string."\n";
        die;
}
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
#	User	Rev	Content
1	williamc	1.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	williamc	1.11	# origurl() : return the original url as originally provided in new
12	williamc	1.1	# url() : return the full url name with all expansion
13	williamc	1.11	# path() : return the path (all after server name - no vars)
14	williamc	1.1	# file() : return the filename from the end of the path
15			# param(var) : return the value of a url parameter
16	williamc	1.11	# 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	williamc	1.1	# type() : get/set the url type
26	williamc	1.11	# vars() : get/set the url parameter hash
27	williamc	1.1	# 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	williamc	1.11	$self->_init();
39	williamc	1.1	$self->_url($self->{origurl});
40			return $self;
41			}
42
43	williamc	1.11	sub _init {
44			my $self=shift;
45			$self->{vars}={};
46			$self->{servername}="";
47			$self->{path}="";
48			$self->{type}="";
49			}
50
51	williamc	1.1	sub origurl {
52			my $self=shift;
53			return $self->{origurl};
54			}
55
56
57	williamc	1.11	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	williamc	1.1	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	williamc	1.11	sub url {
82	williamc	1.1	my $self=shift;
83
84	williamc	1.11	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	williamc	1.1	}
90
91	williamc	1.11	sub merge {
92			my $self=shift;
93			my $url=shift;
94	williamc	1.1
95	williamc	1.11	my $rv=1;
96			# -- can only merge url's of the same type
97	williamc	1.12	if ( (defined $url) && ($self->type() eq $url->type()) ) {
98	williamc	1.11	# -- 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	williamc	1.1	my $self=shift;
117	williamc	1.11	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	williamc	1.1	}
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	williamc	1.7	}
153
154	williamc	1.1	sub file {
155			my $self=shift;
156			my $file;
157
158	williamc	1.11	if ( $self->{path}=~/\// ) {
159			($file=$self->{path})=~s/.*\///g;
160	williamc	1.1	}
161			else {
162	williamc	1.11	$file=$self->{path};
163	williamc	1.1	}
164			return $file;
165			}
166
167			sub param {
168			my $self=shift;
169			my $param=shift;
170
171	williamc	1.3	$self->{vars}{$param};
172	williamc	1.1	}
173
174			#
175			# --- Support Routines
176			#
177	williamc	1.4
178	williamc	1.1	sub _vartostring {
179			my $self=shift;
180
181			my $string="";
182	williamc	1.2	foreach $key ( sort(keys %{$self->{vars}}) ) {
183	williamc	1.1	$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	williamc	1.11	# process a url string into its component parts
200	williamc	1.1	sub _url {
201			my $self=shift;
202			my $url=shift;
203
204	williamc	1.12	if ( $url!~/:/ ) {
205			$self->error("Invalid URL specification - no type: in $url");
206			}
207			else {
208	williamc	1.11	# -- 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	williamc	1.1	my $tmp=join ':' ,@rest;
214	williamc	1.11	my($path, @varsarray)=split /\?/, $tmp;
215	williamc	1.1	my $varstring=join '?' ,@varsarray;
216			if ( $varstring ) { $self->_splitvarstring($varstring);}
217	williamc	1.11
218			# -- extract servername from path
219	williamc	1.12	if ( ! defined $path ) {
220			$path="";
221			}
222			elsif ( $path=~/^\/\// ) {
223	williamc	1.11	my $server;
224			($server,$path)=($path=~/^\/\/(.?)\/(.)/);
225			$self->servername($server);
226			}
227			$self->path($path);
228	williamc	1.12	}
229			}
230
231			sub error {
232			my $self=shift;
233			my $string=shift;
234			print "URLClass: ".$string."\n";
235			die;
236	williamc	1.1	}