+++ /dev/null
-#!/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";
projects / gentoolkit.git / commitdiff