Documentation/scripts/prt-auf

#!/usr/bin/perl
#
# prt-auf --- add/update frontend to CRUX pkgutils (offers mostly the same
#             user experience as prt-get except for the slight delay
#             entailed by Perl having to compile this file on startup)
#
# distributed under the same license as the pkgutils,
# https://crux.nu/gitweb/?p=tools/pkgutils.git;a=blob_plain;f=COPYING;hb=HEAD
#
use warnings;
use strict;

################### Initialize global variables #######################
my $title="prt-auf";                   my $version=0.51; my $cache_ver="V5.1";
my $CONFDIR = "/var/lib/pkg";          my $prtalias="/etc/prt-get.aliases";
my $pkgdb="$CONFDIR/db";               my $prtlocker="$CONFDIR/prt-get.locker";
my $prtcache="$CONFDIR/prt-get.cache"; my %LOCKED; my %ALIASES; my %DEPENDS;
my @allports; my %V_REPO; my %V_INST;  my %DESC; my %SOFTDEPS;
my @results; my $strf; my $ind;  my $hh; my $portpath; my $built_pkg;
my %osearch = ( cache=>0, regex=>0, path=>0, exact=>0, verbose=>0 );
my %odepends = ( inject=>1, soft=>0, tree=>0, recursive=>0, all=>0 );
my %opkg = ( margs=>"", aargs=>"", rargs=>"", runscripts=>"yes", nolock=>0,
	makecommand=>"/usr/bin/pkgmk", addcommand=>"/usr/bin/pkgadd",
	removecommand=>"/usr/bin/pkgrm", test=>"no", group=>"no" );
my %olog = ( write => "disabled", mode => "overwrite", rm_on_success => "yes",
	file => "/var/log/pkgbuild/%n.log" );
my $prtconf = "/etc/prt-get.conf";

################### Process the given command #########################
my ($action, @query) = parse_args(@ARGV);
if ($0 =~ /cache$/) { $osearch{cache} = 1; }
if (($0 =~ /cache$/) and ($action eq "cache")) {
	print "cannot create cache from a cache!\nUse $title instead.\n";
	exit 0;
}
my @bldirs = parse_prt_conf($prtconf);
my @basedirs = @{$bldirs[0]}; my @localports = @{$bldirs[1]};

# load some data structures into memory for the actions that need them

get_locked_and_aliased();

if (($action !~ /^(fsearch|isinst|current)$/) and ($osearch{cache}==0)) {
  @allports = list_ports();
  fill_hashes_from_pkgfiles();
}
if ($osearch{cache}==1) { fill_hashes_from_cache(); }

if ($action !~ /^(search|dsearch|fsearch|info|dup|ls|readme|cat)$/) {
    open (DB, $pkgdb) or die "Could not open package database!\n";
    local $/="";
    while (<DB>) { $V_INST{$1} = $2 if m/^(.*)\n(.*)\n/; }
    close (DB);
}

##############  Branch based on the requested action   #################

if ($action eq "path") { @results = find_port_by_name($query[0],1,1,0);
} elsif ($action eq "search") { @results = find_port_by_name(@query,0,$osearch{path},1);
} elsif ($action eq "fsearch") { $hh = find_port_by_file(".footprint", @query);
} elsif ($action eq "dsearch") { @results = find_port_by_desc(@query);
} elsif ($action eq "info") { $portpath = find_port_by_name(@query,1,1,0);
  @results = get_pkgfile_fields($portpath,"all") if ($portpath);
} elsif ($action eq "cache") { printf_ports("CACHE",@allports);
} elsif ($action eq "printf") { @results = ($osearch{filter}) ?
  find_port_by_name($osearch{filter},0,1,1) : @allports;
  printf_ports($query[0],@results);
} elsif ($action eq "lock") { port_lock(@query);
} elsif ($action eq "unlock") { port_unlock(@query);
} elsif ($action eq "ls") { port_ls(@query);
} elsif ($action =~ /^(cat|edit|readme)$/) { port_edit($1,@query);
} elsif ($action =~ /^(depends|quickdep)$/) { @results=deporder($1,@query);
} elsif ($action =~ /^dep(endent|tree)$/) { @results=list_ports($action,@query);
} elsif ($action eq "install") { @results = up_inst(@query);
} elsif ($action eq "dup") { $ind=find_dups(@query);
} elsif ($action eq "remove") { $ind=uninstall(@query);
} elsif ($action =~ /^(isinst|current|sysup)$/) { @results = port_diff($1,@query);
} elsif ($action =~ /(.*)diff$/) { @results = port_diff($1);
} elsif ($action =~ /^list(.*)/) { @results = list_ports($1);
} elsif ($action eq "help") { print_help();
} elsif ($action eq "version") { print "$title $version\n";
} else { printf "Unsupported command '$action'.\n"; }

#################### Post-transaction reports #######################
$strf = "%s\n";
if (($action =~ /^(listinst|listorphans|dependent)/) and
 ($odepends{tree}==0)) {
    foreach my $result (sort @results) {
   $result = ($osearch{verbose}==1) ? " $result: $V_INST{$result}" : "  $result";
   $result = ($osearch{verbose}>1) ? " $result: $V_INST{$result}\n$DESC{$result}\n" : $result;
        printf $strf, $result;
    }
} elsif ($action =~ /^(list|search|dsearch|path)/) {
   foreach my $result (@results) {
   next if ((! $result) or ($result =~ /^\s*$/));
   $result =~ s/.*\/(.*)$/$1/ if (($action ne "path") and ($osearch{path}==0));
   $result .= " $V_REPO{$result}" if (($osearch{verbose}==1) and ($action ne "path"));
   $result .= " $V_REPO{$result}\n$DESC{$result}\n" if (($osearch{verbose}>1) and ($action ne "path"));
        printf $strf, $result;
    }
} elsif ($action =~ /^(fsearch)/) {
   my %hits = %{$hh}; $strf = "%20s  %s\n"; my @fmatch;
   printf $strf, "Found in", "Matching File";
   foreach my $fh (keys %hits) {
	chomp($hits{$fh});
	@fmatch = split /\s/, $hits{$fh};
	foreach my $fileN (@fmatch) { printf $strf, $fh, $fileN; }
   }
} elsif ($action =~ /^(current|isinst|dup|diff|quickdiff)$/) {
      my $format = "%20s %15s %20s\n"; my $ind = shift(@results);
      if ($action eq "diff") { printf $format, "Port", "Installed", "Available in Repo"; }
      foreach my $diffline (@results) {
	  if ($action =~ /^(current|isinst)$/) { print "$diffline\n"; next; }
          my ($diffN, $diffI, $diffR) = split(/ /, $diffline);
          next if (($osearch{filter}) and ($diffN !~ /$osearch{filter}/));
          next if (($LOCKED{$diffN}) and ($odepends{all}==0));
          printf "$format", $diffN, $diffI, $diffR if ($action eq "diff");
          printf "%s ", $diffN if ($action eq "quickdiff");
      }
      print "\n" if ($action eq "quickdiff");
      exit $ind;
} elsif ($action =~ /^(depends|quickdep)$/) {
  print "-- dependency list ([i] = installed)\n" if ($action =~ /^dep/);
  my $strf="%3s %s\n"; my $dep; my $missing=0;
  foreach $dep (@results) {
    if ($dep =~ /MISSING/) { $missing=1; print "-- missing packages\n"; next; }
    if (! $dep) { next; }
    if ($action ne "quickdep") {
      $ind = (grep { $_ eq $dep } keys %V_INST) ? "[i]" : "[ ]";
      $dep .= " $V_REPO{$dep}" if ($osearch{verbose}==1);
      $dep .= " $V_REPO{$dep}\n$DESC{$dep}" if ($osearch{verbose}>1);
    }
    printf $strf, $ind, $dep unless ($action eq "quickdep");
    printf "%s ", $dep if ($action eq "quickdep");
  }
  print "\n" if ($action eq "quickdep");
} elsif ($action eq "info") {
  $strf = "%14s: %-s\n";
  exit 1 if ($#results < 0);
  my @fields = ("Name", "Repository", "Version", "Release", "Description",
     "Dependencies", "URL", "Optional Deps", "Maintainer",
     "Readme", "PreInstall", "PostInstall");
  for (my $i=0; $i<9; $i++) { printf $strf, $fields[$i], $results[$i] unless ($results[$i] =~ /^\s*$/); }
} elsif ($action eq "remove") {
  my %removed = %$ind;
  my @successes = grep { $removed{$_}==1 } keys %removed;
  my @failures = grep { $removed{$_}==0 } keys %removed;
  print "Ports removed:\n" if (@successes);
  foreach my $p (@successes) { print "$p\n"; }
} elsif ($action =~ /^(install|sysup)$/) {
  my @ok = @{$results[0]}; my %ok_pre = %{$results[1]}; my %ok_post = %{$results[2]};
  my @ok_readme = @{$results[3]}; my @not_ok = @{$results[4]}; my $note;
  if ($opkg{test} eq "yes") { print "\n$action successful.\n";
	  print "*** prt-auf: test mode end\n\n"; }
  if (($opkg{test} eq "no") and (@ok)) {
    print "Successful ports:\n";
    foreach my $k (@ok) {
      $note = ($ok_pre{$k}) ? " pre: ok. " : "";
      $note .= ($ok_post{$k}) ? " post: ok. " : "";
      $note = ( grep /(pre|post):/, $note ) ? "($note)" : "";
      print "  $k $note\n";
    }
    print "\n";
  }
  if (@ok_readme) {
    print "Ports with README files:\n";
    foreach (@ok_readme) { print "  $_\n"; }
    print "\n";
  }
  if (@not_ok) {
    print "Ports with pkgmk/pkgadd failures:\n";
    foreach (@not_ok) { print "  $_\n"; }
    print "\n";
  }
} else {}

# Done!

#################### Begin Subroutines #######################
sub parse_args {
  my @query;
  while (my $arg = shift) {
    if ($arg =~ /^(search|dsearch|fsearch|path|info|list|remove)$/) { $action = $1;
    } elsif ($arg =~ /^(install|update|depinst)$/) { $action = "install";
    } elsif ($arg eq "sysup") { $action = "sysup"; $opkg{nolock}=0;
    } elsif ($arg eq "grpinst") { $action = "install"; $opkg{group} = "yes";
	    print "Warning: grpinst is obsolescent, using install --group\n"; 
    } elsif ($arg =~ /^(lock|unlock|listlocked|current|isinst)$/) { $action = $1;
    } elsif ($arg =~ /^(diff|quickdiff|printf|listinst|listorphans)$/) { 
	    $action = $1; $odepends{tree} = 0;
    } elsif ($arg =~ /^(depends|quickdep|dup|dependent)$/) { $action = $1;
    } elsif ($arg eq "deptree") { $action = $arg; $odepends{tree} = 1;
    } elsif ($arg =~ /^(readme|cat|edit|ls|help|version|cache)$/) { $action = $1;
    } elsif ($arg eq "--tree") { $odepends{tree} = 1;
    } elsif ($arg eq "--all") { $odepends{all} = 1;
    } elsif ($arg eq "--nodeps") { $odepends{inject} = 0;
    } elsif ($arg eq "--depsort") { $odepends{inject} = 1;
    } elsif ($arg eq "--softdeps") { $odepends{soft} = 1;
    } elsif ($arg eq "--recursive") { $odepends{recursive} = 1;
    } elsif ($arg eq "--cache") { $osearch{cache} = 1;
    } elsif ($arg =~ /^--config=(.+)$/) { $prtconf = $1;
    } elsif ($arg eq "--path") { $osearch{path} = 1;
    } elsif ($arg eq "--regex") { $osearch{regex} = 1;
    } elsif ($arg =~ /^--filter=(.+)/) { $osearch{filter} = $1;
    } elsif ($arg eq "-v") { $osearch{verbose} += 1;
    } elsif ($arg eq "-vv") { $osearch{verbose} += 2;
    } elsif ($arg eq "--test") { $opkg{test} = "yes";
    } elsif ($arg eq "--group") { $opkg{group} = "yes";
    } elsif ($arg eq "-fr") { $opkg{margs} .= " -f";
    } elsif ($arg eq "-fi") { $opkg{aargs} .= " -f";
    } elsif ($arg =~ /^(-uf|-if|-us|-is|-ns|-kw)$/) { $opkg{margs} .= " $1";
    } elsif ($arg =~ /^--margs=(.+)/) { $opkg{margs} .= $1;
    } elsif ($arg =~ /^--aargs=(-r|--root)=(.+)/) { $opkg{aargs} .= "$1 $2";
    } elsif ($arg =~ /^--rargs=(-r|--root)=(.+)/) { $opkg{rargs} .= "$1 $2";
    } elsif ($arg =~ /^-/) {
      print "'$arg' is not a recognized option.\n";
    } else { push (@query, $arg); }
  }
  if (! $action) { print_help(); }
  if (($#query > -1) and
     ($action =~ /^(diff|quickdiff|cache|list|sysup)/)) {
    print "warning: $1 takes no arguments; ignoring those given.\n";
  }
  if (($#query > 0) and
     ($action =~ /^(search|dsearch|fsearch|info|readme|path|ls)$/)) {
    print "warning: $1 takes only one argument; ignoring all but the first.\n";
  }
  if ((! @query) and
     ($action =~ /^(search|dsearch|fsearch|info|readme|path|ls)$/)) {
    print "$1 requires an argument.\n"; exit 1;
  }
  if (($#query != 0) and
     ($action =~ /^(deptree|dependent)$/)) {
    print "$1 requires exactly one argument.\n"; exit 1;
  }
  if (($#query < 0) and
     ($action =~ /^(install|update|depinst|remove)$/)) {
    print "$1 requires at least one argument.\n"; exit 1;
  }
  return $action, @query;
}

sub parse_prt_conf {
  my @basedirs; my @localports; my $conf = shift;

  open(PORTS, $conf) or die "could not open $conf";
  while (<PORTS>) { chomp;
    if ( /^prtdir\s+/ ) {
      my $line = $_;
      $line =~ s/^prtdir\s+//;  #remove the leading directive
      $line =~ s/#.*$//;        #strip inline comments like this one
      $line =~ s/\s+//g; #collapse all whitespace, even if in a path!
      if ( $line !~ /:/ ) {
        push @basedirs, $line if (-d $line);
      } else {
        my @a = split(/:/, $line);
        my @b = split(/,/, $a[1]);
        while ( my $c = pop @b ) {
        my $port = $a[0] . "/" . $c;
          push @localports, $port if (-d $port);
        }
      }
    }
    $opkg{runscripts} = $1 if /^runscripts\s+(yes|no)/;
    $opkg{makecommand} = $1 if /^makecommand\s+(.*)(#|$)/;
    $opkg{addcommand} = $1 if /^addcommand\s+(.*)(#|$)/;
    $opkg{removecommand} = $1 if /^removecommand\s+(.*)(#|$)/;
    $olog{write} = $1 if /^writelog\s+(enabled|disabled)/;
    $olog{mode} = $1 if /^logmode\s+(append|overwrite)/;
    $olog{rm_on_success} = $1 if /^rmlog_on_success\s+(no|yes)/;
    $olog{file} = $1 if /^logfile\s+(.*)\s*(#|$)/;
    $prtcache = $1 if /^cachefile\s+(.*)\s*(#|$)/;
  }
  close(PORTS);
  return \@basedirs, \@localports;
}

sub find_dups {
  my %seen; my $format=shift; my @dupinfo; my @info1; my $dupstr; my @hits;
  foreach my $pp (@allports) { my $pn = (split /\//, $pp)[-1]; $seen{$pn}++; }
  my @dups = grep { $seen{$_} > 1 } keys %seen;
  my %subscripts = ( "%n"=>0, "%p1"=>1, "%v1"=>2, "%u1"=>3, "%M1"=>4,
	                      "%p2"=>5, "%v2"=>6, "%u2"=>7, "%M2"=>8 );
  if (($osearch{verbose}==0) and (! $format)) {
      foreach my $dup (@dups) { print "$dup\n"; }
  } elsif (($osearch{verbose}>0) and (! $format)) {
      foreach my $dup (@dups) {
        @hits = grep /\/$dup$/, @allports;
        print "$hits[0] > $hits[1]\n" if $osearch{verbose}==1;
        printf "* %s\n"x(1+$#hits), @hits if $osearch{verbose}>1;
      }
  } else {  # the user has given us a format string; let's respect it
      foreach my $dup (@dups) {
        @hits = grep /\/$dup$/, @allports;
	@dupinfo = (get_pkgfile_fields($hits[0],"all"))[1,2,6,8];
	@info1 = (get_pkgfile_fields($hits[1],"all"))[1,2,6,8];
	push(@dupinfo,@info1); unshift(@dupinfo,$dup);
	$dupstr = "$format\n";
	$dupstr =~ s/(%n|%p1|%v1|%u1|%M1|%p2|%v2|%u2|%M2)/$dupinfo[$subscripts{$1}]/g;
	print $dupstr;
      }
  }
  return 1+$#dups;
}

sub get_locked_and_aliased {
    if (-f $prtalias) {
        open (AL, $prtalias);
        while (<AL>) { $ALIASES{$1} = $2 if m/^\s*(.*)\s*:\s*(.*)/; }
        close (AL);
    }
    if (-f $prtlocker) {
        open (LK, $prtlocker);
        while (<LK>) { chomp; $LOCKED{$_}=1 unless /^\s*$/; }
        close (LK);
    }
}

sub who_aliased_to {
  my $target = shift;
  my @substitutes = grep { defined $V_INST{$_} } keys %ALIASES;
  @substitutes = grep { $ALIASES{$_} eq $target } @substitutes;
  my $who = (@substitutes) ? $substitutes[0] : undef ;
  return $who;
}

sub printf_ports {
  my $FS; my @pstats; my $p; my $inputf=shift; my @targets=@_;
  my @pos; my @outfields; my $outputf; my %FS = ( "t"=>"\t", "n"=>"\n" );
  my %subscripts = ( "n"=>0, "p"=>1, "v"=>2, "r"=>3, "d"=>4, "u"=>5,
    "P"=>7, "M"=>8, "R"=>9, "E"=>10, "O"=>11, "l"=>12, "i"=>13);
  if ($inputf eq "CACHE") {
      open (CACHE,'>',$prtcache) or die "cannot create a new cache file";
      print CACHE "V5.1\n"; 
      my %cached;
      foreach my $pp (@targets) {
        $p = (split /\//, $pp)[-1]; next if ($cached{$p});
        @pstats = get_pkgfile_fields($pp,"all");
        printf CACHE "%s\n"x($#pstats+1), @pstats;
	printf CACHE "\n"; $cached{$p}=1;
      } close (CACHE);
      print "cache created.\n";
  } else {
      @outfields = split /(\\t|\\n)/, $inputf;

      foreach (@outfields) {
        if (m/\\(t|n)/) { $outputf .= $FS{$1}; next; } 
        $strf = $_;
      	s/%(p|n|v|r|d|u|P|M|R|E|O|l|i)/_Z_$subscripts{$1}/g;
	push @pos, grep { s/([0-9]+)(.*)/$1/ } (split /_Z_/, $_);
	$strf =~ s/%(p|n|v|r|d|u|P|M|R|E|O|l|i)/%s/g;
	$outputf .= $strf;
     }

      foreach my $pp (@targets) {
        $p = (split /\//, $pp)[-1];
	@pstats = get_pkgfile_fields($pp,"all");
	$pstats[12] = ($LOCKED{$p}) ? "yes" : "no";
	$pstats[13] = (grep /^$p$/, keys %V_INST) ? "yes" : "no";
	if (($pstats[13] eq "yes") and ($V_INST{$p} ne $V_REPO{$p})) {
		$pstats[13] = "diff" }
	printf STDOUT $outputf, @pstats[@pos];
      }
  }
}

sub fill_hashes_from_cache {
  open (my $cf,$prtcache) or die "cannot use $prtcache as a cache!\n";
  my $p; my $parent; my $deps; my $softDeps;
  my $ignored=<$cf>; chomp($ignored);
  if ($ignored ne "$cache_ver") {
	  die "incompatible cache format; regenerate by running $0 cache";
  }

  while (1) {
     $p = <$cf>; last unless defined $p;
     chomp($p); $parent = <$cf>; chomp($parent);
     push @allports, "$parent/$p";
     $V_REPO{$p} = <$cf>; chomp($V_REPO{$p});
     $V_REPO{$p} .= "-".<$cf>; $DESC{$p} = <$cf>;
     $deps = <$cf>; $ignored=<$cf>; $softDeps = <$cf>;
     chomp($deps, $softDeps, $DESC{$p}, $V_REPO{$p});
     $DEPENDS{$p} = $deps; $SOFTDEPS{$p} = $softDeps;
     $DEPENDS{$p} =~ s/, / /g; $DEPENDS{$p} =~ s/,/ /g;
     $SOFTDEPS{$p} =~ s/, / /g; $SOFTDEPS{$p} =~ s/,/ /g;
     for (my $i=8; $i<13; $i++) { $ignored = <$cf>; }
  }
  close ($cf);
}

sub fill_hashes_from_pkgfiles {
  foreach my $pp (@allports) {
    my $p = (split /\//, $pp)[-1];

    if (! $V_REPO{$p}) { # only populate hashes with the first port found
        my ($rver, $rrel, $rdesc, $rdeps, $rsoftdeps) = get_pkgfile_fields($pp);
        $V_REPO{$p} = ($rver) ? $rver : "0";
        $V_REPO{$p} .= ($rrel) ? "-$rrel" : "-1";
        $DEPENDS{$p} = ($rdeps) ? $rdeps : "";
	$SOFTDEPS{$p} = ($rsoftdeps) ? $rsoftdeps : "";
        $DEPENDS{$p} =~ s/, / /g; $DEPENDS{$p} =~ s/,/ /g;
        $SOFTDEPS{$p} =~ s/, / /g; $SOFTDEPS{$p} =~ s/,/ /g;
        $DESC{$p} = ($rdesc) ? $rdesc : "";
    }
  }
}

sub get_pkgfile_fields {
  my ($descrip, $url, $maintainer, $Version, $Release)=('','','',0,0);
  my ($readme, $preInstall, $postInstall, $Dependencies, $SoftDeps)=("no","no","no",'','');
  my $portpath = shift; my $Name = (split /\//, $portpath)[-1];
  my $pkgfile = "$portpath/Pkgfile";

  $readme = "yes" if (-f "$portpath/README") or (-f "$portpath/README.md");
  $preInstall = "yes" if (-f "$portpath/pre-install");
  $postInstall = "yes" if (-f "$portpath/post-install");
  $portpath =~ s/\/[^\/]+?$//; # now it should be called repository path!

  open(PF,$pkgfile) or die "Cannot open $pkgfile for reading!\n";
  while (<PF>) {
  chomp;
  if (s/^# Description:\s*(.*)/$1/)   { $descrip = $_; } 
  elsif (s/^# URL:\s*(.*)/$1/)        { $url = $_; }
  elsif (s/^version=(.*)/$1/)         { $Version = $_; }
  elsif (s/^release=(.*)/$1/)         { $Release = $_; }
  elsif (s/^# Depends on:\s*(.*)/$1/) { $Dependencies = $_; }
  elsif (s/^# (Optional|Nice to have):\s*(.*)/$2/) { $SoftDeps = $_; }
  elsif (s/^# Maintainer:\s*(.*)/$1/) { $maintainer = $_; }
  else {}
  } close(PF);

  $Dependencies =~ s/, / /g; $Dependencies =~ s/,/ /g;
  $SoftDeps =~ s/, / /g; $SoftDeps =~ s/,/ /g;
  if (shift) {
    return $Name, $portpath, $Version, $Release, $descrip, $Dependencies,
    $url, $SoftDeps, $maintainer, $readme, $preInstall, $postInstall;
  } else { return $Version, $Release, $descrip, $Dependencies, $SoftDeps; }
}

sub find_port_by_file { # for now only used to search footprints, but can be generalized
  my $portfile = shift; my $query = shift; my ($lp, $candidate, $fh); my %hits=();
  my $linewanted = qr/$query/is;
  LOCALENTRY: foreach $lp (@localports) {
    open ($fh, "$lp/$portfile") or die "cannot open $portfile for $lp\n";
    while (<$fh>) {
      $hits{$lp} .= (split /\s/, $_)[2]." " if $_ =~ $linewanted;
    } close ($fh);
  }
  foreach my $collection (@basedirs) {
    my $prefix = ( $osearch{path} == 1 ) ? "$collection/" : "";
    opendir (DIR, $collection) or return;
    PORTENTRY: foreach $candidate (sort(readdir(DIR))) {
      next if (! -f "$collection/$candidate/$portfile");
      open ($fh, "$collection/$candidate/$portfile") or die "cannot open $portfile in $candidate\n";
      while (<$fh>) {
        $hits{"$prefix$candidate"} .= (split /\s/, $_)[2]." " if $_ =~ $linewanted;
      } close ($fh);
    } closedir(DIR);
  }
  return \%hits;
}

sub find_port_by_desc {
  my $query=shift;
  my @hits = grep { (/$query/i) or ($DESC{$_} =~ /$query/i) } keys %DESC;
  return @hits;
}

sub find_port_by_name {
  my $query = shift; my $exact=shift; my $fullpath=shift; my $exhaustive=shift;
  $query =~ s/\+/\\\+/g unless (($action =~ /^(search|dsearch)$/) and ($osearch{regex}==1));
  $query =~ s/\./\\\./g unless (($action =~ /^(search|dsearch)$/) and ($osearch{regex}==1));
  my $pattern = ($exact==1) ? qr/^$query$/s : qr/$query/is;
  my %names_only = map { ($_ => (split /\//, $_)[-1]) } @allports;
  my @hits = grep { $names_only{$_} =~ $pattern } @allports;
  @hits = map { $names_only{$_} } @hits if $fullpath==0;
  
  return @hits if ($exhaustive==1);
  return $hits[0] if ($exhaustive==0);
}

sub uninstall {
  my $PKGRM = $opkg{removecommand};
  my @targets = grep { defined $V_INST{$_} } @_;
  my @rubbish = grep { ! defined $V_INST{$_} } @_;
  foreach my $r (@rubbish) { print "$r not installed; ignoring.\n"; }
  my %removed = map { $_ => 0 } @targets;
  foreach my $t (@targets) {
    ($opkg{test} eq "no") ? system($PKGRM,$opkg{rargs},$t) : print "$PKGRM $opkg{rargs} $t\n";
    $removed{$t}=1 if ($?>>8 == 0);
    if (($LOCKED{$t}) and ($opkg{test} eq "no")) { port_unlock($t); }
  }
  return \%removed;
}

sub port_lock {
  my %oldlocks = map { $_ => "L" } keys %LOCKED;
  my @newlocks = grep { ! defined $oldlocks{$_} } @_;
  if (@newlocks) {
    open (LK,'>>',$prtlocker) or die "cannot open $prtlocker for writing.\n";
    foreach my $lp (@newlocks) {
	  print LK "$lp\n";
	  print STDOUT "$lp locked.\n";
    } close (LK);
  }
}

sub port_unlock {
  my %unlocks = map { $_ => "U" } @_;
  my @newlocks = grep { ! defined $unlocks{$_} } keys(%LOCKED);
  open (LL, '>', $prtlocker."-tmp");
  foreach my $nl (@newlocks) { print LL "$nl\n" unless $nl =~ /^\s*$/; }
  close (LL);
  system ("mv",$prtlocker."-tmp",$prtlocker);
}

sub list_ports {
  my @found; my $subset = shift;

  if (! $subset) {      # empty arg: list all valid ports
    foreach my $collection (@basedirs) {
      opendir (DIR, $collection) or next;
      foreach my $port (sort(readdir DIR)) {
        next if (! -f "$collection/$port/Pkgfile");
	push (@found, "$collection/$port");
      } closedir (DIR);
    }
    foreach my $lp (@localports) {
      push (@found, $lp) if (-f "$lp/Pkgfile");
    }
  } elsif ($subset eq "inst") { @found = keys %V_INST;
  } elsif ($subset eq "locked") { @found = keys %LOCKED;
  } elsif ($subset =~ /^(orphans|dependent|deptree)$/) {
    my $seed; my $sseed;
    our @searchspace=(($subset eq "orphans") or ($odepends{all} == 0)) ?
      keys %V_INST : keys %V_REPO ;
    @searchspace = grep { defined $DEPENDS{$_} } @searchspace;

    if ($subset =~ /^dep/) {
	    $seed=shift; $sseed = $seed;
	    if (! find_port_by_name($seed,1,1,0)) {
	    	print "$seed not found in the ports tree.\n"; return;
	    }
    	# workaround for any port with a plus sign in its name
    	$sseed =~ s/\+/\\\+/g
    }

    if ($subset eq "orphans") {
        my %not_orphans = map { $_ => 0 } @searchspace;
        foreach my $port (@searchspace) {
	    map { $not_orphans{$_} = 1 } split(/ /, $DEPENDS{$port});
	    if ($odepends{soft} == 1) {
	        map { $not_orphans{$_} = 1 } split(/ /, $SOFTDEPS{$port});
	    }
        }
	@found = grep { $not_orphans{$_} eq 0 } keys %V_INST;
    } elsif (($subset eq "dependent") and ($odepends{recursive}==0)) {
	@found = grep { " $DEPENDS{$_} " =~ / $sseed / } @searchspace;
	if ($odepends{soft}==1) { push (@found,
		grep{ " $SOFTDEPS{$_} " =~ / $sseed / } @searchspace);
	}
	if ($odepends{tree}==1) { unshift (@found, "$seed"); }
    } elsif ($subset =~ /^dep(endent|tree)/) {
        our $direction = ($subset eq "deptree") ? "fwd" : "rev";
        my $header = (($subset eq "deptree") and ($odepends{tree} == 1)) ?
	"-- dependencies ([i] = installed, '-->' = already shown)\n":
	"-- reverse dependencies ('-->' = already shown)\n";
	if (($direction eq "fwd") and ($odepends{soft} == 1)) {
		$header =~ s/installed,/installed, [s] = installed softdep,/;
	}
	print $header unless ($odepends{tree} == 0);

 	our $indent="  "; our $height=0;
	our $ind; our %seen; our @lineage; my @fosters=();
	$ind = ($V_INST{$seed}) ? "[i]" : "[ ]";
        print "$ind $seed\n" if ($odepends{tree}==1);
	$seen{$seed} = 1;
        my @children = ($direction eq "fwd") ? split /[ ,]/, $DEPENDS{$sseed}:
		grep { " $DEPENDS{$_} " =~ / $sseed / } @searchspace;
	if ($odepends{soft}==1) {
	    @fosters = ($direction eq "fwd") ?
	    grep { ($V_INST{$_}) } split /[ ,]/, $SOFTDEPS{$sseed}:
	    grep { " $SOFTDEPS{$_} " =~ / $sseed / } @searchspace;
        }

        foreach my $sd (@children) { recurse_tree(0,$sd,$direction); }
	foreach my $sd (@fosters) { recurse_tree(1,$sd,$direction); }

        sub recurse_tree {
            my $greedy = shift; my $s = shift; my $direction=shift;
	    my $ps = (($seen{$s}) and ($odepends{all} !=1)) ? "-->\n" : "\n";
	    $ind = ($V_INST{$s}) ? "[i]" : "[ ]";
	    $ind = (($ind eq "[i]") and ($greedy)) ? "[s]" : $ind;
	    print $ind.(${indent}x(1+$height))."$s".$ps if ($odepends{tree}==1);
	    return if (($seen{$s}) and ($odepends{all} !=1));
	    $seen{$s} = 1;
            my %curdeps = ($direction eq "fwd") ?
	    	map {$_ => 0} split /[ ,]/, $DEPENDS{$s} :
	    	map {$_ => 0} grep { " $DEPENDS{$_} " =~ / $s / } @searchspace;
            if ($odepends{soft} == 1) {
                my @optionals = ($direction eq "fwd") ?
		   grep { ($V_INST{$_}) } split /[ ,]/, $SOFTDEPS{$s} :
		   grep { " $SOFTDEPS{$_} " =~ / $s / } @searchspace;
                map {$curdeps{$_} = 1} @optionals;
            }

            foreach my $dc (keys %curdeps) {
               if (grep /^$dc$/, @lineage) {
                  print "Warning: dependency cycle => ".$dc."\n" unless ($greedy|$curdeps{$dc});
                  return;
               }
            push (@lineage, $dc);
            $height = $#lineage+1;
            recurse_tree($greedy|$curdeps{$dc},$dc,$direction);
	    pop(@lineage);
	    $height = $#lineage+1;
            }
        }
      delete $seen{$seed} if ($odepends{tree} == 0);
      @found = sort(keys %seen);
      }
      # possibilities for the recursive switch have been exhausted
      else { }
  } # possibilities for the filter have been exhausted
  else { }
  return @found if ((! $subset) or ($subset =~ /^(orphans|locked)$/));
  if (! $osearch{filter}) { return @found; }
  else { return grep {$_ !~ /$osearch{filter}/} @found; }
}

sub port_diff { # find differences between the pkgdb and the repo
  my $dtype=shift;  my @argq=@_; my @outfile=(); my $retval=0;

  if ($dtype !~ /^(current|isinst|utd)/) {
    foreach my $p (sort(keys %V_INST)) {
	if (($V_REPO{$p}) and ($V_REPO{$p} ne $V_INST{$p})) {
	    ($dtype =~ /^(quick|sysup)/) ? push @outfile, "$p" :
	        push @outfile, "$p $V_INST{$p} $V_REPO{$p}";
	} elsif ((! $V_REPO{$p}) and ($dtype !~ /^(quick|sysup)/)) {
	    push @outfile, "$p $V_INST{$p} MISSING";
        }
    }
  } elsif ($dtype eq "utd") { my $q=shift(@argq);
	if (! $V_INST{$q}) { $retval--;
	} elsif (($V_REPO{$q}) and ($V_INST{$q} ne $V_REPO{$q})) { $retval++;
	} else {}
  } elsif ($dtype =~ /^(current|isinst)$/) {
      foreach my $q (@argq) {
        if (! $V_INST{$q}) {
          push @outfile, "$q: not installed"; $retval++;
        } else {
          push @outfile, "$q: version $V_INST{$q}" if ($dtype eq "current");
	  push @outfile, "$q is installed." if ($dtype eq "isinst");
        }
      }
  } else {}
  return $retval, @outfile if ($dtype !~ /^(utd|sysup)/);
  return $retval if ($dtype ne "sysup");

  # proceed with the sysup operation
  return up_inst(@outfile);
}

sub deporder { # returns a sorted list of packages required.

  my $type=shift; my @seeds=@_; our @treewalk=(); our @missing;
  our %numPred; our %children; my @result;

  # determine the minimal set of targets needed to satisfy all dependencies
  foreach my $t (@seeds) {
	  ($V_REPO{$t}) ? recurse_deptree($t) : push (@missing, $t);
  }

  sub recurse_deptree {
      my $s=shift; my %curdeps; my @optionals;

      # cycle detection
      ( grep /^$s$/, @treewalk ) ? return : push(@treewalk, $s);

      if (! $numPred{$s}) { $numPred{$s} = 0; }

      %curdeps = map { $_ => 0 } split /[ ,]/, $DEPENDS{$s};
      # if the user toggles --softdeps, consider only the
      # optional dependencies that are already installed
      if ($odepends{soft} == 1)  {
           @optionals = grep { ($V_INST{$_}) } split /[ ,]/, $SOFTDEPS{$s};
           foreach (@optionals) { $curdeps{$_} = 1; }
      }
      
      foreach my $sd (keys %curdeps) {
	      my $subit = who_aliased_to($sd);
	      if ($subit) {
		      $children{$s} .= " $subit ";
		      $numPred{$subit} += 1;
		      recurse_deptree($subit);
	      } else {
		      $children{$s} .= " $sd ";
		      $numPred{$sd} += 1;
		      recurse_deptree($sd);
	      }
      }
      pop (@treewalk);

   } # proceed with the topological sort
   # initialize a queue of nodes with in-degree zero (nothing depends on them)
   my @indZero = grep { ($numPred{$_} == 0) } keys %numPred; 

   # move each node from the queue to the sorted list, and reduce by 1 the
   # in-degree of its dependencies (Kahn 1962)
   while (my $q = shift @indZero) {
	   push(@result, $q);
	   next if (! $children{$q});
	   foreach my $s (split / /, $children{$q}) {
		   $numPred{$s} -= 1;
		   push(@indZero,$s) if ($numPred{$s} == 0);
	   }
   }

   # the resulting list is backwards (dependencies come after the packages they
   # support), and must be reversed.
   @result = reverse @result;

   if (($#missing>-1) and ($type ne "quickdep")) { push (@result, "MISSING", @missing); }
   return @result;
}

sub up_inst {  # returns scalar references to five arrays
  my @requested=@_; my @sortedList; my @targets; my %pdirs;
  my %builtpkg; my %mkcmd; my %addcmd; my %logfile; my %pvars; my $status;
  my %ok; my %not_ok; my %ok_pre; my %ok_post; my @ok_readme=();
  my $PKGMK=$opkg{makecommand}; my $PKGADD=$opkg{addcommand};

  # resolve dependencies unless --nodeps was given,
  # but put glibc{,-32} at the front of the queue
  if ($odepends{inject}==1) {
      @sortedList = deporder("quickdep", @requested);
      @targets=grep { !m/^glibc(|-32)$/ } @sortedList;
      unshift @targets, grep { m/^glibc(|-32)$/ } @sortedList;
  } else {
      @targets = grep { ($V_REPO{$_}) } @requested;
  }

  # omit the ports that appear up to date, unless a rebuild is forced
  if ("$opkg{margs} $opkg{aargs}" !~ m/-f/) {
      @targets = grep {( (! $V_INST{$_}) or ($V_REPO{$_} ne $V_INST{$_}) )} @targets;
  }

  # exempt any locked ports from being updated
  @targets = grep {(! $LOCKED{$_})} @targets;

  # first determine the directories from which pkgmk must be called,
  #   the package that will appear after a successful build,
  #   and where to save the build log.
  my ($COMPRESSION, $PKG_DIR) = parse_pkgmk_conf();
  foreach my $t (@targets) {
    $opkg{$t} = $opkg{margs}; $pvars{'%n'}=$t;
    $opkg{$t} =~ s/-f// unless (grep /^$t$/, @requested);
    $pvars{'%p'} = find_port_by_name($t,1,1,0); $pdirs{$t} = $pvars{'%p'};
    $pvars{'%v'} = $1 if ( $V_REPO{$t} =~ m/(.+)-[0-9]+$/ );
    $pvars{'%r'} = $1 if ( $V_REPO{$t} =~ m/-([0-9]+)$/ );
    $builtpkg{$t} = ($PKG_DIR) ? "$PKG_DIR/$t#$pvars{'%v'}-$pvars{'%r'}.pkg.tar.$COMPRESSION" : "$pvars{'%p'}/$t#$pvars{'%v'}-$pvars{'%r'}.pkg.tar.$COMPRESSION";
    $builtpkg{$t} =~ s/\$name/$t/g; $builtpkg{$t} =~ s/\$\{name\}/$t/g;
    $mkcmd{$t} = "$PKGMK -d $opkg{$t}";
    $addcmd{$t} = "$PKGADD -u $builtpkg{$t}";
    if ($olog{write} eq "enabled") {
      $logfile{$t} = $olog{file};
      $logfile{$t} =~ s/(%n|%v|%r|%p)/$pvars{$1}/g;
      $mkcmd{$t} .= ($olog{mode} eq "append") ? " 2>&1 |/usr/bin/tee -a $logfile{$t}"
      : " 2>&1 |/usr/bin/tee $logfile{$t}";
    }
  }

  if ($opkg{test} eq "yes") {  print("*** prt-auf: test mode\n\n"); 
  print "-- Packages changed\n"; }

  # build each package, unless already installed
  BUILDLOG: foreach my $t (@targets) {
    if ( (-f $builtpkg{$t}) and ($opkg{$t} !~ /-f/) and
	    ((-M $builtpkg{$t}) > (-M "$pdirs{$t}/Pkgfile")) ) {
         $mkcmd{$t} = "echo \"skipped build (package already exists)\"";
    }
    if ($opkg{test} eq "yes") {
	    print("$t\n") if ($mkcmd{$t} !~ /skipped/);
	    $ok{$t}=1;
	    next BUILDLOG;
    }
    if ($mkcmd{$t} ne "") {
      push (@ok_readme, $t) if (-f $pdirs{$t}."/README");
      if ((-f "$pdirs{$t}/pre-install") and ($opkg{runscripts} eq "yes")) {
          system("sh","$pdirs{$t}/pre-install");
          ( $?>>8 == 0 ) ? $ok_pre{$t} = 1 : delete $ok_pre{$t};
      }
      chdir $pdirs{$t}; system("$mkcmd{$t}"); $status=( $?>>8 == 0 );
      if ($logfile{$t}) {
          ( $status ) ? $ok{$t} = 1 : $not_ok{$t} = 1;
      } else {
          (! log_failure($logfile{$t})) ? $ok{$t} = 1 : $not_ok{$t} = 1;
      }
      if ( $ok{$t} ) {
          $addcmd{$t} =~ s/ -u / / if (! $V_INST{$t});
	  system("$addcmd{$t}");
	  if ( $?>>8 == 0 ) { $ok{$t} = 1;
	  } else {
	      $not_ok{$t} = 1; $ok{$t} = 0;
	  }
	  unlink($logfile{$t}) if ( ($ok{$t}==1) and
		  ($logfile{$t}) and ($olog{rm_on_success} eq "yes") );
      }
      if (($ok{$t}) and (-f "$pdirs{$t}/post-install") 
	      and ($opkg{runscripts} eq "yes")) {
	  system("sh","$pdirs{$t}/post-install");
	  ( $?>>8 == 0 ) ? $ok_post{$t}=1 : delete $ok_post{$t};
      }
    }
    last if (($opkg{group} eq "yes") and ($not_ok{$t}) and ($not_ok{$t}==1));
  }

  sub log_failure {
    my $lf=shift; local $/=""; my $failed=0;
    open(FH,$lf) or return 0;
    while (<FH>) { $failed=1 if m/=====> ERROR: /; }
    close(FH); return $failed;
  }

  my @ok = keys %ok;
  my @not_ok = keys %not_ok;
  return \@ok, \%ok_pre, \%ok_post, \@ok_readme, \@not_ok;
}

sub parse_pkgmk_conf {
  my $CONF="/etc/pkgmk.conf"; my $COMPRESSION; my $PKG_DIR="";

  open (CF,$CONF) or return;
  while (<CF>) {
     $COMPRESSION=$1 if m/^PKGMK_COMPRESSION_MODE=(.*)/;
     $PKG_DIR=$1 if m/^PKGMK_PACKAGE_DIR=(.*)/;
  } close (CF);

  if ($COMPRESSION) {
    $COMPRESSION =~ s/#(.*)$//; # remove same-line comments like this one
    $COMPRESSION =~ s/"//g;     # remove double-quotes (thanks jaeger!)
  } else { $COMPRESSION = "gz"; }

  $PKG_DIR =~ s/"//g;
  return $COMPRESSION, $PKG_DIR;
}

sub port_ls {
  my $port=shift; my $pp=find_port_by_name($port,1,1,0);
  return if (! defined $pp);
  opendir (DIR,$pp) or die "Cannot open $pp for directory listing!\n";
  foreach my $l (sort(readdir(DIR))) {
    next if (($l eq ".") or ($l eq ".."));
    print "$l\n";
  } closedir (DIR);
}

sub port_edit {
  my $type=shift; my $port=shift;
  my $file=shift; my $pp=find_port_by_name($port,1,1,0);
  return if (! defined $pp);
  my $EDITOR = ($ENV{EDITOR}) ? $ENV{EDITOR} : "/usr/bin/vi";

  if ($type eq "readme") {
    port_edit("cat",$port,"README") if (-f "$pp/README");
    port_edit("cat",$port,"README.md") if (-f "$pp/README.md");
  }

  if ($type eq "edit") {
    exec ($EDITOR,"$pp/$file") if (($file) and (-f "$pp/$file"));
    exec ($EDITOR,"$pp/Pkgfile") if ((! $file) or (! -f "$pp/$file"));
  }

  if ($type eq "cat") {
    if (($file) and (-f "$pp/$file")) {
      open (PF, "$pp/$file") or die "Could not open $pp/$file.\n";
      while (<PF>) { print $_ ; }
      close (PF);
    } else { 
      open (PF, "$pp/Pkgfile") or die "Could not open $pp/Pkgfile.\n";
      while (<PF>) { print $_ ; }
      close (PF);
    }
  }
}

sub print_help { print <<EOF;
Usage: prt-auf <action> [options] <search term|port name>
where the actions include: 

SEARCH
  search  <expr>     show port names containing <expr>
  dsearch <expr>     show ports containing <expr> in the name or description
  fsearch <pattern>  show ports that provide filenames matching <pattern>

DIFFERENCES / DEPENDENCIES
  quickdiff          show outdated packages on a single line, separated by spaces
  quickdep  <port>   show the dependencies needed by <port>, on a single line
  deptree   <port>   show dependency tree for <port>
  dependent <port>   show installed packages which depend on <port>

INSTALL, UPDATE and REMOVAL
  install [opt] <port1 port2...>    install/update ports in the listed order
  depinst [opt] <port1 port2...>    install/update ports and their dependencies
  remove  [opt] <port1 port2...>    remove ports
  lock          <port1 port2...>    lock each <port> at its current version
  unlock        <port1 port2...>    release the lock on each <port>
  sysup              update all outdated ports, except those that are locked

GENERAL INFORMATION
  list               ports in the active repositories
  listinst           ports currently installed
  listlocked         ports that are locked at their current version
  listorphans        installed ports that no other port claims as a hard dependency
  dup                ports that appear more than once in the active collections
  info    <port>     version, description, dependencies of <port>
  path    <port>     location from which pkgmk would be called to build <port>
  cat <port> <file>  the contents of <port>/<file> on STDOUT
  isinst  <port>     whether port is installed
  current <port>     installed version of port

COMMON OPTIONS
  -v          show version in listing
  -vv         show version and decription in listing
  --path      print path to port if appropriate (search, list, depends)
  --regex     treat search term as a Perl-compatible regular expression
  --cache     use a cache file
  --group     stop the install/update operation if any port fails
  --softdeps  when sorting the targets, consider optional dependencies too
  --nodeps    do not inject or sort by dependencies
  --test      do not actually run pkgmk/pkgadd, just print the affected ports
EOF
  exit;
}