Initial revision

svn path=/; revision=2

4 files changed, 421 insertions, 0 deletions

diff --git a/trunk/src/epm/AUTHORS b/trunk/src/epm/AUTHORS
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/trunk/src/epm/AUTHORS
diff --git a/trunk/src/epm/ChangeLog b/trunk/src/epm/ChangeLog
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/trunk/src/epm/ChangeLog
diff --git a/trunk/src/epm/README b/trunk/src/epm/README
new file mode 100644
index 0000000..e69de29
--- /dev/null
+++ b/trunk/src/epm/README
diff --git a/trunk/src/epm/epm b/trunk/src/epm/epm
new file mode 100644
index 0000000..408f312
--- /dev/null
+++ b/trunk/src/epm/epm
@@ -0,0 +1,421 @@
+#!/usr/bin/perl -wI.
+# $Id$
+
+use Getopt::Long;
+#use epm;
+
+# Global vars
+my $verbose = 0;
+my $dbpath = '/var/db/pkg';
+my $pkgregex = 
+    '^(.+?)'.					# name
+    '-(\d+(?:\.\d+)*\w*)'.			# version, eg 1.23.4a
+    '((?:(?:_alpha|_beta|_pre|_rc)\d*)?)'.	# special suffix
+    '((?:-r\d+)?)$';				# revision, eg r12
+my $root = '/';
+my %opt = (
+    'dbpath' => \$dbpath,
+    'root' => \$root,
+    'v' => \$verbose,
+);
+my $exitcode = 0;
+
+##############################################
+#
+# UTILITY FUNCTIONS
+# 
+##############################################
+sub verb {
+    print STDERR map "-- $_\n", @_ if $verbose;
+}
+
+sub vverb {
+    print STDERR map "--   $_\n", @_ if $verbose > 1;
+}
+
+##############################################
+#
+# QUERY MODE
+# 
+##############################################
+sub query {
+    verb "query mode";
+    verb "actually Verify mode" if $opt{'V'};
+
+    # Implied -l similar to rpm
+    $opt{'dump'} and $opt{'l'} = 1;
+    $opt{'d'}    and $opt{'l'} = 1;
+    $opt{'c'}    and $opt{'l'} = 1;
+
+    # @dgrps contains a list of all the groups at dbpath
+    # @dpkgs contains a list of all the packages at dbpath/@dgrps
+    # %dpkggrp contains a mapping of pkg=>grp
+    # %dnampkg contains a mapping of nam=>@pkg (libxml=>[libxml-1.8.13])
+    # @pkgs is the list of packages being queried
+    # %dfilepkg is a mapping of filename=>@pkg
+    my (@dgrps, @dpkgs, %dpkggrp, %dnampkg, @pkgs);
+   
+    # Read all groups in the db (except for virtual)
+    opendir D, $dbpath or
+	die "epm: Database not found at $dbpath\n";
+    @dgrps = grep {-d "$dbpath/$_" && !/^\./ && $_ ne 'virtual'} readdir D;
+    closedir D;
+    verb "read ".@dgrps." groups from $dbpath"; vverb @dgrps;
+
+    # Read all pkgs in the db
+    for my $g (@dgrps) {
+	opendir D, "$dbpath/$g" or
+	    die "epm: Error reading directory $dbpath/$g\n";
+	my @dp = grep {-d "$dbpath/$g/$_" && !/^\./} readdir D;
+	verb "read ".@dp." pkgs in group $g"; vverb @dp;
+	@dpkggrp{@dp} = ($g) x @dp;
+	push @dpkgs, @dp;
+    }
+    vverb "package to group associations:";
+    vverb map "  $_ => $dpkggrp{$_}", keys %dpkggrp;
+
+    # Create association of names => pkgs
+    for my $p (@dpkgs) {
+	$p =~ /$pkgregex/o || $dpkggrp{$p} eq 'virtual' ||
+	    die "epm: Could't parse name/version/suffix/rev from $p";
+	# $2, $3, $4 aren't used right now, but they're in the regex
+	# for the sake of completeness.
+	push @{$dnampkg{$1}}, $p;
+    }
+
+    # File-based query
+    if ($opt{'f'}) { 
+	# Search through CONTENTS for elements in ARGV.  Building an
+	# index would be bad because it would be HUGE.
+	for my $a (@ARGV) {
+	    my $found = 0;
+	    # Trim trailing slashes from directories
+	    $a =~ s#/*$##;
+	    # TODO: If it's a relative pathname, then figure out
+	    #       the full pathname
+	    if ($a !~ m#^/#) { }
+	    # TODO: stat the file here so that we can determine later
+	    #       what package the file currently belongs to
+	    for my $p (@dpkgs) {
+		my ($CONTENTS, @files);
+		$CONTENTS = "$dbpath/$dpkggrp{$p}/$p/CONTENTS";
+		unless (-s $CONTENTS) {
+		    verb "skipping empty/nonexistent $CONTENTS";
+		    next;
+		}
+		open F, "<$CONTENTS" or die "epm: Can't open $CONTENTS\n";
+		@files = <F>;
+		close F;
+		# Check this list of files for the current query
+		for my $f (@files) {
+		    $f = (split ' ', $f)[1];
+		    next unless $f eq $a;
+		    $found = 1;
+		    # If not doing -qlf, then print the package name
+                    unless ($opt{'l'}) {
+                        # If doing -qGf, then include the group name
+                        print $opt{'G'} ? "$dpkggrp{$p}/$p\n" : "$p\n";
+                    }
+		    push @pkgs, $p;
+		}
+	    }
+	    unless ($found) {
+		print "file $a is not owned by any package\n";
+		$exitcode = 1;
+	    }
+	}
+	# Clear out ARGV so queries below don't get confused
+	@ARGV = ();
+    }
+
+    # Group-based query
+    # Note that if -qfg specified, then rpm prioritizes -qf over -qg,
+    # so we do too.
+    elsif ($opt{'g'}) {
+	for my $a (@ARGV) {
+            verb "checking for packages in group $a";
+            my @l = grep $dpkggrp{$_} eq $a, @dpkgs;
+            vverb "packages in group $a:";
+            vverb "  ", join "\n  ", @l;
+            unless (@l) {
+                print "group $a does not contain any packages\n";
+                $exitcode = 1;
+            }
+            push @pkgs, @l;
+        }
+	# Clear out ARGV so queries below don't get confused
+	@ARGV = ();
+    }
+
+    # Package-based query (how does this work with emerge?)
+    if ($opt{'p'}) { 
+        die "epm: Sorry, package-based query not yet supported\n";
+    }
+
+    # Query on all packages
+    if ($opt{'a'}) {
+	die "epm: extra arguments given for query of all packages\n" if @ARGV;
+	@pkgs = @dpkgs;
+    } 
+    elsif (@pkgs) {
+	# must have been populated by, for instance, -qf
+    }
+    else {
+	for my $a (@ARGV) {
+	    if ($a =~ /$pkgregex/o) {
+		verb "$a matches pkgregex";
+		vverb "name=$1, version=$2, suffix=$3, revision=$4";
+		push @pkgs, $a;
+		next;
+	    }
+	    if (defined $dnampkg{$a}) {
+		verb "$a found in dnampkg";
+		vverb @{$dnampkg{$a}};
+		push @pkgs, @{$dnampkg{$a}};
+		next;
+	    }
+	    print "package $a is not installed\n";
+	    next;
+	}
+    }
+
+    # Do a file listing of the requested packages
+    if ($opt{'l'}) {
+	for my $p (@pkgs) {
+	    my $CONTENTS = "$dbpath/$dpkggrp{$p}/$p/CONTENTS";
+	    open F, "<$CONTENTS" || die "epm: Can't open $CONTENTS\n";
+	    my @files = <F>;
+	    close F;
+	    # Trim @files if config files requested
+	    if ($opt{'c'}) {
+		# Read in CONFIG_PROTECT from /etc/make.{global,conf}
+		my @CONFIG_PROTECT = split ' ', 
+		    `. /etc/make.globals; 
+		     . /etc/make.conf; 
+		     echo \$CONFIG_PROTECT`;
+		die "CONFIG_PROTECT is empty" unless @CONFIG_PROTECT;
+		my $confprotre = join '|', @CONFIG_PROTECT;
+		@files = grep { 
+			(split ' ', $_)[1] =~ /^($confprotre)/o 
+		    } @files;
+	    }
+	    # Trim @files if doc files requested
+	    if ($opt{'d'}) {
+		# We don't have a variable like CONFIG_PROTECT to work
+		# with, so just fake it...  :-)
+		my $docre = '/usr/share/doc|/usr/share/man';
+		@files = grep { 
+			(split ' ', $_)[1] =~ m/^($docre)/o 
+		    } @files;
+	    }
+	    # If this is a dump query, then print the entire array
+	    if ($opt{'dump'}) {
+		print @files;
+	    } 
+	    # Otherwise do some work so that intermediate directories
+	    # aren't listed
+	    else {
+		for (my $i=0; $i < @files; $i++) {
+		    my ($f1) = $files[$i];
+		    $f1 = (split ' ', $f1)[1];
+		    if ($i < @files-1) {
+			my $f2 = $files[$i+1];
+			$f2 = (split ' ', $f2)[1];
+			vverb "Comparing $f1 to $f2";
+			next if $f2 =~ m#^\Q$f1\E/#;
+		    }
+		    print $f1, "\n";
+		}
+	    }
+	}
+    }
+
+    # If not another type of listing, then simply list the packages
+    if (!$opt{'l'} && !$opt{'f'}) {
+        # If doing -qG, then include the group name
+	print map(($opt{'G'} ? "$dpkggrp{$_}/$_\n" : "$_\n"), @pkgs);
+    }
+}
+
+##############################################
+#
+# ERASE MODE
+# 
+##############################################
+sub erase {
+    verb "erase mode";
+    verb "(testing)" if $opt{'test'};
+
+    # Catch empty command-line
+    die "epm: no packages given for uninstall\n" unless @ARGV;
+
+    # Must be root to erase; rpm just lets permissions slide but I don't
+    if ($> != 0) {
+        print STDERR "Must be root to remove packages from the system\n";
+        $exitcode = 1;
+        return;
+    }
+
+    # Erase everything listed on the command-line.  Give an error
+    # message on bogus names, but continue anyway, a la rpm.  Note
+    # that for epm, we require the group name...
+    for my $a (@ARGV) {
+        unless ($a =~ '/') {
+            print STDERR "error: $a does not contain group/ prefix\n";
+            $exitcode = 1;
+            next;
+        }
+        my $p = $a;
+        $p =~ s,^.*/,,;  # remove the group
+        unless (-f "$dbpath/$a/$p.ebuild") {
+            print STDERR "error: package $a is not installed\n";
+            $exitcode = 1;
+            next;
+        }
+        my @cmd = ('ebuild', "$dbpath/$a/$p.ebuild", 'unmerge');
+        print STDERR join(" ", @cmd), "\n";
+        unless ($opt{'test'}) {
+            system @cmd;
+            die "epm: Fatal error running ebuild; aborting\n" if $?;
+        }
+    }
+}
+
+##############################################
+#
+# MAIN
+#
+##############################################
+
+# Syntax string for errors
+my $syntax = <<EOT;
+EPM version 0.1
+Copyright (C) 2001 - Aron Griffis
+This program may be freely redistributed under the terms of the GNU GPL
+
+Usage:
+   --help                  - print this message
+  *--version               - print the version of rpm being used
+
+   All modes support the following arguments:
+     -v                    - be a little more verbose
+     -vv                   - be incredibly verbose (for debugging)
+
+   -q, --query             - query mode
+      --dbpath <dir>       - use <dir> as the directory for the database
+      --root <dir>         - use <dir> as the top level directory
+      Package specification options:
+        -a, --all          - query all packages
+        -f <file>+         - query package owning <file>
+       *-p <packagefile>+  - query (uninstalled) package <packagefile>
+       *--triggeredby <pkg> - query packages triggered by <pkg>
+       *--whatprovides <cap> - query packages which provide <cap> capability
+       *--whatrequires <cap> - query packages which require <cap> capability
+        -g <group>+ --group <group>+ - query packages in group <group>
+      Information selection options:
+       *-i, --info         - display package information
+        -l                 - display package file list
+        -G, --showgroup    - display group name in output (not in rpm)
+        -d                 - list only documentation files (implies -l)
+        -c                 - list only configuration files (implies -l)
+        --dump             - show all verifiable information for each file
+                             (must be used with -l, -c, or -d)
+       *--provides         - list capabilities package provides
+       *-R, --requires     - list package dependencies
+       *--scripts          - print the various [un]install scripts
+
+    --erase <package>
+    -e <package>           - erase (uninstall) package
+     *--allmatches         - remove all packages which match <package>
+                             (normally an error is generated if <package>
+                             specified multiple packages)
+      --dbpath <dir>       - use <dir> as the directory for the database
+     *--justdb             - update the database, but do not modify the
+                             filesystem
+     *--nodeps             - do not verify package dependencies
+     *--noorder            - do not reorder package installation to satisfy
+                             dependencies
+     *--noscripts          - do not execute any package specific scripts
+     *--notriggers         - don't execute any scripts triggered by this
+                             package
+      --root <dir>         - use <dir> as the top level directory
+      --test               - don't uninstall, but tell what would happen
+
+    -V, -y, --verify       - verify a package installation using the same
+                             package specification options as -q
+      --dbpath <dir>       - use <dir> as the directory for the database
+      --root <dir>         - use <dir> as the top level directory
+      --nodeps             - do not verify package dependencies
+      --nomd5              - do not verify file md5 checksums
+      --nofiles            - do not verify file attributes
+EOT
+
+# Allow bundling of options since rpm does
+Getopt::Long::Configure ("bundling");
+
+# Parse the options on the cmdline.  Put the short versions first in
+# each optionstring so that the hash keys are created using the short
+# versions.  For example, use 'q|query', not 'query|q'.
+my $result = GetOptions(
+    \%opt, 
+    'help',		# help message
+    'v+',		# verbose, more v's for more verbosity
+
+    'q|query', 		# query mode
+	'dbpath=s',	# use <dir> as the directory for the database
+	'root=s',	# use <dir> as the top level directory
+	# Package specification options:
+	'a|all',	# query all packages
+	'f',		# query package owning file(s)
+	'p',		# query (uninstalled) package
+        'g|group',      # query packages in group(s)
+	'whatprovides',	# query packages which provide capability
+	'whatrequires',	# query packages which require capability
+	# Information selection options:
+	'i|info',	# display package information
+	'l',		# display package file list
+	'd',		# list documentation files (implies -l)
+	'c',		# list configuration files (implies -l)
+	'dump',		# show all verifiable information for each file
+	                # (must be used with -l, -c, or -d)
+	'R|requires',	# list package dependencies
+	'scripts',	# print the various [un]install scripts
+        'G|showgroup',  # include group name in output
+
+    'e|erase', 		# erase mode
+        'test',         # don't uninstall, but tell what would happen
+
+    'V|y|verify',       # verify a package installation using the same
+                        # package specification options as -q
+	'nodeps',	# do not verify package dependencies
+	'nomd5',	# do not verify file md5 checksums
+	'nofiles',	# do not verify file attributes
+);
+
+# Handle help message
+if ($opt{'help'}) { print $syntax; exit 0 }
+
+# Determine which mode we're running in; make sure it's valid.
+#  (q)uery
+#  (V)erify
+#  (i)nstall
+#  (U)pgrade
+#  (e)rase
+#  (b)uild
+#  other
+if ((defined $opt{"q"} || 0) +
+    (defined $opt{"V"} || 0) +
+    (defined $opt{"i"} || 0) +
+    (defined $opt{"U"} || 0) + 
+    (defined $opt{"e"} || 0) + 
+    (defined $opt{"b"} || 0) != 1) {
+	die "One mode required, and only one mode allowed\n";
+}
+
+# Query mode
+if ($opt{'q'}) { query(); exit $exitcode }
+if ($opt{'V'}) { query(); exit $exitcode }
+if ($opt{'e'}) { erase(); exit $exitcode }
+
+# Other modes not implemented yet
+die "epm: Sorry, this mode isn't implemented yet.  Check back later!  :-)\n";