1# ex:ts=8 sw=4:
2# $OpenBSD: Installed.pm,v 1.26 2010/07/02 11:17:46 espie Exp $
3#
4# Copyright (c) 2007-2010 Marc Espie <espie@openbsd.org>
5#
6# Permission to use, copy, modify, and distribute this software for any
7# purpose with or without fee is hereby granted, provided that the above
8# copyright notice and this permission notice appear in all copies.
9#
10# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
11# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
12# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
13# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
14# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
15# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
16# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
17
18use strict;
19use warnings;
20
21# XXX: we want to be able to load PackageRepository::Installed stand-alone,
22# so we put the only common method into PackageRepositoryBase.
23#
24# later, when we load the base PackageRepository, we tweak the inheritance
25# of PackageRepository::Installed to have full access...
26
27package OpenBSD::PackageRepositoryBase;
28
29sub parse_url
30{
31	my ($class, $r, $state) = @_;
32
33	my $path;
34
35	if ($$r =~ m/^(.*?)\:(.*)/) {
36		$path = $1;
37		$$r = $2;
38	} else {
39		$path = $$r;
40		$$r = '';
41	}
42
43	$path .= '/' unless $path =~ m/\/$/;
44	bless { path => $path, state => $state }, $class;
45}
46
47sub parse_fullurl
48{
49	my ($class, $r, $state) = @_;
50
51	$class->strip_urlscheme($r) or return undef;
52	return $class->parse_url($r, $state);
53}
54
55sub strip_urlscheme
56{
57	my ($class, $r) = @_;
58	if ($$r =~ m/^(.*?)\:(.*)$/) {
59		my $scheme = lc($1);
60		if ($scheme eq $class->urlscheme) {
61			$$r = $2;
62			return 1;
63	    	}
64	}
65	return 0;
66}
67
68sub match_locations
69{
70	my ($self, $search, @filters) = @_;
71	my $l = $search->match_locations($self);
72	while (my $filter = (shift @filters)) {
73		last if @$l == 0; # don't bother filtering empty list
74		$l = $filter->filter_locations($l);
75	}
76	return $l;
77}
78
79sub url
80{
81	my ($self, $name) = @_;
82	return $self->urlscheme.':'.$self->relative_url($name);
83}
84
85sub finish_and_close
86{
87	my ($self, $object) = @_;
88	$self->close($object);
89}
90
91sub close_now
92{
93	my ($self, $object) = @_;
94	$self->close($object, 0);
95}
96
97sub close_after_error
98{
99	my ($self, $object) = @_;
100	$self->close($object, 1);
101}
102
103sub close_with_client_error
104{
105	my ($self, $object) = @_;
106	$self->close($object, 1);
107}
108
109sub canonicalize
110{
111	my ($self, $name) = @_;
112
113	if (defined $name) {
114		$name =~ s/\.tgz$//o;
115	}
116	return $name;
117}
118
119sub new_location
120{
121	my ($self, @args) = @_;
122
123	return $self->locationClassName->new($self, @args);
124}
125
126sub locationClassName
127{ "OpenBSD::PackageLocation" }
128
129sub locations_list
130{
131	my $self = shift;
132	if (!defined $self->{locations}) {
133		my $l = [];
134		require OpenBSD::PackageLocation;
135
136		for my $name (@{$self->list}) {
137			push @$l, $self->new_location($name);
138		}
139		$self->{locations} = $l;
140	}
141	return $self->{locations};
142}
143
144package OpenBSD::PackageRepository::Installed;
145
146our @ISA = (qw(OpenBSD::PackageRepositoryBase));
147
148sub urlscheme
149{
150	return 'inst';
151}
152
153use OpenBSD::PackageInfo (qw(is_installed installed_info
154    installed_packages installed_stems installed_name));
155
156sub new
157{
158	my ($class, $all, $state) = @_;
159	return bless { all => $all, state => $state }, $class;
160}
161
162sub relative_url
163{
164	my ($self, $name) = @_;
165	return $name or '';
166}
167
168sub close
169{
170}
171
172sub canonicalize
173{
174	my ($self, $name) = @_;
175	return installed_name($name);
176}
177
178sub find
179{
180	my ($repository, $name, $arch) = @_;
181	my $self;
182
183	if (is_installed($name)) {
184		require OpenBSD::PackageLocation;
185
186		$self = $repository->new_location($name);
187		$self->{dir} = installed_info($name);
188	}
189	return $self;
190}
191
192sub locationClassName
193{ "OpenBSD::PackageLocation::Installed" }
194
195sub grabPlist
196{
197	my ($repository, $name, $arch, $code) = @_;
198	require OpenBSD::PackingList;
199	return  OpenBSD::PackingList->from_installation($name, $code);
200}
201
202sub available
203{
204	my $self = shift;
205	return installed_packages($self->{all});
206}
207
208sub list
209{
210	my $self = shift;
211	my @list = installed_packages($self->{all});
212	return \@list;
213}
214
215sub stemlist
216{
217	return installed_stems();
218}
219
220sub wipe_info
221{
222}
223
224sub may_exist
225{
226	my ($self, $name) = @_;
227	return is_installed($name);
228}
229
2301;
231