PackageLocator.pm revision 1.5 
1# $OpenBSD: PackageLocator.pm,v 1.5 2003/11/06 17:59:23 espie Exp $
2#
3# Copyright (c) 2003 Marc Espie.
4#
5# Redistribution and use in source and binary forms, with or without
6# modification, are permitted provided that the following conditions
7# are met:
8# 1. Redistributions of source code must retain the above copyright
9#    notice, this list of conditions and the following disclaimer.
10# 2. Redistributions in binary form must reproduce the above copyright
11#    notice, this list of conditions and the following disclaimer in the
12#    documentation and/or other materials provided with the distribution.
13#
14# THIS SOFTWARE IS PROVIDED BY THE OPENBSD PROJECT AND CONTRIBUTORS
15# ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
16# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
17# A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE OPENBSD
18# PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
19# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
20# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
21# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
22# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
23# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
24# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
25
26use strict;
27use warnings;
28
29# XXX we don't want to load Ustar all the time
30package OpenBSD::Ustar;
31
32our $AUTOLOAD;
33
34sub AUTOLOAD {
35	eval { require OpenBSD::Ustar;
36	};
37	goto &$AUTOLOAD;
38}
39
40package OpenBSD::PackageLocation;
41
42sub _new
43{
44	my ($class, $location) = @_;
45	bless { location => $location }, $class;
46}
47
48sub new
49{
50	my ($class, $location) = @_;
51	if ($location =~ m/^ftp\:/i) {
52		return OpenBSD::PackageLocation::FTP->_new($location);
53	} elsif ($location =~ m/^http\:/i) {
54		return OpenBSD::PackageLocation::HTTP->_new($location);
55	} elsif ($location =~ m/^scp\:/i) {
56		return OpenBSD::PackageLocation::SCP->_new($location);
57	} else {
58		return OpenBSD::PackageLocation::Local->_new($location);
59	}
60}
61
62package OpenBSD::PackageLocation::SCP;
63our @ISA=qw(OpenBSD::PackageLocation OpenBSD::PackageLocation::FTPorSCP);
64
65sub _new
66{
67	my ($class, $location) = @_;
68	$location =~ s/scp\:\/\///i;
69	$location =~ m/\//;
70	bless {	host => $`, path => "/$'" }, $class;
71}
72
73sub open
74{
75	my ($self, $name) = @_;
76	my $host = $self->{host};
77	my $path = $self->{path};
78	open(my $fh, '-|', "scp $host:$path$name /dev/stdout 2> /dev/null|gzip -d -c -q - 2> /dev/null") or return undef;
79	return $fh;
80}
81
82sub list
83{
84	my ($self) = @_;
85	my $host = $self->{host};
86	my $path = $self->{path};
87	return _list("ssh $host ls -l $path");
88}
89
90package OpenBSD::PackageLocation::Local;
91our @ISA=qw(OpenBSD::PackageLocation);
92
93sub open
94{
95	my ($self, $name) = @_;
96	my $fullname = $self->{location}.$name;
97	open(my $fh, '-|', "gzip -d -c -q -f 2>/dev/null $fullname") or return undef;
98	return $fh;
99}
100
101sub list
102{
103	my $self = shift;
104	my @l = ();
105	opendir(my $dir, $self->{location}) or return undef;
106	while (my $e = readdir $dir) {
107		next unless -f "$dir/$e";
108		next unless $e = ~ m/\.tgz$/;
109		push(@l, $`);
110	}
111	close($dir);
112	return @l;
113}
114
115package OpenBSD::PackageLocation::FTPorSCP;
116
117sub _list
118{
119	my ($self, $cmd) = @_;
120	my @l =();
121	local $_;
122	open(my $fh, '-|', "$cmd") or return undef;
123	while(<$fh>) {
124		chomp;
125		next if m/^d.*\s+\S/;
126		next unless m/([^\s]+)\.tgz\s*$/;
127		push(@l, $1);
128	}
129	close($fh);
130	return @l;
131}
132
133package OpenBSD::PackageLocation::HTTPorFTP;
134sub open
135{
136	my ($self, $name) = @_;
137	my $fullname = $self->{location}.$name;
138	open(my $fh, '-|', "ftp -o - $fullname 2>/dev/null|gzip -d -c -q - 2>/dev/null") or return undef;
139	return $fh;
140}
141
142package OpenBSD::PackageLocation::HTTP;
143our @ISA=qw(OpenBSD::PackageLocation::HTTPorFTP OpenBSD::PackageLocation);
144sub list
145{
146	my ($self) = @_;
147	my $fullname = $self->{location};
148	my @l =();
149	local $_;
150	open(my $fh, '-|', "echo ls|ftp -o - $fullname 2>/dev/null") or return undef;
151	# XXX assumes a pkg HREF won't cross a line. Is this the case ?
152	while(<$fh>) {
153		chomp;
154		for my $pkg (m/\<A\s+HREF=\"(.*?)\.tgz\"\>/gi) {
155			next if $pkg =~ m|/|;
156			push(@l, $pkg);
157		}
158	}
159	close($fh);
160	return @l;
161}
162
163package OpenBSD::PackageLocation::FTP;
164our @ISA=qw(OpenBSD::PackageLocation::HTTPorFTP OpenBSD::PackageLocation OpenBSD::PackageLocation::FTPorSCP);
165
166sub list
167{
168	my ($self) = @_;
169	my $fullname = $self->{location};
170	return _list("echo ls|ftp -o - $fullname 2>/dev/null");
171}
172
173
174package OpenBSD::PackageLocator;
175
176# this returns an archive handle from an uninstalled package name, currently
177# There is a cache available.
178
179use OpenBSD::PackageInfo;
180use OpenBSD::Temp;
181
182my %packages;
183my @pkgpath;
184
185if (defined $ENV{PKG_PATH}) {
186	my @tentative = split /\:/, $ENV{PKG_PATH};
187	@pkgpath = ();
188	while (my $i = shift @tentative) {
189		if ($i =~ m/^(?:ftp|http|scp)$/i) {
190			$i.= ":".(shift @tentative);
191		}
192		$i =~ m|/$| or $i.='/';
193		push @pkgpath, OpenBSD::PackageLocation->new($i);
194	}
195} else {
196	@pkgpath=(OpenBSD::PackageLocation->new("./"));
197}
198
199sub find
200{
201	my $class = shift;
202	local $_ = shift;
203
204	if ($_ eq '-') {
205		my $location = OpenBSD::PackageLocation->new('-');
206		my $package = openAbsolute($location, '');
207		bless $package, $class;
208		return $package;
209	}
210	$_.=".tgz" unless m/\.tgz$/;
211	if (exists $packages{$_}) {
212		return $packages{$_};
213	}
214	my $package;
215	if (m/\//) {
216		use File::Basename;
217
218		my ($pkgname, $path) = fileparse($_);
219		my $location = OpenBSD::PackageLocation->new($path);
220		$package = openAbsolute($location, $pkgname);
221		if (defined $package) {
222			push(@pkgpath, $location);
223		}
224	} else {
225		for my $p (@pkgpath) {
226			$package = openAbsolute($p, $_);
227			last if defined $package;
228		}
229	}
230	return $package unless defined $package;
231	$packages{$_} = $package;
232	bless $package, $class;
233}
234
235sub info
236{
237	my $self = shift;
238	return $self->{dir};
239}
240
241sub close
242{
243	my $self = shift;
244	close($self->{fh}) if defined $self->{fh};
245	$self->{fh} = undef;
246	$self->{archive} = undef;
247}
248
249sub openAbsolute
250{
251	my ($location, $name) = @_;
252	my $fh = $location->open($name);
253	if (!defined $fh) {
254		return undef;
255	}
256	my $archive = new OpenBSD::Ustar $fh;
257	my $dir = OpenBSD::Temp::dir();
258
259	my $self = { name => $_, fh => $fh, archive => $archive, dir => $dir };
260	# check that Open worked
261	while (my $e = $archive->next()) {
262		if ($e->isFile() && is_info_name($e->{name})) {
263			$e->{name}=$dir.$e->{name};
264			$e->create();
265		} else {
266			$archive->unput();
267			last;
268		}
269	}
270	if (-f $dir.CONTENTS) {
271		return $self;
272	} else {
273		CORE::close($fh);
274		return undef;
275	}
276}
277
278# allows the autoloader to work correctly
279sub DESTROY
280{
281}
282
2831;
284