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