1# ex:ts=8 sw=4:
2# $OpenBSD: PackageName.pm,v 1.50 2010/12/24 09:04:14 espie Exp $
3#
4# Copyright (c) 2003-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
21package OpenBSD::PackageName;
22
23sub url2pkgname($)
24{
25	my $name = $_[0];
26	$name =~ s|.*/||;
27	$name =~ s|\.tgz$||;
28
29	return $name;
30}
31
32# see packages-specs(7)
33sub splitname
34{
35	my $_ = shift;
36	if (/^(.*?)\-(\d.*)$/o) {
37		my $stem = $1;
38		my $rest = $2;
39		my @all = split /\-/o, $rest;
40		return ($stem, @all);
41	} else {
42		return ($_);
43	}
44}
45
46my $cached = {};
47
48sub from_string
49{
50	my ($class, $_) = @_;
51	return $cached->{$_} //= $class->new_from_string($_);
52}
53
54sub new_from_string
55{
56	my ($class, $_) = @_;
57	if (/^(.*?)\-(\d.*)$/o) {
58		my $stem = $1;
59		my $rest = $2;
60		my @all = split /\-/o, $rest;
61		my $version = OpenBSD::PackageName::version->from_string(shift @all);
62		return bless {
63			stem => $stem,
64			version => $version,
65			flavors => { map {($_, 1)} @all },
66		}, "OpenBSD::PackageName::Name";
67	} else {
68		return bless {
69			stem => $_,
70		}, "OpenBSD::PackageName::Stem";
71	}
72}
73
74sub splitstem
75{
76	my $_ = shift;
77	if (/^(.*?)\-\d/o) {
78		return $1;
79	} else {
80		return $_;
81	}
82}
83
84sub is_stem
85{
86	my $_ = shift;
87	if (m/\-\d/o || $_ eq '-') {
88		return 0;
89	} else {
90		return 1;
91	}
92}
93
94sub compile_stemlist
95{
96	my $hash = {};
97	for my $n (@_) {
98		my $stem = splitstem($n);
99		$hash->{$stem} = {} unless defined $hash->{$stem};
100		$hash->{$stem}->{$n} = 1;
101	}
102	bless $hash, "OpenBSD::PackageLocator::_compiled_stemlist";
103}
104
105sub avail2stems
106{
107	my @avail = @_;
108	return OpenBSD::PackageName::compile_stemlist(@avail);
109}
110
111package OpenBSD::PackageLocator::_compiled_stemlist;
112
113sub find
114{
115	my ($self, $stem) = @_;
116	return keys %{$self->{$stem}};
117}
118
119sub add
120{
121	my ($self, $pkgname) = @_;
122	my $stem = OpenBSD::PackageName::splitstem($pkgname);
123	$self->{$stem}->{$pkgname} = 1;
124}
125
126sub delete
127{
128	my ($self, $pkgname) = @_;
129	my $stem = OpenBSD::PackageName::splitstem($pkgname);
130	delete $self->{$stem}->{$pkgname};
131	if(keys %{$self->{$stem}} == 0) {
132		delete $self->{$stem};
133	}
134}
135
136sub find_partial
137{
138	my ($self, $partial) = @_;
139	my @result = ();
140	while (my ($stem, $pkgs) = each %$self) {
141		next unless $stem =~ /\Q$partial\E/i;
142		push(@result, keys %$pkgs);
143	}
144	return @result;
145}
146
147package OpenBSD::PackageName::dewey;
148
149my $cache = {};
150
151sub from_string
152{
153	my ($class, $string) = @_;
154	my $o = bless { deweys => [ split(/\./o, $string) ],
155		suffix => '', suffix_value => 0}, $class;
156	if ($o->{deweys}->[-1] =~ m/^(\d+)(rc|beta|pre|pl)(\d*)$/) {
157		$o->{deweys}->[-1] = $1;
158		$o->{suffix} = $2;
159		$o->{suffix_value} = $3;
160	}
161	return $o;
162}
163
164sub make
165{
166	my ($class, $string) = @_;
167	return $cache->{$string} //= $class->from_string($string);
168}
169
170sub to_string
171{
172	my $self = shift;
173	my $r = join('.', @{$self->{deweys}});
174	if ($self->{suffix}) {
175		$r .= $self->{suffix} . $self->{suffix_value};
176	}
177	return $r;
178}
179
180sub suffix_compare
181{
182	my ($a, $b) = @_;
183	if ($a->{suffix} eq $b->{suffix}) {
184		return $a->{suffix_value} <=> $b->{suffix_value};
185	}
186	if ($a->{suffix} eq 'pl') {
187		return 1;
188	}
189	if ($b->{suffix} eq 'pl') {
190		return -1;
191	}
192
193	if ($a->{suffix} gt $b->{suffix}) {
194		return -suffix_compare($b, $a);
195	}
196	# order is '', beta, pre, rc
197	# we know that a < b,
198	if ($a->{suffix} eq '') {
199		return 1;
200	}
201	if ($a->{suffix} eq 'beta') {
202		return -1;
203	}
204	# refuse to compare pre vs. rc
205	return 0;
206}
207
208sub compare
209{
210	my ($a, $b) = @_;
211	# Try a diff in dewey numbers first
212	for (my $i = 0; ; $i++) {
213		if (!defined $a->{deweys}->[$i]) {
214			if (!defined $b->{deweys}->[$i]) {
215				last;
216			} else {
217				return -1;
218			}
219		}
220		if (!defined $b->{deweys}->[$i]) {
221			return 1;
222		}
223		my $r = dewey_compare($a->{deweys}->[$i],
224			$b->{deweys}->[$i]);
225		return $r if $r != 0;
226	}
227	return suffix_compare($a, $b);
228}
229
230sub dewey_compare
231{
232	my ($a, $b) = @_;
233	# numerical comparison
234	if ($a =~ m/^\d+$/o and $b =~ m/^\d+$/o) {
235		return $a <=> $b;
236	}
237	# added lowercase letter
238	if ("$a.$b" =~ m/^(\d+)([a-z]?)\.(\d+)([a-z]?)$/o) {
239		my ($an, $al, $bn, $bl) = ($1, $2, $3, $4);
240		if ($an != $bn) {
241			return $an <=> $bn;
242		} else {
243			return $al cmp $bl;
244		}
245	}
246	return $a cmp $b;
247}
248
249package OpenBSD::PackageName::version;
250
251sub p
252{
253	my $self = shift;
254
255	return defined $self->{p} ? $self->{p} : -1;
256}
257
258sub v
259{
260	my $self = shift;
261
262	return defined $self->{v} ? $self->{v} : -1;
263}
264
265sub from_string
266{
267	my ($class, $string) = @_;
268	my $o = bless {}, $class;
269	if ($string =~ m/^(.*)v(\d+)$/o) {
270		$o->{v} = $2;
271		$string = $1;
272	}
273	if ($string =~ m/^(.*)p(\d+)$/o) {
274		$o->{p} = $2;
275		$string = $1;
276	}
277	$o->{dewey} = OpenBSD::PackageName::dewey->make($string);
278
279	return $o;
280}
281
282sub to_string
283{
284	my $o = shift;
285	my $string = $o->{dewey}->to_string;
286	if (defined $o->{p}) {
287		$string .= 'p'.$o->{p};
288	}
289	if (defined $o->{v}) {
290		$string .= 'v'.$o->{v};
291	}
292	return $string;
293}
294
295sub pnum_compare
296{
297	my ($a, $b) = @_;
298	return $a->p <=> $b->p;
299}
300
301sub compare
302{
303	my ($a, $b) = @_;
304	# Simple case: epoch number
305	if ($a->v != $b->v) {
306		return $a->v <=> $b->v;
307	}
308	# Simple case: only p number differs
309	if ($a->{dewey} eq $b->{dewey}) {
310		return $a->pnum_compare($b);
311	}
312
313	return $a->{dewey}->compare($b->{dewey});
314}
315
316sub has_issues
317{
318	my $self = shift;
319	if ($self->{dewey}{deweys}[-1] =~ m/v\d+$/ && defined $self->{p}) {
320		return ("correct order is pNvM");
321	} else {
322		return ();
323	}
324}
325
326package OpenBSD::PackageName::versionspec;
327our @ISA = qw(OpenBSD::PackageName::version);
328
329my $ops = {
330	'<' => 'lt',
331	'<=' => 'le',
332	'>' => 'gt',
333	'>=' => 'ge',
334	'=' => 'eq'
335};
336
337sub from_string
338{
339	my ($class, $s) = @_;
340	my ($op, $version) = ('=', $s);
341	if ($s =~ m/^(\>\=|\>|\<\=|\<|\=)(.*)$/) {
342		($op, $version) = ($1, $2);
343	}
344	bless $class->SUPER::from_string($version),
345		"OpenBSD::PackageName::version::$ops->{$op}";
346}
347
348sub pnum_compare
349{
350	my ($spec, $b) = @_;
351	if (!defined $spec->{p}) {
352		return 0;
353	} else {
354		return $spec->SUPER::pnum_compare($b);
355	}
356}
357
358sub is_exact
359{
360	return 0;
361}
362package OpenBSD::PackageName::version::lt;
363our @ISA = qw(OpenBSD::PackageName::versionspec);
364sub match
365{
366	my ($self, $b) = @_;
367	-$self->compare($b) >= 0 ? 0 : 1;
368}
369
370package OpenBSD::PackageName::version::le;
371our @ISA = qw(OpenBSD::PackageName::versionspec);
372sub match
373{
374	my ($self, $b) = @_;
375	-$self->compare($b) <= 0 ? 1 : 0;
376}
377
378package OpenBSD::PackageName::version::gt;
379our @ISA = qw(OpenBSD::PackageName::versionspec);
380sub match
381{
382	my ($self, $b) = @_;
383	-$self->compare($b) > 0 ? 1 : 0;
384}
385
386package OpenBSD::PackageName::version::ge;
387our @ISA = qw(OpenBSD::PackageName::versionspec);
388sub match
389{
390	my ($self, $b) = @_;
391	-$self->compare($b) >= 0 ? 1 : 0;
392}
393
394package OpenBSD::PackageName::version::eq;
395our @ISA = qw(OpenBSD::PackageName::versionspec);
396sub match
397{
398	my ($self, $b) = @_;
399	-$self->compare($b) == 0 ? 1 : 0;
400}
401
402sub is_exact
403{
404	return 1;
405}
406
407package OpenBSD::PackageName::Stem;
408sub to_string
409{
410	my $o = shift;
411	return $o->{stem};
412}
413
414sub to_pattern
415{
416	my $o = shift;
417	return $o->{stem}.'-*';
418}
419
420sub has_issues
421{
422	my $self = shift;
423	return ("is a stem");
424}
425
426package OpenBSD::PackageName::Name;
427sub flavor_string
428{
429	my $o = shift;
430	return join('-', sort keys %{$o->{flavors}});
431}
432
433sub to_string
434{
435	my $o = shift;
436	return join('-', $o->{stem}, $o->{version}->to_string,
437	    sort keys %{$o->{flavors}});
438}
439
440sub to_pattern
441{
442	my $o = shift;
443	return join('-', $o->{stem}, '*', $o->flavor_string);
444}
445
446sub compare
447{
448	my ($a, $b) = @_;
449	if ($a->{stem} ne $b->{stem} || $a->flavor_string ne $b->flavor_string) {
450		return undef;
451	}
452	return $a->{version}->compare($b->{version});
453}
454
455sub has_issues
456{
457	my $self = shift;
458	return ((map {"flavor $_ can't start with digit"}
459	    	grep { /^\d/ } keys %{$self->{flavors}}),
460		$self->{version}->has_issues);
461}
462
4631;
464