summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--usr.sbin/pkg/Makefile10
-rw-r--r--usr.sbin/pkg/pkg.pl388
2 files changed, 398 insertions, 0 deletions
diff --git a/usr.sbin/pkg/Makefile b/usr.sbin/pkg/Makefile
new file mode 100644
index 00000000000..3c0725775c2
--- /dev/null
+++ b/usr.sbin/pkg/Makefile
@@ -0,0 +1,10 @@
+# $OpenBSD: Makefile,v 1.1 2001/04/02 10:11:16 espie Exp $
+
+NOMAN=
+NOPROG=
+
+afterinstall:
+ ${INSTALL} ${INSTALL_COPY} -o ${BINOWN} -g ${BINGRP} -m ${BINMODE} \
+ ${.CURDIR}/pkg.pl ${DESTDIR}${BINDIR}/pkg
+
+.include <bsd.prog.mk>
diff --git a/usr.sbin/pkg/pkg.pl b/usr.sbin/pkg/pkg.pl
new file mode 100644
index 00000000000..0f975aa84e5
--- /dev/null
+++ b/usr.sbin/pkg/pkg.pl
@@ -0,0 +1,388 @@
+#!/usr/bin/perl
+# ex:ts=8 sw=4:
+# $OpenBSD: pkg.pl,v 1.1 2001/04/02 10:11:16 espie Exp $
+#
+# Copyright (c) 2001 Marc Espie.
+#
+# Redistribution and use in source and binary forms, with or without
+# modification, are permitted provided that the following conditions
+# are met:
+# 1. Redistributions of source code must retain the above copyright
+# notice, this list of conditions and the following disclaimer.
+# 2. Redistributions in binary form must reproduce the above copyright
+# notice, this list of conditions and the following disclaimer in the
+# documentation and/or other materials provided with the distribution.
+#
+# THIS SOFTWARE IS PROVIDED BY THE OPENBSD PROJECT AND CONTRIBUTORS
+# ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE OPENBSD
+# PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+require 5.6.0;
+
+use strict;
+use Getopt::Std;
+
+# This is a first implementation of the pkg_* perl replacement.
+# We are doing this piecewise, handling larger and larger parts of
+# package handling in perl, until the corresponding C code just vanishes.
+
+# This code is going to change a lot in the near future.
+
+# Currently, it's a bare-bones implementation of the new dependency
+# handler. Note that even the syntax may change.
+
+my $vardb = $ENV{'PKG_DBDIR'} || '/var/db/pkg';
+my $verbose;
+
+sub compare_pseudo_numbers
+{
+ my ($n, $m) = @_;
+
+ my ($n1, $m1);
+
+ if ($n =~ m/^\d+/) {
+ $n1 = $&;
+ $n = $';
+ }
+ if ($m =~ m/^\d+/) {
+ $m1 = $&;
+ $m = $';
+ }
+
+ if ($n1 == $m1) {
+ return $n cmp $m;
+ } else {
+ return $n1 <=> $m1;
+ }
+}
+
+
+sub dewey_compare
+{
+ my ($a, $b) = @_;
+ my ($pa, $pb);
+
+ unless ($b =~ m/p\d+$/) { # does the Dewey hold a p<number> ?
+ $a =~ s/p\d+$//; # No -> strip it from version.
+ }
+
+ return 0 if $a =~ /^$b$/; # bare equality
+
+ if ($a =~ s/p(\d+)$//) { # extract patchlevels
+ $pa = $1;
+ }
+ if ($b =~ s/p(\d+)$//) {
+ $pb = $1;
+ }
+
+ my @a = split(/\./, $a);
+ push @a, $pa if defined $pa; # ... and restore them
+ my @b = split(/\\\./, $b);
+ push @b, $pb if defined $pb;
+ while (@a > 0 && @b > 0) {
+ my $va = shift @a;
+ my $vb = shift @b;
+ next if $va eq $vb;
+ return compare_pseudo_numbers($va, $vb);
+ }
+ if (@a > 0) {
+ return 1;
+ } else {
+ return -1;
+ }
+}
+
+sub check_version
+{
+ my ($v, $spec) = @_;
+ local $_;
+
+ # any version spec
+ return 1 if $spec eq '.*';
+
+ my @specs = split(/,/, $spec);
+ for (grep /^\d/, @specs) { # exact number: check match
+ return 1 if $v =~ /^$_$/;
+ return 1 if $v =~ /^${_}p\d+$/; # allows for recent patches
+ }
+ for (grep !/^\d/, @specs) { # dewey match, all of them
+ if (m/^\<\=|\>\=|\<|\>/) {
+ my ($op, $dewey) = ($&, $');
+ my $compare = dewey_compare($v, $dewey);
+ return 0 if $op eq '<' && $compare >= 0;
+ return 0 if $op eq '<=' && $compare > 0;
+ return 0 if $op eq '>' && $compare <= 0;
+ return 0 if $op eq '>=' && $compare < 0;
+ }
+ }
+ return 1;
+}
+
+sub check_1flavor
+{
+ my ($f, $spec) = @_;
+ local $_;
+
+ for (split /-/, $spec) {
+ # must not be here
+ if (m/^\!/) {
+ return 0 if $f->{$'};
+ # must be here
+ } else {
+ return 0 unless $f->{$_};
+ }
+ }
+ return 1;
+}
+
+sub check_flavor
+{
+ my ($f, $spec) = @_;
+ local $_;
+ # no flavor constraints
+ return 1 if $spec eq '';
+
+ # retrieve all flavors
+ my %f = map +($_, 1), split /\-/, $f;
+
+ # check each flavor constraint
+ for (split /,/, $spec) {
+ if (check_1flavor(\%f, $_)) {
+ return 1;
+ }
+ }
+ return 0;
+}
+
+sub subpattern_match
+{
+ my ($p, $list) = @_;
+ local $_;
+
+ my ($stemspec, $vspec, $flavorspec);
+
+ # first, handle special characters (shell -> perl)
+ $p =~ s/\./\\\./g;
+ $p =~ s/\+/\\\+/g;
+ $p =~ s/\*/\.\*/g;
+ $p =~ s/\?/\./g;
+
+ # then, guess at where the version number is if any,
+
+ # this finds patterns like -<=2.3,>=3.4.p1-
+ # the only constraint is that the actual number
+ # - must start with a digit,
+ # - not contain - or ,
+ if ($p =~ m/\-((?:\>|\>\=|\<|\<\=)?\d[^-]*)/) {
+ ($stemspec, $vspec, $flavorspec) = ($`, $1, $');
+ # `any version' matcher
+ } elsif ($p =~ m/\-(\.\*)/) {
+ ($stemspec, $vspec, $flavorspec) = ($`, $1, $');
+ # okay, so no version marker. Assume no flavor spec.
+ } else {
+ ($stemspec, $vspec, $flavorspec) = ($p, '', '');
+ }
+
+ print "$stemspec, $vspec, $flavorspec\n" if $verbose;
+ $p = "$stemspec-\.\*" if $vspec ne '';
+
+ # First trim down the list
+ my @l = grep {/^$p$/} @$list;
+
+ my @result = ();
+ # Now, have to extract the version number, and the flavor...
+ for (@l) {
+ my ($stem, $v, $flavor);
+ if (m/\-(\d[^-]*)/) {
+ ($stem, $v, $flavor) = ($`, $1, $');
+ if ($stem =~ m/^$stemspec$/ &&
+ check_version($v, $vspec) &&
+ check_flavor($flavor, $flavorspec)) {
+ push(@result, $_);
+ }
+ }
+ }
+
+ print join(', ', @result), "\n";
+ return @result;
+}
+
+sub pattern_match
+{
+ my ($pattern, $list) = @_;
+ my @l;
+
+ for my $subpattern (split /\|/, $pattern) {
+ @l = subpattern_match($subpattern, $list);
+ if (@l > 0) {
+ return $l[0];
+ }
+ }
+ return 0;
+}
+
+sub check_dependencies
+{
+ my $pattern = shift;
+ unless (chdir $vardb) {
+ die "Directory $vardb absent\n";
+ }
+ my @list = glob '*';
+ # Try subpatterns in sequence
+ return pattern_match($pattern, \@list) ? 1 : 0;
+}
+
+sub solve_dependencies
+{
+ my $file = shift;
+ my $pkgname;
+ my %verify;
+ my @lines;
+
+ open(FILE, '<', $file);
+ # Parse the old plist, scanning for what we want to handle only.
+ while (<FILE>) {
+ chomp;
+ if (m/^\@name\s+/) {
+ $pkgname=$';
+ }
+ elsif (m/^\@newdepend\s+/) {
+ my ($name, $pattern, $def) = split(/\:/, $');
+ unless (defined $verify{$name}) {
+ $verify{$name} = [];
+ }
+ push(@{$verify{$name}}, [$pattern, $def]);
+ push(@lines, "\@comment newdepend $name:$pattern:$def");
+ } else {
+ push(@lines, $_);
+ }
+ }
+ close(FILE);
+
+ open FILE, '>', "$file";
+ print FILE "\@name $pkgname\n";
+ my @todo = ($pkgname);
+ my %done = ();
+
+ unless (chdir $vardb) {
+ die "Directory $vardb absent\n";
+ }
+ my @list = glob '*';
+
+ # create all the new pkgdep stuff
+
+ for my $check (@todo) {
+ print "Handling dependencies for $check\n" if $verbose;
+ for my $dep (@{$verify{$check}}) {
+ print " checking ", $dep->[0], " (", $dep->[1],
+ ") -> " if $verbose;
+ my $r = pattern_match($dep->[0], \@list);
+ if ($r) {
+ print "$r\n" if $verbose;
+ } else {
+ print "Not found\n" if $verbose;
+ }
+ # unshift so that base dependencies happen first.
+ if ($r) {
+ unshift @lines, "\@pkgdep $r";
+ } else {
+ unshift @lines, "\@pkgdep ".$dep->[1];
+ push @todo, $dep->[1] unless $done{$dep->[1]};
+ }
+ }
+ $done{$check} = 1;
+ }
+ for my $l (@lines) {
+ print FILE $l, "\n";
+ }
+ close FILE;
+}
+
+sub resolve_version
+{
+ return $_ if -d $_;
+ my @l = glob("$_-[0-9]*");
+ if (@l > 0) {
+ return $l[0];
+ } else {
+ return undef;
+ }
+}
+
+sub show_forward_dependencies
+{
+ my @l = @_;
+
+ local $_;
+
+ unless (chdir $vardb) {
+ die "Directory $vardb absent\n";
+ }
+
+ @l = map(resolve_version, @l);
+
+ my %known = map +($_,1), @l;
+
+ open(OUT, "|tsort -f -r|tr '\012' '\040';echo");
+ for my $p (@l) {
+ print OUT "$p $p\n";
+ if (open(DEPS, "$p/+REQUIRED_BY")) {
+ while (<DEPS>) {
+ chomp;
+ print OUT "$p $_\n";
+ unless ($known{$_}) {
+ push(@l, $_);
+ $known{$_} = 1;
+ }
+ }
+ close DEPS;
+ }
+ }
+ close OUT;
+}
+
+# Pass this off to the old package commands
+my %legacy = map +($_, 1), qw{add info delete create};
+my %opts;
+
+getopts('v', \%opts);
+
+$verbose = 1 if defined($opts{'v'});
+
+if (@ARGV == 0) {
+ die "needs arguments\n";
+}
+
+my $cmd = shift;
+
+if (defined $legacy{$cmd}) {
+ if (defined $opts{'v'}) {
+ unshift(@ARGV, '-v');
+ }
+ exec { "pkg_$cmd"} ("pkg_$cmd", @ARGV);
+} elsif ($cmd eq 'dependencies') {
+ my $sub = shift;
+ if ($sub eq 'check') {
+ if (check_dependencies(shift)) {
+ exit(0);
+ } else {
+ exit(1);
+ }
+ } elsif ($sub eq 'solve') {
+ solve_dependencies(shift);
+ exit(0);
+ } elsif ($sub eq 'show') {
+ show_forward_dependencies(@ARGV);
+ exit(0);
+ }
+ die "Bad dependency subcommand $sub\n";
+}
+die "Bad command $cmd\n";
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-15 17:18:27 +0000