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