Search.pm revision 1.10 
1# ex:ts=8 sw=4:
2# $OpenBSD: Search.pm,v 1.10 2009/04/19 15:18:23 espie Exp $
3#
4# Copyright (c) 2007 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
18package OpenBSD::Search;
19sub match_locations
20{
21	my ($self, $o) = @_;
22	require OpenBSD::PackageLocation;
23
24	my @l = map {$o->new_location($_)} $self->match($o);
25	return \@l;
26}
27
28# XXX this is not efficient
29sub filter_locations
30{
31	my ($self, $l) = @_;
32	my $r = [];
33	for my $loc (@$l) {
34		if ($self->filter($loc->{name})) {
35			push(@$r, $loc);
36		}
37	}
38	return $r;
39}
40
41package OpenBSD::Search::PkgSpec;
42our @ISA=(qw(OpenBSD::Search));
43
44sub match_ref
45{
46	my ($self, $r) = @_;
47	return $self->{spec}->match_ref($r);
48}
49
50sub match
51{
52	my ($self, $o) = @_;
53	return $self->match_ref($o->list);
54}
55
56sub match_locations
57{
58	my ($self, $o) = @_;
59	return $self->{spec}->match_locations($o->locations_list);
60}
61
62sub filter_locations
63{
64	my ($self, $l) = @_;
65	return $self->{$spec}->match_locations($l);
66}
67
68sub filter
69{
70	my ($self, @list) = @_;
71	return $self->match_ref(\@list);
72}
73
74sub new
75{
76	my ($class, $pattern) = @_;
77	require OpenBSD::PkgSpec;
78
79	bless { spec => $class->spec_class->new($pattern)}, $class;
80}
81
82sub add_pkgpath_hint
83{
84	my ($self, $pkgpath) = @_;
85	$self->{pkgpath} = $pkgpath;
86}
87
88sub spec_class
89{ "OpenBSD::PkgSpec" }
90
91package OpenBSD::Search::Exact;
92our @ISA=(qw(OpenBSD::Search::PkgSpec));
93sub spec_class
94{ "OpenBSD::PkgSpec::Exact" }
95
96package OpenBSD::Search::Stem;
97our @ISA=(qw(OpenBSD::Search));
98
99sub new
100{
101	my ($class, $stem) = @_;
102
103	return bless {stem => $stem}, $class;
104}
105
106sub split
107{
108	my ($class, $pkgname) = @_;
109	require OpenBSD::PackageName;
110
111	return $class->new(OpenBSD::PackageName::splitstem($pkgname));
112}
113
114sub match
115{
116	my ($self, $o) = @_;
117	return $o->stemlist->find($self->{stem});
118}
119
120sub _keep
121{
122	my ($self, $stem) = @_;
123	return $self->{stem} eq $stem;
124}
125
126sub filter
127{
128	my ($self, @l) = @_;
129	my @result = ();
130	require OpenBSD::PackageName;
131	for my $pkg (@l) {
132		if ($self->_keep(OpenBSD::PackageName::splitstem($pkgname))) {
133			push(@result, $pkg);
134		}
135	}
136	return @result;
137}
138
139package OpenBSD::Search::PartialStem;
140our @ISA=(qw(OpenBSD::Search::Stem));
141
142sub match
143{
144	my ($self, $o) = @_;
145	return $o->stemlist->find_partial($self->{stem});
146}
147
148sub _keep
149{
150	my ($self, $stem) = @_;
151	my $partial = $self->{stem};
152	return $stem =~ /\Q$partial\E/;
153}
154
155package OpenBSD::Search::Filter;
156our @ISA=(qw(OpenBSD::Search));
157
158sub new
159{
160	my ($class, $code) = @_;
161
162	return bless {code => $code}, $class;
163}
164
165sub filter
166{
167	my ($self, @l) = @_;
168	return &{$self->{code}}(@l);
169}
170
171package OpenBSD::Search::FilterLocation;
172our @ISA=(qw(OpenBSD::Search));
173sub new
174{
175	my ($class, $code) = @_;
176
177	return bless {code => $code}, $class;
178}
179
180sub filter_locations
181{
182	my ($self, $l) = @_;
183	return &{$self->{code}}($l);
184}
185
186sub keep_most_recent
187{
188	my $class = shift;
189	return $class->new(
190sub {
191	my $l = shift;
192	# no need to filter
193	return $l if @$l <= 1;
194
195	require OpenBSD::PackageName;
196	my $h = {};
197	# we have to prove we have to keep it
198	while (my $e = pop @$l) {
199		my $stem = $e->pkgname->{stem};
200		my $keep = 1;
201		# so let's compare with every element in $h with the same stem
202		for my $f (@{$h->{$e->pkgname->{stem}}}) {
203			# if this is not the same flavors,
204			# we don't filter
205			if ($f->pkgname->flavor_string ne $e->pkgname->flavor_string) {
206				next;
207			}
208			# okay, now we need to prove there's a common pkgpath
209			if (!$e->update_info->match_pkgpath($f->update_info)) {
210				next;
211			}
212
213			if ($f->pkgname->{version}->compare($e->pkgname->{version}) < 0) {
214			    $f = $e;
215			}
216			$keep = 0;
217			last;
218
219		}
220		if ($keep) {
221			push(@{$h->{$e->pkgname->{stem}}}, $e);
222		}
223	}
224	my $largest = [];
225	push @$largest, map {@$_} values %$h;
226	return $largest;
227}
228	);
229}
230
2311;
232