head	1.2;
access;
symbols;
locks; strict;
comment	@# @;


1.2
date	2003.01.05.10.39.49;	author mholzer;	state dead;
branches;
next	1.1;

1.1
date	2002.01.24.20.45.57;	author karltk;	state Exp;
branches;
next	;


desc
@@


1.2
log
@delete
@
text
@#!/usr/bin/perl -wI.
# $Id: epm,v 1.1 2002/01/24 20:45:57 karltk Exp $

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";
@


1.1
log
@Initial import of Gentoolkit
@
text
@d2 1
a2 1
# $Id: epm,v 1.5 2001/10/23 14:14:01 agriffis Exp agriffis $
@

