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 ( $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;

        # -- 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  ( $path=~/^\/\// ) {
          my $server;
         ($server,$path)=($path=~/^\/\/(.*?)\/(.*)/);
         $self->servername($server);
        }
        $self->path($path);
}
Revision:	1.11
Committed:	Fri Jul 28 17:06:00 2000 UTC (24 years, 9 months ago) by williamc
Content type:	text/plain
Branch:	MAIN
Changes since 1.10:	+105 -63 lines
Log Message:	Fully tested with new interface
#	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			if ( $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	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.11	# -- split out type and lowercase it
205			my ($type, @rest)= split ":", $url;
206			($self->{type}=$type)=~tr[A-Z][a-z];
207
208			# -- sort out variables
209	williamc	1.1	my $tmp=join ':' ,@rest;
210	williamc	1.11	my($path, @varsarray)=split /\?/, $tmp;
211	williamc	1.1	my $varstring=join '?' ,@varsarray;
212			if ( $varstring ) { $self->_splitvarstring($varstring);}
213	williamc	1.11
214			# -- extract servername from path
215			if ( $path=~/^\/\// ) {
216			my $server;
217			($server,$path)=($path=~/^\/\/(.?)\/(.)/);
218			$self->servername($server);
219			}
220			$self->path($path);
221	williamc	1.1	}