src/Utilities/urlhandler.pm

# url handler -> returns the location of the file
#
# Interface
# ---------
# new() :
# new(cachedir)       : A new urlhandler with a defined default cahce directory
# get(url)            : download from the specified url to the default cache
# get(url,location)        : dowload to the specified directory
# setcvsco("checkout_cmd") : Default cvs is "co" change with this cmd
# setbase(type,@args) : set the url defaults for a specific url type
#                       arguments are dependent on type
#                       http:
#                       file:
#                       cvs: servername,servertype [ ,user,passkey ]
#                       label:
# unsetbase(type)  : deactivate a previously set base
#
# ----------------------------------------------------------------------
# returns file location - or crashes out
# can pass a file name for the item to be stored as 
# if not then stores in a default cache.

package urlhandler;
require 5.004;
use Utilities::AddDir;

sub new {
        my $class=shift;
        my $cache=shift;
        $self={};
        bless $self, $class;
        $self->init($cache);
        return $self;
}

sub init {
        use Utilities::AddDir;
        my $self=shift;
        my $cache=shift;
        if ($cache eq "" ) { $cache="/tmp/SCRAMcache" }; # default cache
        AddDir::adddir($cache);
        $self->{cache}=$cache;
        $self->{cvsco}="co";
        @{$self->{urltypes}} = qw(label file cvs http);
}

sub get ($@) {
        my $self=shift;
        my $origurl=shift;
        my $filename=shift;
        my $rest;
        my $type;
        my $url;
        my $version;

        chomp $origurl;
        # get our version info from the url (after last ??)
        ( $url, $version) = split /\?\?/, $origurl;
        if ( $url=~/:/ ) {
          ($type,$rest) = split /:/, $url;
        }
        else {
           $type='label';
           $rest=$url.":".$version;
        }
        foreach $ty ( @{$self->{urltypes}} ) {
           do { return &$ty($self, $rest, $filename); $supported='yes'; last;}
                        , if $type eq $ty;
        }
        if ( ! ( $supported=~/yes/ )) {
           print "urlhandler: Unsupported type $type\n";
           exit 1;
        }
}

#
# setcvsco --- to change nature of cvs co (e.g "export" rather than "co")
#
sub setcvsco {
        my $self=shift;
        $self->{cvsco}=shift;
}

sub setbase {
        my $self=shift;
        my $type=shift;
        my @args=@_;

        # Check type is supported
        if ( ! grep( $type, @{$self->{urltypes}}) ) {
          print "urlhandler error: Unsupported type $type\n";
          return 1;
        }
        else {
          &{$type."_setbase"}($self,@args);
        }
}

sub unsetbase {
        my $self=shift;
        my $type=shift;

        # Check type is supported
        if ( ! grep( $type, @{$self->{urltypes}}) ) {
          print "urlhandler error: Unsupported type $type\n";
          return 1;
        }
        else {
          &{$type."_unsetbase"}($self, @args);
        }
}

# ------------------------- Type Support Routines ----------------------------
#
# label:
#
sub label {
        my $self=shift;
        my $label=shift;
        my $filename=shift;
        my $returnval="";

        open ( LOOKUP, "$ENV{SCRAM_LOOKUPDB}" ) 
           || die "urlhandler: Unable to open DataBase $ENV{SCRAM_LOOKUPDB} $!";
        while ( <LOOKUP> ) {
          next if /^#/;
          if ( $_=~s/^$label\:// ) {
                $returnval = urlhandler($_,$filename);
          }
        }
        close LOOKUP;
        if ( $returnval ne "" ) {
          return $returnval;
        }
        ($proj,$ver)=split /:/, $label;
        print "Error : Unknown project name or version (".$proj." ".$ver.")\n";
        exit 1;
}

sub label_setbase {
        my $self=shift;
}

sub label_unsetbase {
        my $self=shift;
}

#
# file:
#
sub file {
        my $self=shift;
        use File::Copy;
        my $urlfile=shift;
        my $filename=shift;

        if ( $self->{filebase} ne "" ) { # add a base if it exists
          $urlfile=$self->{filebase}."/".$urlfile;
        }
        if ( -e "$urlfile" ) {
          if ( $filename ne "" ) {
           copy ( $urlfile, $filename ) || return $urlfile;
           return $filename;
          }
          return $urlfile;
        }
        else {
           print "urlhandler: Unable to find file $urlfile : $!\n";
           exit 1;
        }
}

#
# 
#
sub file_setbase {
        my $self=shift;
        my $filebase=shift;
        
        if ( -d $filebase ) {
          $self->{filebase}=$filebase;
          push  @{$self->{filebasestack}},  $self->{filebase};
        }
        else {
          die "Directory Does Not Exist \n";
        }
}

sub file_unsetbase {
        my $self=shift;
        pop @{$self->{filebasestack}};
        $self->{filebase}=@{$self->{filebasestack}}
                [$#{$self->{filebasestack}}];
}

#
# cvs:
#

sub cvs {
        my $self=shift;
        my $url=shift;
        my $dirname=shift;

        my $cvscmd;
        my $module;
        my $version;

        # Where should we co to?
        if ( $dirname eq "" ) {
          $dirname=$self->{cache};
        }

        # Split up our url into its components
        ($module, $version)= split /\?/, $url;

        if ( $version ne "" ) {
           $cvscmd=$self->{cvsco}." -r $version"; 
        }
        else {
           $cvscmd=$self->{cvsco}
        }
        #
        # Check to see we have a server and if so attempt the checkout
        #
        if ( ! defined $self->{cvsobject} )  {
         print "urlhandler error: undefined cvs server for $module\n";
         return 1;
        }
        else {
         chdir $dirname or die "Unable to Enter Directory $dirname $!\n";
         $self->{cvsobject}->invokecvs($cvscmd,  $module);
        }
}

sub cvs_setbase {
        my $self=shift;
        my $base=shift;
        my $auth=shift;
        my $user=shift;
        my $passkey=shift;

        # Push a new cvs object onto the cvs stack
        $self->{cvsobject}=cvsmodule->new();
        push @{$self->{cvsobjectstack}},$self->{cvsobject};
        $self->{cvsobject}->set_base($base);
        $self->{cvsobject}->set_auth($auth);
        if ( $user ne "" ) {
             $self->{cvsobject}->set_user($user);
        }
        if ( $passkey ne "" ) {
             $self->{cvsobject}->set_passkey($passkey);
        }
}

sub cvs_unsetbase {
        my $self=shift;
        pop @{$self->{cvsobjectstack}};
        $self->{cvsobject}=@{$self->{cvsobjectstack}}
                [$#{$self->{cvsobjectstack}}];
}

#
# http:
#

sub http {
        my $self=shift;
        my $urlfile=shift;
        my $filename=shift;
#       use LWP::Simple;
        print "Hello $filename, $urlfile\n";
#       open (STORE, ">$filename") || die "unable to open file $filename $!\n";
#       print STORE (get 'http:'.$urlfile);
        close STORE;
}

sub http_setbase {
        my $self=shift;
}

sub http_unsetbase {
        my $self=shift;
}

# ------------------------ General Support Routines ----------------------------

sub cachefilename {
         my $self=shift;
             use File::Basename;
             use Utilities::AddDir;
             my $filebase=dirname($rest);
             $cache="/tmp/williamc/urlhandler$$";
             adddir($cache);
             $filename=$cache."/".$filebase;
}

Revision:	1.7
Committed:	Mon Jun 7 15:01:52 1999 UTC (25 years, 11 months ago) by williamc
Content type:	text/plain
Branch:	MAIN
Changes since 1.6:	+20 -1 lines
Log Message:	Add base methods for file
#	User	Rev	Content
1	williamc	1.1	# url handler -> returns the location of the file
2			#
3	williamc	1.6	# Interface
4			# ---------
5			# new() :
6			# new(cachedir) : A new urlhandler with a defined default cahce directory
7			# get(url) : download from the specified url to the default cache
8			# get(url,location) : dowload to the specified directory
9			# setcvsco("checkout_cmd") : Default cvs is "co" change with this cmd
10			# setbase(type,@args) : set the url defaults for a specific url type
11			# arguments are dependent on type
12			# http:
13			# file:
14			# cvs: servername,servertype [ ,user,passkey ]
15			# label:
16			# unsetbase(type) : deactivate a previously set base
17			#
18			# ----------------------------------------------------------------------
19	williamc	1.1	# returns file location - or crashes out
20			# can pass a file name for the item to be stored as
21			# if not then stores in a default cache.
22
23			package urlhandler;
24	williamc	1.4	require 5.004;
25	williamc	1.6	use Utilities::AddDir;
26	williamc	1.1
27	williamc	1.6	sub new {
28			my $class=shift;
29			my $cache=shift;
30			$self={};
31			bless $self, $class;
32			$self->init($cache);
33			return $self;
34			}
35
36			sub init {
37			use Utilities::AddDir;
38			my $self=shift;
39			my $cache=shift;
40			if ($cache eq "" ) { $cache="/tmp/SCRAMcache" }; # default cache
41			AddDir::adddir($cache);
42			$self->{cache}=$cache;
43			$self->{cvsco}="co";
44			@{$self->{urltypes}} = qw(label file cvs http);
45			}
46	williamc	1.1
47	williamc	1.6	sub get ($@) {
48			my $self=shift;
49	williamc	1.1	my $origurl=shift;
50			my $filename=shift;
51			my $rest;
52			my $type;
53			my $url;
54			my $version;
55
56			chomp $origurl;
57			# get our version info from the url (after last ??)
58			( $url, $version) = split /\?\?/, $origurl;
59			if ( $url=~/:/ ) {
60			($type,$rest) = split /:/, $url;
61			}
62			else {
63			$type='label';
64			$rest=$url.":".$version;
65			}
66	williamc	1.6	foreach $ty ( @{$self->{urltypes}} ) {
67			do { return &$ty($self, $rest, $filename); $supported='yes'; last;}
68			, if $type eq $ty;
69	williamc	1.1	}
70			if ( ! ( $supported=~/yes/ )) {
71			print "urlhandler: Unsupported type $type\n";
72			exit 1;
73			}
74			}
75	williamc	1.6
76			#
77			# setcvsco --- to change nature of cvs co (e.g "export" rather than "co")
78			#
79			sub setcvsco {
80			my $self=shift;
81			$self->{cvsco}=shift;
82			}
83
84			sub setbase {
85			my $self=shift;
86			my $type=shift;
87			my @args=@_;
88
89			# Check type is supported
90			if ( ! grep( $type, @{$self->{urltypes}}) ) {
91			print "urlhandler error: Unsupported type $type\n";
92			return 1;
93			}
94			else {
95			&{$type."_setbase"}($self,@args);
96			}
97			}
98
99			sub unsetbase {
100			my $self=shift;
101			my $type=shift;
102
103			# Check type is supported
104			if ( ! grep( $type, @{$self->{urltypes}}) ) {
105			print "urlhandler error: Unsupported type $type\n";
106			return 1;
107			}
108			else {
109			&{$type."_unsetbase"}($self, @args);
110			}
111			}
112
113			# ------------------------- Type Support Routines ----------------------------
114			#
115			# label:
116			#
117	williamc	1.1	sub label {
118	williamc	1.6	my $self=shift;
119	williamc	1.1	my $label=shift;
120			my $filename=shift;
121			my $returnval="";
122
123			open ( LOOKUP, "$ENV{SCRAM_LOOKUPDB}" )
124			\|\| die "urlhandler: Unable to open DataBase $ENV{SCRAM_LOOKUPDB} $!";
125			while ( <LOOKUP> ) {
126			next if /^#/;
127			if ( $_=~s/^$label\:// ) {
128			$returnval = urlhandler($_,$filename);
129			}
130			}
131			close LOOKUP;
132	williamc	1.5	if ( $returnval ne "" ) {
133			return $returnval;
134			}
135			($proj,$ver)=split /:/, $label;
136			print "Error : Unknown project name or version (".$proj." ".$ver.")\n";
137			exit 1;
138	williamc	1.1	}
139
140	williamc	1.6	sub label_setbase {
141			my $self=shift;
142			}
143
144			sub label_unsetbase {
145			my $self=shift;
146			}
147
148			#
149			# file:
150			#
151	williamc	1.1	sub file {
152	williamc	1.6	my $self=shift;
153	williamc	1.1	use File::Copy;
154			my $urlfile=shift;
155			my $filename=shift;
156	williamc	1.7
157			if ( $self->{filebase} ne "" ) { # add a base if it exists
158			$urlfile=$self->{filebase}."/".$urlfile;
159			}
160	williamc	1.1	if ( -e "$urlfile" ) {
161	williamc	1.7	if ( $filename ne "" ) {
162	williamc	1.1	copy ( $urlfile, $filename ) \|\| return $urlfile;
163			return $filename;
164			}
165			return $urlfile;
166			}
167			else {
168			print "urlhandler: Unable to find file $urlfile : $!\n";
169			exit 1;
170			}
171			}
172
173	williamc	1.7	#
174			#
175			#
176	williamc	1.6	sub file_setbase {
177			my $self=shift;
178	williamc	1.7	my $filebase=shift;
179
180			if ( -d $filebase ) {
181			$self->{filebase}=$filebase;
182			push @{$self->{filebasestack}}, $self->{filebase};
183			}
184			else {
185			die "Directory Does Not Exist \n";
186			}
187	williamc	1.6	}
188
189			sub file_unsetbase {
190			my $self=shift;
191	williamc	1.7	pop @{$self->{filebasestack}};
192			$self->{filebase}=@{$self->{filebasestack}}
193			[$#{$self->{filebasestack}}];
194	williamc	1.6	}
195
196			#
197			# cvs:
198			#
199
200	williamc	1.1	sub cvs {
201	williamc	1.6	my $self=shift;
202			my $url=shift;
203			my $dirname=shift;
204
205			my $cvscmd;
206			my $module;
207			my $version;
208
209			# Where should we co to?
210			if ( $dirname eq "" ) {
211			$dirname=$self->{cache};
212			}
213
214			# Split up our url into its components
215			($module, $version)= split /\?/, $url;
216
217			if ( $version ne "" ) {
218			$cvscmd=$self->{cvsco}." -r $version";
219			}
220			else {
221			$cvscmd=$self->{cvsco}
222			}
223			#
224			# Check to see we have a server and if so attempt the checkout
225			#
226			if ( ! defined $self->{cvsobject} ) {
227			print "urlhandler error: undefined cvs server for $module\n";
228			return 1;
229			}
230			else {
231			chdir $dirname or die "Unable to Enter Directory $dirname $!\n";
232			$self->{cvsobject}->invokecvs($cvscmd, $module);
233			}
234	williamc	1.1	}
235
236	williamc	1.6	sub cvs_setbase {
237			my $self=shift;
238			my $base=shift;
239			my $auth=shift;
240			my $user=shift;
241			my $passkey=shift;
242
243			# Push a new cvs object onto the cvs stack
244			$self->{cvsobject}=cvsmodule->new();
245			push @{$self->{cvsobjectstack}},$self->{cvsobject};
246			$self->{cvsobject}->set_base($base);
247			$self->{cvsobject}->set_auth($auth);
248			if ( $user ne "" ) {
249			$self->{cvsobject}->set_user($user);
250			}
251			if ( $passkey ne "" ) {
252			$self->{cvsobject}->set_passkey($passkey);
253			}
254			}
255
256			sub cvs_unsetbase {
257			my $self=shift;
258			pop @{$self->{cvsobjectstack}};
259			$self->{cvsobject}=@{$self->{cvsobjectstack}}
260			[$#{$self->{cvsobjectstack}}];
261			}
262
263			#
264			# http:
265			#
266
267	williamc	1.3	sub http {
268	williamc	1.6	my $self=shift;
269	williamc	1.4	my $urlfile=shift;
270			my $filename=shift;
271	williamc	1.6	# use LWP::Simple;
272	williamc	1.5	print "Hello $filename, $urlfile\n";
273	williamc	1.6	# open (STORE, ">$filename") \|\| die "unable to open file $filename $!\n";
274			# print STORE (get 'http:'.$urlfile);
275	williamc	1.4	close STORE;
276	williamc	1.3	}
277
278	williamc	1.6	sub http_setbase {
279			my $self=shift;
280			}
281
282			sub http_unsetbase {
283			my $self=shift;
284			}
285
286			# ------------------------ General Support Routines ----------------------------
287
288	williamc	1.1	sub cachefilename {
289	williamc	1.6	my $self=shift;
290	williamc	1.1	use File::Basename;
291	williamc	1.2	use Utilities::AddDir;
292	williamc	1.1	my $filebase=dirname($rest);
293			$cache="/tmp/williamc/urlhandler$$";
294			adddir($cache);
295			$filename=$cache."/".$filebase;
296			}
297