mirror of
https://github.com/fspc/dswim.git
synced 2025-04-04 08:13:24 -04:00
Rearranging things so that perl -I . can easily be used for development.
This commit is contained in:
freesource
parent
686cf50f9c
commit
c013a4564c
263
SWIM/Ag.pm
Normal file
263
SWIM/Ag.pm
Normal file
@ -0,0 +1,263 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Ag;
|
||||
use strict;
|
||||
use SWIM::Global qw(:Info $file_now);
|
||||
use SWIM::DB_Library qw(:Xyz);
|
||||
use SWIM::Info;
|
||||
use SWIM::Pn_print;
|
||||
use SWIM::Deps;
|
||||
use vars qw(@ISA @EXPORT);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(description q_description);
|
||||
|
||||
|
||||
# stuff to query package names, -a, and groups
|
||||
|
||||
# -qi <packages name> Anotherwards that big thing of info...also
|
||||
# -c, -l
|
||||
sub description {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
|
||||
if (!$commands->{"n"}) {
|
||||
dbi(\%commands);
|
||||
}
|
||||
else {
|
||||
ndb(\%commands);
|
||||
}
|
||||
|
||||
|
||||
if (defined $argument) {
|
||||
# We will check for more than two..just in case
|
||||
if ($argument !~ /_/) {
|
||||
if (defined $db{$argument}) {
|
||||
$argument = $db{$argument};
|
||||
}
|
||||
}
|
||||
if ($db{"$argument"}){
|
||||
my $package = $db{"$argument"};
|
||||
print $package;
|
||||
}
|
||||
else {
|
||||
print "package $argument is not installed\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
untie %db;
|
||||
|
||||
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
|
||||
if ($commands->{"c"} && !($commands->{"l"} || $commands->{"d"})) {
|
||||
if (conf(\%commands) ne 0) {
|
||||
print conf(\%commands) if !$commands->{"md5sum"};
|
||||
# here for a reason
|
||||
# if -i because calls from qindexer.
|
||||
if ($commands->{"i"}) {
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
file(\%commands)
|
||||
}
|
||||
}
|
||||
}
|
||||
if (($commands->{"c"} && ($commands->{"l"} || $commands->{"d"})) ||
|
||||
($commands->{"l"} || $commands->{"d"})) {
|
||||
if ($commands->{"c"} && conf(\%commands) ne 0) {
|
||||
print conf(\%commands) if !$commands->{"md5sum"};
|
||||
}
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
file(\%commands);
|
||||
}
|
||||
|
||||
if (!($commands->{"z"} || $commands->{"ftp"} ||
|
||||
$commands->{"remove"} || $commands->{"r"} ||
|
||||
$commands->{"purge"})) {
|
||||
if ($commands->{"x"} || $commands->{"ftp"} || $commands->{"source"} ||
|
||||
$commands->{"source_only"} || $commands->{"remove"} ||
|
||||
$commands->{"r"} || $commands->{"purge"}) {
|
||||
require SWIM::Safex;
|
||||
SWIM::Safex->import(qw(safex));
|
||||
safex(\%commands);
|
||||
}
|
||||
}
|
||||
|
||||
} # end sub description
|
||||
|
||||
# Access Descriptions, and other stuff for known <packages>.
|
||||
# This includes -ql(d)c, -qc or plain -q (just the package name and
|
||||
# version). Anotherwards if -i isn't used this sub is called. And
|
||||
# -ql is handled by file. Mostly, this was designed for calling a single
|
||||
# package name on the command line without a known package title except
|
||||
# when -q is called by itself, but using -T is an exception since this is
|
||||
# useful.
|
||||
sub q_description {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
|
||||
|
||||
if (!$commands->{"n"}) {
|
||||
dbi(\%commands);
|
||||
}
|
||||
else {
|
||||
ndb(\%commands);
|
||||
}
|
||||
|
||||
|
||||
if (defined $argument) {
|
||||
if ($argument !~ /_/) {
|
||||
if (defined $db{$argument}) {
|
||||
$argument = $db{$argument};
|
||||
}
|
||||
if ($commands->{"c"} && $commands->{"d"}) {
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
print "$argument\n" if $commands->{"g"};
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
if (conf(\%commands) ne 0) {
|
||||
print conf(\%commands) if !$commands->{"md5sum"};
|
||||
}
|
||||
# it's nice to print out -d with -c, so this was added.
|
||||
file(\%commands);
|
||||
}
|
||||
elsif ($commands->{"c"}) {
|
||||
# this produces annoying spaces
|
||||
print "$argument\n" if $commands->{"g"} && conf(\%commands) ne 0;
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
if (conf(\%commands) ne 0) {
|
||||
print conf(\%commands) if !$commands->{"md5sum"};
|
||||
if ($commands->{"md5sum"}) {
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
file(\%commands);
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($db{$argument} && !$commands->{"c"}) {
|
||||
print "$argument\n" if $commands->{"T"} ||
|
||||
$commands->{"depends"} || $commands->{"pre_depends"} ||
|
||||
$commands->{"recommends"} || $commands->{"suggests"} ||
|
||||
$commands->{"conflicts"} || $commands->{"replaces"} ||
|
||||
$commands->{"provides"};
|
||||
singular(\%commands);
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
print "\n" if $commands->{"T"} ||
|
||||
$commands->{"depends"} || $commands->{"pre_depends"} ||
|
||||
$commands->{"recommends"} || $commands->{"suggests"} ||
|
||||
$commands->{"conflicts"} || $commands->{"replaces"} ||
|
||||
$commands->{"provides"};
|
||||
}
|
||||
else { print "package $argument is not installed\n"; }
|
||||
}
|
||||
elsif ($argument =~ /_/) {
|
||||
if ($commands->{"c"} && $commands->{"d"}) {
|
||||
print "$argument\n" if $commands->{"g"};
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
print conf(\%commands) if conf(\%commands) ne 0 && !$commands->{"md5sum"};
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
file(\%commands);
|
||||
}
|
||||
elsif ($commands->{"c"}) {
|
||||
my $check = conf(\%commands);
|
||||
print "$argument\n" if $commands->{"g"} && $check ne 0 ||
|
||||
$commands->{"l"};
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
if (conf(\%commands) ne 0) {
|
||||
print conf(\%commands) if !$commands->{"md5sum"};
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
file(\%commands);
|
||||
}
|
||||
elsif (conf(\%commands) == 0) {
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
file(\%commands);
|
||||
}
|
||||
}
|
||||
elsif ($db{$argument} && !$commands->{"c"}) {
|
||||
# watch this
|
||||
##print "$argument\n" if $commands->{"g"};
|
||||
print "$argument\n" if $commands->{"T"} ||
|
||||
$commands->{"depends"} || $commands->{"pre_depends"} ||
|
||||
$commands->{"recommends"} || $commands->{"suggests"} ||
|
||||
$commands->{"conflicts"} || $commands->{"replaces"} ||
|
||||
$commands->{"provides"};
|
||||
singular(\%commands);
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
print "\n" if $commands->{"T"} ||
|
||||
$commands->{"depends"} || $commands->{"pre_depends"} ||
|
||||
$commands->{"recommends"} || $commands->{"suggests"} ||
|
||||
$commands->{"conflicts"} || $commands->{"replaces"} ||
|
||||
$commands->{"provides"};
|
||||
}
|
||||
else { print "package $argument is not installed\n"; }
|
||||
}
|
||||
|
||||
}
|
||||
untie %db;
|
||||
|
||||
if (!defined $file_now &&
|
||||
!($commands->{"z"} || $commands->{"ftp"} ||
|
||||
$commands->{"remove"} || $commands->{"r"} ||
|
||||
$commands->{"purge"})) {
|
||||
if ($commands->{"x"} || $commands->{"ftp"} || $commands->{"source"} ||
|
||||
$commands->{"source_only"} || $commands->{"remove"} ||
|
||||
$commands->{"r"} || $commands->{"purge"}) {
|
||||
require SWIM::Safex;
|
||||
SWIM::Safex->import(qw(safex));
|
||||
safex(\%commands);
|
||||
}
|
||||
}
|
||||
} # end sub q_description
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
1;
|
||||
1219
SWIM/Apt.pm
Normal file
1219
SWIM/Apt.pm
Normal file
File diff suppressed because it is too large
Load Diff
358
SWIM/Compare.pm
Normal file
358
SWIM/Compare.pm
Normal file
@ -0,0 +1,358 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Compare;
|
||||
use strict;
|
||||
use SWIM::Conf qw($dpkg);
|
||||
use SWIM::Library;
|
||||
use vars qw(@ISA @EXPORT %EXPORT_TAGS);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(comparison compare_versions);
|
||||
|
||||
# comparison function and checking function (-v) for not-installed databases
|
||||
|
||||
=pod
|
||||
|
||||
DEVELOPMENTAL
|
||||
|
||||
This uses the comparison method mentioned in the packaging manual. It
|
||||
will look for an epoch *: or the absence, and a revision -* or the
|
||||
absence. First the epoch is compared, then the upstream-version, than
|
||||
the debian-revision. The sub will stop and return a value as soon as
|
||||
a difference is found. A look in the dpkg attic helped out (compare_vnumbers)
|
||||
here, but lib.pl used separate subs, and doesn't appear to check for
|
||||
an epoch separately, ofcourse there may have not been an epoch. This
|
||||
uses the special variable $&, but apparently this isn't as big a waste
|
||||
of resources in later versions of Perl, but there will be some
|
||||
experiments and benchmarks for alternatives in the future for this sub.
|
||||
There some rules built into comparison() to deal with patch to non-patch,
|
||||
more than one hyphen (-). This involves a little transformation.
|
||||
You can verify that this sub is working by doing perl -e '$five =\
|
||||
system "dpkg --compare-versions 10 gt 1.0.17"; print "nop\n" if $five\
|
||||
== 256; print "yes\n" if $five == 0', take a look at the scripts, too.
|
||||
Also, use -v (compare_versions()) when using --initndb or --rebuildndb
|
||||
for a report.
|
||||
|
||||
=cut
|
||||
|
||||
sub comparison {
|
||||
|
||||
# $pversion = version from Packages.gz
|
||||
# $eversion = version from nstatusindex-arch-dist.deb
|
||||
|
||||
my($pversion,$eversion) = @_;
|
||||
my($epoch, $upstream, $revision);
|
||||
my($eepoch, $eupstream, $erevision);
|
||||
my($revisiond,$erevisiond);
|
||||
my $result;
|
||||
|
||||
# If the two versions "eq" one another no reason to go on
|
||||
if ($pversion ne $eversion) {
|
||||
|
||||
# check epoch first, go on if the same
|
||||
#########
|
||||
# EPOCH #
|
||||
#########
|
||||
if ($pversion =~ /:/ || $eversion =~ /:/) {
|
||||
if ($pversion =~ /:/) {
|
||||
($epoch,$upstream) = split(/:/,$pversion,2);
|
||||
}
|
||||
else {
|
||||
$epoch = 0; $upstream = $pversion;
|
||||
}
|
||||
if ($eversion =~ /:/) {
|
||||
($eepoch,$eupstream) = split(/:/,$eversion,2);
|
||||
}
|
||||
else {
|
||||
$eepoch = 0; $eupstream = $eversion;
|
||||
}
|
||||
do {
|
||||
|
||||
$epoch =~ s/^\d*//; my $epochd = $&;
|
||||
$eepoch =~ s/^\d*//; my $eepochd = $&;
|
||||
$result = $epochd <=> $eepochd;
|
||||
return "<" if $result == -1;
|
||||
return ">" if $result == 1;
|
||||
|
||||
} while (length ($epoch) && length ($eepoch));
|
||||
#return length ($a) cmp length ($b);
|
||||
} # end if epoch
|
||||
else {
|
||||
$epoch = 0; $upstream = $pversion;
|
||||
$eepoch = 0; $eupstream = $eversion;
|
||||
}
|
||||
|
||||
# Check the upstream-revision next
|
||||
#####################
|
||||
# UPSTREAM-REVISION #
|
||||
#####################
|
||||
if ($upstream || $eupstream) {
|
||||
# we need to run a little test in case hyphens exists more than once
|
||||
if ($upstream =~ /-/) {
|
||||
my $hyphen = ($upstream =~ tr/-//);
|
||||
if ($hyphen > 1) {
|
||||
$upstream =~ m,(^.*)-(.*$),;
|
||||
$upstream = $1;
|
||||
$revision = $2;
|
||||
}
|
||||
else {
|
||||
($upstream,$revision) = split(/-/,$upstream,2);
|
||||
}
|
||||
}
|
||||
else {
|
||||
# because the absence is considered earlier, and the convention
|
||||
# is to use -1.
|
||||
$revision = 0;
|
||||
}
|
||||
# we need to run a little test in case hyphens exists more than once
|
||||
if ($eupstream =~ /-/) {
|
||||
my $hyphen = ($eupstream =~ tr/-//);
|
||||
if ($hyphen > 1) {
|
||||
$eupstream =~ m,(^.*)-(.*$),;
|
||||
$eupstream = $1;
|
||||
$erevision = $2;
|
||||
}
|
||||
else {
|
||||
($eupstream,$erevision) = split(/-/,$eupstream,2);
|
||||
}
|
||||
}
|
||||
else {
|
||||
# because the absence is considered earlier, and the convention
|
||||
# is to use -1.
|
||||
$erevision = 0;
|
||||
}
|
||||
do {
|
||||
# letters
|
||||
$upstream =~ s/^\D*//; my $upstreamd = $&;
|
||||
$eupstream =~ s/^\D*//; my $eupstreamd = $&;
|
||||
|
||||
# hopefully this handles nasty beta situations
|
||||
if ($upstreamd eq "b" and $eupstreamd eq "." ) {
|
||||
return "<";
|
||||
}
|
||||
elsif ($upstreamd eq "." and $eupstreamd eq "b" ) {
|
||||
return ">";
|
||||
}
|
||||
elsif ($upstreamd eq "beta" and $eupstreamd eq "." ) {
|
||||
return "<";
|
||||
}
|
||||
elsif ($upstreamd eq "." and $eupstreamd eq "beta" ) {
|
||||
return ">";
|
||||
}
|
||||
elsif ($upstreamd eq "." and $eupstreamd eq "-pre-") {
|
||||
return ">";
|
||||
}
|
||||
elsif ($eupstreamd eq "." and $upstreamd eq "-pre-") {
|
||||
return "<";
|
||||
}
|
||||
|
||||
# solves problems when "." is compared to letters, and also a weird
|
||||
# case involving a patched version changing to a non-patched version.
|
||||
if ($upstreamd =~ /\./) {
|
||||
if ($eupstreamd =~ /\w/) {
|
||||
if ($eupstreamd =~ /pl/ && $upstreamd !~ /pl/) {
|
||||
$eupstreamd = "";
|
||||
}
|
||||
elsif ($upstreamd !~ /\.\w{2,10}/) {
|
||||
$eupstreamd = ".";
|
||||
}
|
||||
}
|
||||
elsif ($eupstreamd eq "") {
|
||||
$eupstreamd = ".";
|
||||
}
|
||||
}
|
||||
# the weird -pre situation
|
||||
elsif ($upstreamd =~ /-pre/ || $eupstreamd =~ /-pre/) {
|
||||
$upstreamd = ""; $eupstreamd = "";
|
||||
}
|
||||
|
||||
if ( $eupstreamd =~ /\./) {
|
||||
if ($upstreamd =~ /\w/) {
|
||||
if ($upstreamd =~ /pl/ && $eupstreamd !~ /pl/) {
|
||||
$upstreamd = "";
|
||||
}
|
||||
elsif ($upstreamd !~ /\.\w{2,10}/) {
|
||||
$upstreamd = ".";
|
||||
}
|
||||
}
|
||||
elsif ($upstreamd eq "") {
|
||||
$upstreamd = ".";
|
||||
}
|
||||
}
|
||||
# the weird -pre situation
|
||||
elsif ($upstreamd =~ /-pre/ || $eupstreamd =~ /-pre/) {
|
||||
$upstreamd = ""; $eupstreamd = "";
|
||||
}
|
||||
|
||||
$result = $upstreamd cmp $eupstreamd;
|
||||
return "<" if $result == -1;
|
||||
return ">" if $result == 1;
|
||||
# it's importantant to realize that . & + are being checked for
|
||||
# above. : and - have already been dealt with. cmp seems to deal with
|
||||
# these characters with no problems.
|
||||
|
||||
|
||||
# numbers
|
||||
|
||||
# found a little problem with <=> when number's eq "",
|
||||
# but this doesn't effect cmp.
|
||||
if ($upstream eq "") {
|
||||
if ($eupstream eq ".") {
|
||||
$upstream = ".";
|
||||
}
|
||||
else {
|
||||
$upstream = 0;
|
||||
}
|
||||
}
|
||||
if ( $eupstream eq "") {
|
||||
if ($upstream eq ".") {
|
||||
$eupstream = ".";
|
||||
}
|
||||
else {
|
||||
$eupstream = 0;
|
||||
}
|
||||
}
|
||||
|
||||
$upstream =~ s/^\d*//; $upstreamd = $&;
|
||||
$eupstream =~ s/^\d*//; $eupstreamd = $&;
|
||||
$result = $upstreamd <=> $eupstreamd;
|
||||
return "<" if $result == -1;
|
||||
return ">" if $result == 1;
|
||||
} while (length ($upstream) || length ($eupstream))
|
||||
} # end if upstream
|
||||
else {
|
||||
$revision = 0;
|
||||
$erevision = 0;
|
||||
}
|
||||
|
||||
# Finally, check the revision
|
||||
############
|
||||
# REVISION #
|
||||
############
|
||||
if ($revision || $erevision) {
|
||||
do {
|
||||
# letters
|
||||
$revision =~ s/^\D*//; $revisiond = $&; #$revisiond =~ s/\W/ /g;
|
||||
$erevision =~ s/^\D*//; $erevisiond = $&; #$erevisiond =~ s/\W/ /g;
|
||||
|
||||
# pre in the revision
|
||||
if ($revisiond eq "." and $erevisiond eq "pre") {
|
||||
return "r>";
|
||||
}
|
||||
elsif ($erevisiond eq "." and $revisiond eq "pre") {
|
||||
return "r<";
|
||||
}
|
||||
$result = $revisiond cmp $erevisiond;
|
||||
return "r<" if $result == -1;
|
||||
return "r>" if $result == 1;
|
||||
# it's importantant to realize that . & + are being checked for
|
||||
# above. : and - have already been dealt with. cmp seems to deal with
|
||||
# these characters with no problems.
|
||||
|
||||
# numbers
|
||||
# found a little problem with <=> when number's eq "",
|
||||
# but this doesn't effect cmp.
|
||||
if ($revision eq "") {
|
||||
if ($erevision eq ".") {
|
||||
$revision = ".";
|
||||
}
|
||||
else {
|
||||
$revision = 0;
|
||||
}
|
||||
}
|
||||
if ( $erevision eq "") {
|
||||
if ($revision eq ".") {
|
||||
$erevision = ".";
|
||||
}
|
||||
else {
|
||||
$erevision = 0;
|
||||
}
|
||||
}
|
||||
|
||||
$revision =~ s/^\d*//; $revisiond = $&;
|
||||
$erevision =~ s/^\d*//; $erevisiond = $&;
|
||||
$result = $revisiond <=> $erevisiond;
|
||||
return "r<" if $result == -1;
|
||||
return "r>" if $result == 1;
|
||||
} while (length ($revision) && length ($erevision));
|
||||
} # end if revision
|
||||
|
||||
# still 0? check the remainder..this is just for letters which may have
|
||||
# been mulled over because they looked like words \w.
|
||||
if ($result == 0) {
|
||||
$result = $epoch cmp $eepoch || $upstream cmp $eupstream ||
|
||||
$revision cmp $erevision;
|
||||
return "<" if $result == -1;
|
||||
return ">" if $result == 1;
|
||||
}
|
||||
}
|
||||
|
||||
} # end sub comparison
|
||||
|
||||
|
||||
# This produces a report to make sure that comparison() is up to par, and
|
||||
# is called with -v. It uses dpkg's --compare-versions. The advantage of
|
||||
# not normally running --compare-versions is portability. People using
|
||||
# other distribution's don't need dpkg installed, and people using weird
|
||||
# Oses who can't use dpkg can still explore a virtual installation.
|
||||
sub compare_versions {
|
||||
|
||||
# The test result is put in .version_compare
|
||||
|
||||
# $result = operand (result from comparison)
|
||||
# $virtual = version from Packages.gz
|
||||
# $installed = version from nstatusindex-arch-dist.deb
|
||||
# $name = packagename
|
||||
# $commands = options
|
||||
|
||||
my ($result, $virtual, $installed, $name, $commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my ($cv, $cv_result, $cresult);
|
||||
my $place = finddb(\%commands);
|
||||
|
||||
# usually it will be greater
|
||||
if (defined $dpkg) {
|
||||
$cv = system "$dpkg", "--compare-versions", "$virtual", "gt", "$installed";
|
||||
|
||||
$cv_result = "no" if $cv == 256;
|
||||
$cv_result = "yes" if $cv == 0;
|
||||
#$cresult = "no" if $result =~ m,[r]?<,;
|
||||
#$cresult = "yes" if $result =~ m,[r]?>,;
|
||||
$cresult = "no" if $result eq "<" || $result eq "r<";
|
||||
$cresult = "yes" if $result eq ">" || $result eq "r>";
|
||||
|
||||
open(CV,">>$place/.version_compare")
|
||||
or warn "couldn't create version compare report\n";
|
||||
if ($cresult eq "yes" && $cv_result eq "no") {
|
||||
print CV "$name:\ndpkg - $virtual < $installed\nswim - $virtual > $installed\n\n";
|
||||
}
|
||||
elsif ($cresult eq "no" && $cv_result eq "yes") {
|
||||
print CV "$name:\ndpkg - $virtual > $installed\nswim - $virtual < $installed\n\n";
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
close(CV);
|
||||
}
|
||||
|
||||
} # end sub compare_versions
|
||||
|
||||
|
||||
|
||||
1;
|
||||
673
SWIM/Conf.pm
Normal file
673
SWIM/Conf.pm
Normal file
@ -0,0 +1,673 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Conf;
|
||||
use vars qw(@ISA @EXPORT %EXPORT_TAGS);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
|
||||
@EXPORT = qw($my_number $tmp $architecture $distribution @user_defined_section
|
||||
$default_directory $default_root_directory $permission $dpkg
|
||||
$dpkg_deb $ar $gcc $apt_get $apt_cache $sources @FTP $spl $cat
|
||||
$sort $md5sum $zcat $tar $grep $gzip $fastswim $slowswim $longswim
|
||||
$mount $umount $mke2fs $copy $pager $base $pwd $parent $library
|
||||
$splt $mv $imswim $swim_conf $debug $port $timeout
|
||||
$firewall $passive $apt_sources $HISTORY $alt);
|
||||
%EXPORT_TAGS = (
|
||||
Path => [ qw($tmp $parent $base $library) ],
|
||||
Deb => [ qw($pwd $dpkg_deb $ar $tar $grep $tmp $md5sum $cat $mv) ],
|
||||
Qftp => [ qw($default_root_directory $permission @FTP
|
||||
$default_directory $swim_conf) ],
|
||||
Info => [ qw($parent $base $zcat) ]
|
||||
);
|
||||
|
||||
|
||||
|
||||
#############################
|
||||
# DEFAULT PROGRAM VARIABLES #
|
||||
#############################
|
||||
|
||||
# You can change this to how many lines you would like "swim -qf <>" to
|
||||
# print out, before asking for -t or --total, it will automatically ask
|
||||
# though, if there is more than one package and you used the option -i.
|
||||
# Remember -t can be used with --scripts family members to view the
|
||||
# title of the script file regardless of this setting, and if -t has to be
|
||||
# used, the titles will be displayed, which makes sense.
|
||||
$my_number = 23;
|
||||
|
||||
# Just like a shell, you can keep a history of whatever length you want.
|
||||
$HISTORY = 10;
|
||||
|
||||
# For not-installed:
|
||||
# This part supplies the default value for --arch.
|
||||
#
|
||||
# You can determine the default architecture used when -n is
|
||||
# called or a not-installed database is made. Architectures are always
|
||||
# being added so check with Debian to find a list. There is alpha, arm,
|
||||
# hurd (alternative kernel to linux), i386, m68k, powerpc, sparc. Just use
|
||||
# the arch found after the hyphen in the Contents-(arch) file.
|
||||
$architecture = "i386";
|
||||
|
||||
# For not-installed:
|
||||
# This part supplies the default value for --dists.
|
||||
#
|
||||
# The default distribution can be either stable, unstable, frozen, or
|
||||
# experimental (rare). These represent the state of development that the
|
||||
# packages are under. The unstable distribution can have lot's of changes
|
||||
# within a very short time period, and frozen may or may not be available.
|
||||
$distribution = "unstable";
|
||||
|
||||
|
||||
#For not-installed:
|
||||
#This part supplies the default value for --main, --contrib, --non-free,
|
||||
#and --non-us.
|
||||
|
||||
# Distributions are divided into the sections. These sections are called
|
||||
# distributions in the version 2.4.1.0 packaging manual, because they were at
|
||||
# one time separate distributions, but this has since changed. You can
|
||||
# determine which of these sections (main, non-free, contrib or non-US) to
|
||||
# pull out of the Contents file if you don't want to use --main, --contrib,
|
||||
# --non-free, and --non-us to selectively pick sections. Basically, whatever
|
||||
# you pull out should match the Package(s) file(s) you are targetting, this
|
||||
# program is friendly if you make a mistake, but it's more effecient to pull
|
||||
# out just what you want. If the same package happens to exist in two
|
||||
# different sections, main and non-us for example (which is really a
|
||||
# situation that shouldn't exist, yet it does), you will still be able to
|
||||
# find this package in the non-us group, but its section and locations will be
|
||||
# the one which main recognizes assuming that you use the order in the example
|
||||
# below.
|
||||
|
||||
# Setting it up:
|
||||
# Example: You just want to pull out main and contrib every time you run
|
||||
# --initndb, --rebuildndb, or --ndb.
|
||||
# @user_defined_section = qw(main contrib non-US);
|
||||
# remember "non-US" not "non-us".
|
||||
|
||||
# untill non-US is fixed the second is better
|
||||
#@user_defined_section = qw(main contrib non-free non-US);
|
||||
@user_defined_section = qw(main contrib non-free);
|
||||
|
||||
# Usually, this is
|
||||
$alt = "debian";
|
||||
|
||||
################
|
||||
# DF LOCATION #
|
||||
################
|
||||
|
||||
# A little philosophy:
|
||||
# swim was developed for maximum versatility, so whether you are just
|
||||
# interested in researching, and keeping tabs on the newest packages,
|
||||
# or maintaining a Debian virtual distribution on a non-Debian real
|
||||
# distribution, or you are a using swim for distribution development, swim
|
||||
# provides a way. The default directory (DF - which can also mean
|
||||
# directory/file) keeps track of Contents and Packages files downloaded
|
||||
# using --ftp, and gives the files names specific to the distribution and
|
||||
# architectures they represent. But, you also have the freedom not to use
|
||||
# the default directory in this case swim will still do the renaming and
|
||||
# keeping track of the mtime, but you will have to remember where you put
|
||||
# the files. On the other hand, if you use apt, you won't even have to use
|
||||
# the DF directory for Packages files because you can get the ones specific
|
||||
# to your own systems architecture from apt, but if you want to look at
|
||||
# other architectures you will need to use the DF directory or one of your
|
||||
# own choice.
|
||||
# Naming Convention: Contents = Contents-dist.gz
|
||||
# Packages = Packages-arch-dist-section.gz
|
||||
$default_directory = '/root/.swim';
|
||||
|
||||
|
||||
# The default root directory is the key to easy management of packages
|
||||
# downloaded through --ftp and --file, and provides an easy way to put together
|
||||
# a personalized distribution. Future implementations of swim will provide
|
||||
# a distribution called personal..Packages and Contents files specific to
|
||||
# this distribution will automatically be made. This directory can be a
|
||||
# real ftp site on your computer, or put where ever else you are allowed
|
||||
# to have directories. dists/distribution/section/architecture/subject will be
|
||||
# placed above this directory. No matter what, debian must be the final
|
||||
# directory before dists. Other distributions are placed alongside debian,
|
||||
# like debian-non-US or personal.
|
||||
# Feel free to change the permissions. This directory is above your default_
|
||||
# directory.
|
||||
$default_root_directory = '/pub/debian';
|
||||
|
||||
# Because you may be using a real ftp site, this configuration allows you
|
||||
# to determine what permissions swim will set for directories it creates
|
||||
# above the default root directory.
|
||||
$permission = '0755';
|
||||
|
||||
|
||||
###############
|
||||
# AR or DPKG? #
|
||||
###############
|
||||
|
||||
# NOTE: users set these next two with the $package_tool variable.
|
||||
|
||||
# packaging friends dpkg and dpkg-deb come from the essential and
|
||||
# required dpkg package. ar from the package binutils can also be used (below).
|
||||
# This is the archival program used for deb packages, but binutils is just
|
||||
# a standard non-essential package, and the ar capabilities are built into
|
||||
# dpkg-deb, and it's better not to assume that the standard packages are
|
||||
# even established, yet.
|
||||
$dpkg = ();
|
||||
$dpkg_deb = ();
|
||||
|
||||
|
||||
# If you don't have the dpkg package on your system then you can use ar
|
||||
# from the package binutils. This would be a standard, but not an essential
|
||||
# package in Debian, but this package is also fairly standard amongst all
|
||||
# distributions, and can even be found in the free djgpp for M$ Oses.
|
||||
# Since people who have both dpkg and ar may want to try the ar method,
|
||||
# rather than creating an automatic check, just assign a value to either
|
||||
# ($dpkg & $dpkg_deb) or just $ar.
|
||||
#my $ar = '/usr/bin/ar'; # same for RH
|
||||
$ar = '/usr/bin/ar';
|
||||
|
||||
|
||||
#######
|
||||
# APT #
|
||||
#######
|
||||
|
||||
# NOTE: users set apt-get and apt-cache with the $apt variable
|
||||
|
||||
# If you have apt you are in luck.
|
||||
$apt_get = ();
|
||||
$apt_cache = ();
|
||||
$sources = '/etc/apt/sources.list';
|
||||
$apt_sources = '/var/state/apt/lists';
|
||||
|
||||
#########
|
||||
# PAGER #
|
||||
#########
|
||||
|
||||
# less is a nice pager, unless you like more! There is an option
|
||||
# --nopager or -n. Pager is used for --help and swim called without any
|
||||
# options. more comes from the required package util-linux, whereas
|
||||
# less comes from a standard package called less. In the future there is
|
||||
# a possiblity that a large percentage of swim may use an internal pager.
|
||||
# less, more, or most or...
|
||||
#$ENV{PAGER} = "/usr/bin/less"; # same RH
|
||||
$ENV{PAGER} = "less";
|
||||
$pager = $ENV{PAGER};
|
||||
|
||||
|
||||
|
||||
#################
|
||||
# SWIM PROGRAMS #
|
||||
#################
|
||||
|
||||
# This is replaced by the Makefile.
|
||||
$pre="/usr";
|
||||
|
||||
# This is the hash making program fastswim.
|
||||
$fastswim = "$pre/lib/SWIM/fastswim";
|
||||
|
||||
# imswim in an alternative to fastswim for --lowmem
|
||||
$imswim = "$pre/lib/SWIM/imswim";
|
||||
|
||||
# This is the low memory program slowswim.
|
||||
$slowswim = "$pre/lib/SWIM/slowswim";
|
||||
|
||||
# This is the dir/file making program longswim.
|
||||
$longswim = "$pre/lib/SWIM/longswim";
|
||||
|
||||
############
|
||||
# TEMP DIR #
|
||||
############
|
||||
|
||||
# If you want to set an alternative directory for the temporary files
|
||||
# created when the databases are made, change here. You may want to make
|
||||
# $tmp a RAM disk. See package loadlin for initrd documentation and an
|
||||
# explanation for making such a disk. There is also
|
||||
# /usr/src/kernel-source.version/Documentation. Whether this will speed
|
||||
# things up is a subject of experimentation.
|
||||
$tmp = '/tmp';
|
||||
|
||||
##################
|
||||
# MAIN CONFFILES #
|
||||
##################
|
||||
|
||||
# if configuration files are not kept in /etc change this
|
||||
# and set up the directories by hand.
|
||||
|
||||
$swim_conf = '/etc/swim';
|
||||
|
||||
|
||||
#############
|
||||
# UTILITIES #
|
||||
#############
|
||||
|
||||
|
||||
# This probably never will have to be changed.
|
||||
$pwd = `pwd`;
|
||||
chomp $pwd;
|
||||
|
||||
# If the command split is somewhere else besides /usr/bin change this.
|
||||
# The required package textutils provides this.
|
||||
#my $splt = '/usr/bin/split'; # same RH
|
||||
$splt = 'split';
|
||||
|
||||
# cat comes from the essential and required package textutils.
|
||||
#my $cat = '/bin/cat'; # same RH
|
||||
$cat = 'cat';
|
||||
|
||||
# This command also omes from the required and essential package textutils.
|
||||
#my $sort = '/usr/bin/sort'; # same RH
|
||||
$sort = 'sort';
|
||||
|
||||
# This program uses md5sum from the dpkg package, it can also use md5sum
|
||||
# from the RH package.
|
||||
#my $md5sum = '/usr/bin/md5sum'; # same RH
|
||||
$md5sum = 'md5sum';
|
||||
|
||||
# If you want to view compressed files make sure this is correct.
|
||||
# The required package gzip provides this.
|
||||
#my $zcat = '/bin/zcat'; # same RH
|
||||
$zcat = 'zcat';
|
||||
|
||||
# tar comes from the essential and required package tar.
|
||||
#my $tar = '/bin/tar'; # same RH
|
||||
$tar = 'tar';
|
||||
|
||||
# grep comes from the essential and required package grep. This seems
|
||||
# to require a path.
|
||||
$grep = '/bin/grep'; # same RH
|
||||
|
||||
# gzip comes from the essential and required package gzip.
|
||||
#my $gzip = "/bin/gzip"; # same RH
|
||||
$gzip = "gzip";
|
||||
|
||||
# mount comes from the essential and required package mount.
|
||||
#my $mount = '/bin/mount'; # same RH
|
||||
#my $umount = '/bin/umount'; # same RH
|
||||
$mount = 'mount';
|
||||
$umount = 'umount';
|
||||
|
||||
# If your file system isn't an ext2 filesystem, you may want to change
|
||||
# this. mke2fs comes from the essential and required package e2fsprogs.
|
||||
#my $mke2fs = '/sbin/mke2fs'; # same RH
|
||||
$mke2fs = 'mke2fs';
|
||||
|
||||
# cp and mv from the essential and required package fileutils
|
||||
#my $copy = '/bin/cp'; # same RH
|
||||
$copy = 'cp';
|
||||
$mv = 'mv';
|
||||
|
||||
# Your system definitely has gcc if you have ar. gcc is a standard package
|
||||
# in debian.
|
||||
$gcc = 'gcc';
|
||||
|
||||
|
||||
######
|
||||
# FTP #
|
||||
#######
|
||||
|
||||
# Major mode --ftp and --file automates the download of Contents and Packages
|
||||
# files. Even if you have apt installed, you may still want to download Packages
|
||||
# from alternative architectures, and the Contents file for your own architecture
|
||||
# or other architectures. If you want virtual and/or -ld capabilities you need
|
||||
# the Contents file. You specify a list of ftp or file sites using urls (like
|
||||
# apt). For your system's architecture specify the type deb, for other
|
||||
# architectures specify deb(hyphen)architecture (ex: deb-alpha). Regardless of
|
||||
# whether or not you specify an architecture, deb implies /dist* found under the
|
||||
# base directory specified by the ftp url, except in the case of experimental,
|
||||
# and to a degree non-us. minor mode --ftp, and --file will use the sites in this
|
||||
# configuration as well, on a fifo (first in first out) basis, so choose the
|
||||
# order of sites based on which are closest, most current, as well as fast.
|
||||
|
||||
# IMPORTANT: It is a BIG MISTAKE to use the distributions name (slink,po,etc)
|
||||
# anywhere in the sources list, or in swim's configuration file..in fact swim
|
||||
# won't work properly, not to mention the fact that someday your favorite name
|
||||
# will suddenly disappear. This is because swim thinks in terms of the real
|
||||
# distribution name (stable,unstable,frozen, experimental). The problem goes
|
||||
# like this - slink remains slink, but goes from unstable to frozen to stable.
|
||||
# At first, using the distributions alias may seem appropriate, but the
|
||||
# purpose of swim is to keep tabs on the dists, and not to ignore changes in
|
||||
# the states, this also makes managing swim's databases much easier and
|
||||
# intuitive...more about this later.
|
||||
|
||||
# Fun experiments: Swim uses the naming conventions of apt, but leaves the
|
||||
# Package files compressed in the DF directory. So you can always decompress
|
||||
# the databases and move them to /var/state/apt/lists. This ofcourse assumes
|
||||
# that the appropriate changes to the sources.list reflecting these Packages
|
||||
# (need to be the same architecture as your system) existed before you
|
||||
# update. (author needs to do this experiment :*)
|
||||
|
||||
$ftp1 = "deb ftp://localhost/pub/debian unstable main contrib non-free non-US";
|
||||
$ftp2 = "deb ftp://localhost/pub/debian unstable main contrib non-free";
|
||||
$ftp3 = "deb ftp://localhost/pub/debian project/experimental/";
|
||||
@FTP = ($ftp1,$ftp2,$ftp3);
|
||||
|
||||
# These next variables allow some characteristics of the ftp client
|
||||
# to be altered. See Net::FTP for ways of altering some of these
|
||||
# variables through the environment.
|
||||
|
||||
$firewall = 0;
|
||||
$port = 0;
|
||||
$timeout = 120;
|
||||
$debug = 0;
|
||||
$passive = 0;
|
||||
|
||||
|
||||
########################################
|
||||
# STUFF THAT NEVER NEEDS TO BE CHANGED #
|
||||
########################################
|
||||
|
||||
# You will never need to change this unless for some weird reason all the
|
||||
# files under dpkg are somewhere else (including /info*) , see --dbpath as
|
||||
# an alternative if you decide to access or make the databases somewhere
|
||||
# else. I should point out that this program was designed to work with only
|
||||
# one user .. root.
|
||||
$base = '/var/lib/dpkg';
|
||||
|
||||
# --dbpath takes care of this so don't touch.
|
||||
$parent = '/';
|
||||
$library = '/var/lib/dpkg';
|
||||
|
||||
|
||||
#############################
|
||||
# LOAD CUSTOM CONFIGURATION #
|
||||
#############################
|
||||
|
||||
|
||||
# Here we load in the customized configuration which override the defaults
|
||||
# Might as well use do, let the world learn Perl ... compare this to apt's
|
||||
# configuation file with scopes. Swim's sources.list file (/etc/swim/swimz.list),
|
||||
# will be grabbed at SWIM::Apt and SWIM::Qftp if it exists.
|
||||
|
||||
do "$swim_conf/swimrc";
|
||||
do "$ENV{HOME}/.swim/swimrc";
|
||||
if ((defined $dpkg && !defined $dpkg_deb) ||
|
||||
(!defined $dpkg && defined $dpkg_deb)) {
|
||||
print "swim: need to give both \$dpkg and \$dpkg_deb a value if you want dpkg\n";
|
||||
exit;
|
||||
}
|
||||
if (defined $package_tool) {
|
||||
if ($package_tool =~ /ar/) {
|
||||
$ar = $ar;
|
||||
}
|
||||
else {
|
||||
$dpkg = 'dpkg';
|
||||
$dpkg_deb = 'dpkg-deb';
|
||||
undef $ar;
|
||||
}
|
||||
}
|
||||
if (defined $apt) {
|
||||
$apt_get = 'apt-get';
|
||||
$apt_cache = 'apt-cache';
|
||||
}
|
||||
|
||||
|
||||
###############################
|
||||
# MAKE ANY NEEDED DIRECTORIES #
|
||||
###############################
|
||||
|
||||
# make sure all the appropriate directories are made
|
||||
if (!-d $default_directory) {
|
||||
if (-e $default_directory) {
|
||||
print "swim: can not create default directory because a file exists\n";
|
||||
exit;
|
||||
}
|
||||
my @DRD = split(m,/,,$default_directory);
|
||||
my $placement = "/";
|
||||
for (1 .. $#DRD) {
|
||||
$_ == 1 ? ($placement = "/$DRD[$_]")
|
||||
: ($placement = $placement . "/" . $DRD[$_]);
|
||||
-d $placement or mkdir("$placement",0755);
|
||||
}
|
||||
}
|
||||
|
||||
if (!-d "$default_directory$default_root_directory") {
|
||||
my @DRD = split(m,/,,$default_root_directory);
|
||||
print "swim: debian must be the final directory before dists\n"
|
||||
if $DRD[$#DRD] ne "debian";
|
||||
exit if $DRD[$#DRD] ne "debian";
|
||||
my $placement = "/";
|
||||
for (1 .. $#DRD) {
|
||||
$_ == 1 ? ($placement = "/$DRD[$_]")
|
||||
: ($placement = $placement . "/" . $DRD[$_]);
|
||||
unless (-d "$default_directory$placement") {
|
||||
mkdir("$default_directory$placement",0755)
|
||||
or die "swim: could not create root default directory\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Makefile will make sure these directories exist, unless for some strange
|
||||
# reason you have to change them.
|
||||
|
||||
if (!-d $library) {
|
||||
mkdir($library,0755) or die "Couldn't create default directory\n";
|
||||
}
|
||||
|
||||
if (!-d $base) {
|
||||
mkdir($base,0755) or die "Couldn't create default directory\n";
|
||||
}
|
||||
|
||||
if (!-d $swim_conf) {
|
||||
mkdir($swim_conf,0666) or die "Couldn't create configuration file directory,
|
||||
please make the directories which are needed.\n";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
swimrc - swim configuration file
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
B<swimrc> is the configuartion file for swim allowing many default values
|
||||
to be set so that they do not have to be mentioned on the command line.
|
||||
Swimrc interacts directly with Perl allowing a wide variety of variables
|
||||
found in B<SWIW::Conf> to be altered.
|
||||
|
||||
=cut
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
Values for variable can be altered for B<swim> by assigning different
|
||||
values enclosed in quotes or quoted whitespace (qw()), and ended with a
|
||||
semi-colon.
|
||||
|
||||
$variable = "value";
|
||||
$variable = "qw(value1 value2 ..)";
|
||||
|
||||
=head1 VARIABLES
|
||||
|
||||
This is a list of variables with explanations. The default values for
|
||||
B<swim> are shown.
|
||||
|
||||
=head2 OUTPUT VARIABLE
|
||||
|
||||
$my_number can be changed to how many lines you would like "swim -qf <>"
|
||||
to print out, before the program asks for C<-t> or C<--total>. Exception:
|
||||
If C<-i> is used in the query and there is more than one package then the
|
||||
total will be presented.
|
||||
|
||||
Hint: C<-t> can be used with all the various C<--scripts> family members
|
||||
to view the title of the script file regardless of this variable setting,
|
||||
and if C<-t> has to be used, the titles will be displayed, which makes
|
||||
sense.
|
||||
|
||||
B<$my_number = 23;>
|
||||
|
||||
=head2 HISTORY
|
||||
|
||||
This is a shell-like history kept in relation to searches and the most
|
||||
recent edit when C<--stdin> is used.
|
||||
|
||||
B<$HISTORY = 10;>
|
||||
|
||||
=head2 AR or DPKG?
|
||||
|
||||
Debian packages are ar archives. If you are using a Debian Distribution
|
||||
assign "dpkg" to $package_tool, otherwise assign "ar" to $package_tool.
|
||||
|
||||
B<$package_tool = "/usr/bin/ar";>
|
||||
|
||||
=head2 APT
|
||||
|
||||
B<Swim> does not assign a value for apt. To use C<--apt> and C<-xyz>
|
||||
assign $apt the value "yes".
|
||||
|
||||
Example: B<$apt = "yes";>
|
||||
|
||||
=head2 PAGER
|
||||
|
||||
less is a nice pager, unless you like more! Pager is used for C<--help>
|
||||
and B<swim> called without any options. There is an option C<--nopager> or
|
||||
C<-n>. more comes from the required package util-linux, whereas less
|
||||
comes from a standard package called less. Values: "less", "more", or
|
||||
"most" or...
|
||||
|
||||
B<$ENV{PAGER} = "less";>
|
||||
|
||||
=head2 NOT-INSTALLED VARIABLES
|
||||
|
||||
Assign values for $architecture and/or $distribution to avoid having to
|
||||
use C<--arch> and C<--dists> everytime the not-installed databases are
|
||||
accessed with C<-n> or made or altered.
|
||||
|
||||
Architectures are always being added so check with Debian to find a list.
|
||||
There is I<alpha, arm, hurd-i386 (alternative kernel to linux), i386,
|
||||
m68k, powerpc, sparc>. Just use the arch found after the hyphen in the
|
||||
Contents-(arch) file.
|
||||
|
||||
B<$architecture = "i386";>
|
||||
|
||||
The distribution can be either I<stable, unstable, frozen, or experimental
|
||||
(rare)>. These represent the state of development that the packages are
|
||||
under. The unstable distribution can have lot's of changes within a very
|
||||
short time period, and frozen may or may not be available.
|
||||
|
||||
B<$distribution = "unstable";>
|
||||
|
||||
Distributions are divided into sections. These sections were called
|
||||
distributions in the version 2.4.1.0 packaging manual, because they were
|
||||
at one time separate distributions, but this has since changed.
|
||||
|
||||
You can determine which of the sections I<main, non-free, contrib or
|
||||
non-US> to pull out of the Contents file if you don't want to use
|
||||
C<--main>, C<--contrib>, C<--non-free>, and C<--non-us> to selectively
|
||||
pick the sections.
|
||||
|
||||
For efficiency, you should choose the sections which you will be pulling
|
||||
out of the Packages file(s) being targetted.
|
||||
|
||||
Rule: Use "non-US" not "non-us".
|
||||
|
||||
B<@user_defined_section = qw(main contrib non-free non-US);>
|
||||
|
||||
=head2 DF LOCATION
|
||||
|
||||
A little philosophy: B<swim> was developed for maximum versatility, so
|
||||
whether you are just interested in researching, and keeping tabs on the
|
||||
newest packages, or maintaining a Debian virtual distribution on a
|
||||
non-Debian distribution, or you are a using B<swim> for distribution
|
||||
development, B<swim> provides a way.
|
||||
|
||||
The next two variables determine the location of the DF (default
|
||||
directory/file system)
|
||||
|
||||
The default directory keeps track of Contents and/or Packages databases
|
||||
retrieved with --ftp. The Contents and Packages databases and Release
|
||||
file are give names specific to the distribution and architectures they
|
||||
represent using the naming convention found in apt's sources directory.
|
||||
You also have the freedom not to use the default directory, in which case
|
||||
swim will still do the renaming and keeping track of the mtime, but you
|
||||
will have to remember where you put the files.
|
||||
|
||||
B<$default_directory = '/root/.swim';>
|
||||
|
||||
The default root directory (DRD) is the key to easy management of binary
|
||||
packages, source, dsc, and diff files received from --ftp, and provides an
|
||||
easy way to put together a personalized distribution. This directory can
|
||||
be a real ftp site on your computer, or put wherever else you are
|
||||
allowed to have directories. The DRD is always placed below the value
|
||||
assigned to $default_directory. According to the previous assignment to
|
||||
$default_directory, if the DRD is "/pub/a/debian" then the full path
|
||||
would be "/root/.swim/pub/a/debian".
|
||||
|
||||
Example: When a package is downloaded it will be placed in
|
||||
dists/distribution/section/architecture/subject below the DRD.
|
||||
|
||||
Rule: debian must be the final directory before dists, this is because
|
||||
other distributions are placed alongside debian, like debian-non-US or
|
||||
personal (specialized distribution).
|
||||
|
||||
B<$default_root_directory = '/pub/debian';>
|
||||
|
||||
Because you may be using a real ftp site, this variable allows you to
|
||||
determine what permissions B<swim> will assign for directories it creates
|
||||
below the DRD.
|
||||
|
||||
B<$permission = '0755';>
|
||||
|
||||
=head2 TEMPORARY DIRECTORY
|
||||
|
||||
If you want to set an alternative directory for the temporary files
|
||||
created when the databases are made, change here. You may want to make
|
||||
$tmp a RAM disk. See package loadlin for initrd documentation and an
|
||||
explanation for making such a disk. There is also documentation in
|
||||
/usr/src/kernel-source.version/Documentation. Whether this will speed
|
||||
things up is a subject of experimentation.
|
||||
|
||||
B<$tmp = "/tmp";>
|
||||
|
||||
=head2 FTP
|
||||
|
||||
You can alter the Firewall, Port, Timeout, Debug and Passive
|
||||
characteristics of the ftp client as defined in Net::FTP(3pm) by providing
|
||||
arguments to these variables. All variables but $timeout are set to untrue
|
||||
by default.
|
||||
|
||||
$firewall = 0; (FTP firewall machine name)
|
||||
$port = 0; (defaults to 23)
|
||||
$timeout = 120; (120 seconds)
|
||||
$debug = 0; (1 will turn on STDERR)
|
||||
$passive = 0; (1 will enable)
|
||||
|
||||
=head1 OTHER VARIABLES
|
||||
|
||||
see SWIM::Conf
|
||||
|
||||
=head1 FILES
|
||||
|
||||
/etc/swim/swimrc
|
||||
~/.swim/swimrc
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
swim(8), Net::FTP(3pm)
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Send directly to mttrader@access.mountain.net.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Jonathan D. Rosenbaum <mttrader@access.mountain.net>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
|
||||
Copyright (c) 1999 Jonathan Rosenbaum. All rights reserved. This program
|
||||
is free software; you can redistribute it and/or modify it under the GPL.
|
||||
|
||||
=cut
|
||||
947
SWIM/DB.pm
Normal file
947
SWIM/DB.pm
Normal file
@ -0,0 +1,947 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::DB;
|
||||
use strict;
|
||||
use SWIM::DB_Library qw(:Db);
|
||||
use SWIM::Format;
|
||||
use SWIM::Conf qw(:Path);
|
||||
use SWIM::Global;
|
||||
use vars qw(@ISA @EXPORT_OK);
|
||||
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(db rebuildflatdb);
|
||||
|
||||
|
||||
# --db --rebuildflatdb db() rebuildflatdb()
|
||||
|
||||
# The goal here is to save some time by just updating the database rather
|
||||
# than rebuilding it. Generally, though, swim -i <package> would be the
|
||||
# favorable way of doing this, and ultimately may become the primary way of
|
||||
# setting up the databases after the required packages for this program are
|
||||
# set-up. This is because --db has to check the status file, whereas -i
|
||||
# uses statusindex.db, and grabs package information right from the
|
||||
# package, there are exceptions to this, certain things like the status
|
||||
# will have to be found from the status file or some other method.
|
||||
sub db {
|
||||
|
||||
# Well, we better check for any changes in the status file, before we
|
||||
# attempt anything. This is made easy by the version reference hash created
|
||||
# when --initdb or --rebuilddb is run, and then comparing this to the new
|
||||
# results when --db is run. Only then will we process, add, and remove
|
||||
# packages when we know what is gone, and what is new (whether its a
|
||||
# new package name, or a package with a new version or older version).
|
||||
# The statusindex.deb could be used for version checking, instead the
|
||||
# important status field is compared, so if we have situations like
|
||||
# "deinstall ok config-file" this will be recognized as a CHANGE. The
|
||||
# update takes place so that the status field remain proper.
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
# description stuff
|
||||
my (@description, @ldescription);
|
||||
# my @dpackage; # not needed here
|
||||
|
||||
# does status exist
|
||||
my $the_status;
|
||||
|
||||
# Keep track of changes to the status file
|
||||
my $rootsky = "/.";
|
||||
my @package;
|
||||
my @name;
|
||||
my $status;
|
||||
my @changed_packages;
|
||||
my @gone;
|
||||
my (@GONE, @CHANGED, @NEW);
|
||||
my @before;
|
||||
my %compare;
|
||||
|
||||
# The mys for NEW
|
||||
my $count = 0;
|
||||
# a special one to deal with package[1] version change.
|
||||
my $packv;
|
||||
my (@essential,$priority,$section,$installed_size,$maintainer,$source);
|
||||
my (%group, $group);
|
||||
|
||||
# Keeps a package->version database
|
||||
# to save time over using status
|
||||
my @status;
|
||||
my ($replaces, $provides, $depends, $pre_depends, $recommends, $suggests,
|
||||
$conflicts);
|
||||
my (@conffiles,$line_before,@conf,@complete,@form,@formly);
|
||||
my $format_deb = "$tmp/format.deb";
|
||||
|
||||
dbi(\%commands); ib(\%commands); sb(\%commands);
|
||||
# Check differences now.
|
||||
print "checking for new, changed, and removed packages\n";
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
open(DIFFERENCE,"$parent$library/status");
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
open(DIFFERENCE,"$parent$base/status");
|
||||
}
|
||||
while (<DIFFERENCE>) {
|
||||
# Package name
|
||||
if (/^Package:/i) {
|
||||
@package = split(/: /,$_);
|
||||
chomp $package[1];
|
||||
}
|
||||
elsif (/^Status:/) {
|
||||
chomp;
|
||||
$status = substr($_,8);
|
||||
# a test
|
||||
#if ($status eq "purge ok not-installed") {
|
||||
# if (defined $db{$package[1]}) {
|
||||
# print "$db{$package[1]}\n";
|
||||
# }
|
||||
#}
|
||||
}
|
||||
# hold ok not-installed - may want to change this just to
|
||||
# non-installed.
|
||||
###########
|
||||
# VERSION #
|
||||
###########
|
||||
elsif (/^Version:/ && $status !~ /not-installed/) {
|
||||
my $version = $_; chomp $version;
|
||||
my $ver = m,Version:\s(.*),; my $statusname;
|
||||
if (defined $sb{$package[1]}) {
|
||||
$statusname = (split(/\s/,$sb{$package[1]}))[3];
|
||||
$statusname =~ s/:/ /g;
|
||||
}
|
||||
########
|
||||
# GONE #
|
||||
########
|
||||
if (defined $db{$package[1]}) {
|
||||
push(@gone,"$package[1]_$1");
|
||||
if ("$package[1]_$1" ne $db{$package[1]}) {
|
||||
$compare{$package[1]} = "$package[1]_$1";
|
||||
}
|
||||
# Version remained the same, but status changed
|
||||
# even though $statusname may be undefined..this
|
||||
# routine is only done when it does exist.
|
||||
######
|
||||
# CR #
|
||||
######
|
||||
elsif ("$package[1]_$1" eq $db{$package[1]} &&
|
||||
$statusname ne $status) {
|
||||
push(@changed_packages, "$package[1]");
|
||||
$compare{$package[1]} = "$package[1]_$1";
|
||||
}
|
||||
}
|
||||
#######
|
||||
# NEW #
|
||||
#######
|
||||
elsif (!defined $db{$package[1]}) {
|
||||
push(@NEW,$package[1]);
|
||||
$compare{$package[1]} = "$package[1]_$1";
|
||||
push(@gone,"$package[1]_$1");
|
||||
}
|
||||
}
|
||||
}
|
||||
close(DIFFERENCE);
|
||||
|
||||
# lets find what existed before, ofcourse mistakes in /. better be
|
||||
# taken care of beforehand, because this ignores those here. Some time
|
||||
# may have been saved by using a separate database rather than /., but,
|
||||
# this keeps things clean.
|
||||
if ($ib{$rootsky}){
|
||||
@before = split(/\s/,$ib{$rootsky});
|
||||
my %tracker;
|
||||
grep($tracker{$_}++,@gone);
|
||||
my @goners = grep(!$tracker{$_},@before);
|
||||
foreach (@goners) {
|
||||
m,(^.*)_.*$,;
|
||||
if (!defined $compare{$1}) {
|
||||
push(@GONE,$1);
|
||||
}
|
||||
else {
|
||||
# these will be process like @GONE for original, and @NEW for
|
||||
# new
|
||||
push(@CHANGED,$1);
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
print "swim: missing important database\n"; exit;
|
||||
}
|
||||
|
||||
foreach (@GONE) {
|
||||
print "GONE $_\n";
|
||||
}
|
||||
foreach (@CHANGED) {
|
||||
print "CHANGED $_\n";
|
||||
}
|
||||
foreach (@changed_packages) {
|
||||
push(@CHANGED,$_);
|
||||
print "CHANGED STATUS $_\n";
|
||||
}
|
||||
foreach (@NEW) {
|
||||
print "NEW $_\n";
|
||||
}
|
||||
|
||||
my $new=$#NEW + 1; my $cr=$#changed_packages + 1;
|
||||
my $ch=($#CHANGED + 1) - $cr; my $gon= $#GONE + 1;
|
||||
if ($commands->{"check"}) {
|
||||
print "\n TOTAL\n -----\n";
|
||||
print "NEW $new\n"; print "GONE $gon\n";
|
||||
print "CHANGED $ch\n"; print "CHANGED STATUS $cr\n"; exit;
|
||||
}
|
||||
print "\n TOTAL\n -----\n";
|
||||
print "NEW $new\n"; print "GONE $gon\n";
|
||||
print "CHANGED $ch\n"; print "CHANGED STATUS $cr\n";
|
||||
|
||||
|
||||
@GONE = (@GONE,@CHANGED);
|
||||
@NEW = (@NEW,@CHANGED);
|
||||
|
||||
undef @before; # can use below.
|
||||
untie %db;
|
||||
undef %db;
|
||||
untie %ib;
|
||||
undef %ib;
|
||||
|
||||
# Going to be adding some stuff to nsearchindex.deb and ndirindex.deb
|
||||
# so better remove any compressed versions if they exist
|
||||
if (defined @GONE || defined @NEW) {
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if (-e "$parent$library/searchindex.deb") {
|
||||
unlink("$parent$library/searchindex.deb.gz");
|
||||
unlink("$parent$library/dirindex.deb.gz");
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (-e "$parent$base/searchindex.deb") {
|
||||
unlink("$parent$base/searchindex.deb.gz");
|
||||
unlink("$parent$base/dirindex.deb.gz");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
# Time for some fun stuff
|
||||
# There are three states: GONE - all information about this package
|
||||
# needs to be removed from the databases. NEW - all information about
|
||||
# this package needs to be put in the databases. CHANGED - a
|
||||
# combination of the two previous, information could be cross
|
||||
# referenced and checked for changes, but it's probably no saving of
|
||||
# time, so first remove information from the same package of a
|
||||
# different version, then add the information about the package of the
|
||||
# new version (older or newer)
|
||||
|
||||
#############
|
||||
# #
|
||||
# GONE #
|
||||
# #
|
||||
#############
|
||||
# GONE. (reverse applies to NEW)
|
||||
# For package.deb - Delete description
|
||||
# (packagename_version), packagenameREP, packagenamePRO,
|
||||
# packagenameDEP, packagenamePRE, packagenameREC,
|
||||
# packagenameSUG, packagenameCON, packagenameCONF. delete package ->
|
||||
# version.
|
||||
#
|
||||
# for fileindex.deb -
|
||||
# Find all files and directories associated with the package. Delete
|
||||
# these files (keys). Find all directories where the file
|
||||
# exists..delete package name from value, delete whole key if it is the
|
||||
# only package name.
|
||||
#
|
||||
# for groupindex - delete package name (value) from Section
|
||||
# it belonged to..humm, find section package belongs to in
|
||||
# statusuindex.deb, and delete whole Section key if only one.
|
||||
#
|
||||
# for statusindex.deb -
|
||||
# delete package -> version group.
|
||||
#
|
||||
# for flat files dirindex and searchindex -
|
||||
# the removal of files and/or directories can be put on hold, and
|
||||
# done with an option at a later time, since fileindex.deb remembers
|
||||
# current state, at a later time the old state of the flat files can be
|
||||
# compared to the new state of fileindex, and these files can be
|
||||
# rewritten. This is all o.k. because these extra files or directories
|
||||
# will return undef in search() if the packages don't exist.
|
||||
|
||||
ping(\%commands); # uses $ping for package.deb
|
||||
zing(\%commands); # uses $zing for fileindex.deb
|
||||
ging(\%commands); # uses $ging for groupindex.deb
|
||||
sing(\%commands); # uses $sing for statusindex.deb
|
||||
|
||||
$| = 1; my $x = 1;
|
||||
foreach (@GONE) {
|
||||
print "G|C|CS $x $_.list\r";
|
||||
$x++;
|
||||
#first delete keys from package.deb
|
||||
# If I kept this the name_version would be remembered.
|
||||
$ping->del($_);
|
||||
my $orig_argument = $_;
|
||||
my $packname_version = (split(/\s/,$sb{$orig_argument}))[0];
|
||||
$packname_version =~ s,\+,\\\+,g;
|
||||
$argument = "$_";
|
||||
ver(\%commands);
|
||||
$ping->del($argument);
|
||||
my $conf = $argument . "CONF";
|
||||
$ping->del($conf);
|
||||
$conf = $argument . "REP";
|
||||
$ping->del($conf);
|
||||
$conf = $argument . "PRO";
|
||||
$ping->del($conf);
|
||||
$conf = $argument . "DEP";
|
||||
$ping->del($conf);
|
||||
$conf = $argument . "PRE";
|
||||
$ping->del($conf);
|
||||
$conf = $argument . "REC";
|
||||
$ping->del($conf);
|
||||
$conf = $argument . "SUG";
|
||||
$ping->del($conf);
|
||||
$conf = $argument . "CON";
|
||||
$ping->del($conf);
|
||||
untie $ping;
|
||||
|
||||
# next let's go into fileindex.deb and hunt down all directories and
|
||||
# files associated with this package. It would be kind of nice to use
|
||||
# package_name.list, but it's probably more realistic not to depend on
|
||||
# the existence of these file..unless a backup is made. Now if -i is used
|
||||
# this would be a simple matter, but in this case things are different.
|
||||
# A database to accomplish this wasn't realistic, so the backup
|
||||
# files for *.list are in ./info/backup/*.list.bk. We will also have to
|
||||
# deal with those rare cases that forget /. (smail 2.0v). We should remove
|
||||
# this file as well as the packagename-conf.md5sums file below.
|
||||
my $file = "$parent$base/info/backup/$_.list.bk";
|
||||
my $md5sum_file = "$parent$base/info/$_-conf.md5sums";
|
||||
open(LIST,"$file");
|
||||
while (<LIST>) {
|
||||
chomp;
|
||||
if (defined $ib{$_}) {
|
||||
my $status = ($ib{$_} =~ s,$packname_version ,,);
|
||||
if ($status eq "") {
|
||||
$status = ($ib{$_} =~ s, $packname_version,,);
|
||||
if ($status eq "") {
|
||||
$ib{$_} =~ s,$packname_version,,;
|
||||
}
|
||||
}
|
||||
if ($ib{$_} eq "") {
|
||||
$zing->del($_);
|
||||
}
|
||||
} # if defined
|
||||
}
|
||||
close(LIST);
|
||||
unlink("$file");
|
||||
|
||||
#######################
|
||||
# deinstall situation #
|
||||
#######################
|
||||
my $yit = (split(/\s/,$sb{$orig_argument}))[3];
|
||||
if ($yit eq "deinstall:ok:config-files" ||
|
||||
$yit eq "purge:ok:config-files") {
|
||||
if (defined $ib{"/."}) {
|
||||
my $status = ($ib{"/."} =~ s,$packname_version ,,);
|
||||
if ($status eq "") {
|
||||
$status = ($ib{"/."} =~ s, $packname_version,,);
|
||||
if ($status eq "") {
|
||||
$ib{"/."} =~ s,$packname_version,,;
|
||||
}
|
||||
}
|
||||
if ($ib{"/."} eq "") {
|
||||
$zing->del($_);
|
||||
}
|
||||
} # if defined
|
||||
} # deinstall situation
|
||||
|
||||
if (-e $md5sum_file) {
|
||||
unlink("$md5sum_file");
|
||||
}
|
||||
|
||||
# remove from the group, and if only one remove the group.
|
||||
# Let's first find out which group this monster belongs to.
|
||||
if (defined $sb{$orig_argument}) {
|
||||
(my $oa = $orig_argument) =~ s,\+,\\\+,g;
|
||||
my($section) = (split(/\s/,$sb{$orig_argument}))[1];
|
||||
if (defined $gb{$section}) {
|
||||
my $status = ($gb{$section} =~ s,$oa ,,);
|
||||
if ($status eq "") {
|
||||
$status = ($gb{$section} =~ s, $oa,,);
|
||||
if ($status eq "") {
|
||||
$gb{$section} =~ s,$oa,,;
|
||||
}
|
||||
}
|
||||
if ($gb{$section} eq "") {
|
||||
$ging->del($section);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Now ditch the package->version group in statusindex.deb
|
||||
$sing->del($orig_argument);
|
||||
untie $sing;
|
||||
|
||||
} # end foreach OLD
|
||||
|
||||
print "\n" if $#GONE != -1 && $#NEW == -1;
|
||||
|
||||
#############
|
||||
# #
|
||||
# NEW #
|
||||
# #
|
||||
#############
|
||||
if (-e "$parent$base/status" && -e "$parent$base/info") {
|
||||
$the_status = "$parent$base/status";
|
||||
}
|
||||
else {
|
||||
print "swim: crucial file(s)/directories are missing in $parent\n";
|
||||
exit;
|
||||
}
|
||||
my %exacts;
|
||||
my $goon;
|
||||
print "\n" if $#NEW != -1; $x = 1;
|
||||
foreach (@NEW) {
|
||||
$exacts{$_} = "yes";
|
||||
}
|
||||
# first let's find the fields to put into packages.deb
|
||||
# We'll have to go through the status file again, something we
|
||||
# wouldn't have had to do with swim -i. As it turns out, a good
|
||||
# percentage of the information can be processed into the database
|
||||
# while going through status.
|
||||
open(PRETTY, ">$format_deb");
|
||||
open(AVAIL, "$the_status");
|
||||
while (<AVAIL>) {
|
||||
# here's the difference with database(), we just find the packages
|
||||
# which belong to the hash %exacts
|
||||
# Package name
|
||||
if (/^Package:|^PACKAGE:/) {
|
||||
@package = split(/: /,$_);
|
||||
chomp $package[1];
|
||||
if (defined $exacts{$package[1]}) {
|
||||
print "N|C|CS $x\r"; $x++;
|
||||
$goon = "yes";
|
||||
}
|
||||
else {
|
||||
$goon = "no";
|
||||
undef @package;
|
||||
next;
|
||||
}
|
||||
}
|
||||
elsif ($goon eq "no") {
|
||||
next;
|
||||
}
|
||||
elsif (/^Status:/) {
|
||||
$status = $_;
|
||||
}
|
||||
elsif (/^Essential/) {
|
||||
@essential = split(/: /,$_);
|
||||
}
|
||||
# missing priority and section will be dealt with below
|
||||
elsif (/^Priority:/) {
|
||||
$priority = $_;
|
||||
}
|
||||
elsif (/^Section:/) {
|
||||
$section = $_;
|
||||
# make the hash for the groupindex.deb
|
||||
$group = substr($section,9);
|
||||
chomp $group;
|
||||
# we will put not-installed in their own group for reference
|
||||
if ($status !~ /not-installed/) {
|
||||
if (!defined $gb{$group}) {
|
||||
$ging->put($group,$package[1]);
|
||||
}
|
||||
else {
|
||||
my $change_group = "$gb{$group} $package[1]";
|
||||
$ging->del($group);
|
||||
$ging->put($group,"$change_group");
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif (/^Installed-Size:/) {
|
||||
$installed_size = $_;
|
||||
}
|
||||
elsif (/^Maintainer:/) {
|
||||
$maintainer = $_;
|
||||
}
|
||||
elsif (/^Source:/) {
|
||||
$source = $_;
|
||||
}
|
||||
# hold ok not-installed - may want to change this just to
|
||||
# non-installed.
|
||||
elsif (/^Version:/ && $status !~ /not-installed/) {
|
||||
my $version = $_;
|
||||
chomp $version;
|
||||
###########
|
||||
# SECTION #
|
||||
###########
|
||||
if (defined $section) {
|
||||
chomp $section;
|
||||
}
|
||||
else {
|
||||
nsb(\%commands);
|
||||
if (defined $nsb{$package[1]}) {
|
||||
my ($nvname,$ngname,$npriorname) =
|
||||
split(/\s/,"$nsb{$package[1]}",3);
|
||||
$group = $ngname;
|
||||
}
|
||||
else {
|
||||
$group = "unavailable";
|
||||
}
|
||||
}
|
||||
$col1 = "Package: $package[1]";
|
||||
$col2 = $status;
|
||||
write PRETTY;
|
||||
$col1 = $version;
|
||||
my $ver = m,Version:\s(.*),;
|
||||
# This creates a name -> version index in package.deb,
|
||||
# and the statusindex.deb database which will serve to
|
||||
# determine if the status has changed when --db or -i is
|
||||
# run.
|
||||
$packv = "$package[1]_$1";
|
||||
$ping->put($package[1],$packv);
|
||||
my ($priory,$statusy);
|
||||
############
|
||||
# PRIORITY #
|
||||
############
|
||||
if (defined $priority) {
|
||||
$priory = substr($priority,10);
|
||||
}
|
||||
else {
|
||||
nsb(\%commands);
|
||||
if (defined $nsb{$package[1]}) {
|
||||
my ($nvname,$ngname,$npriorname) =
|
||||
split(/\s/,"$nsb{$package[1]}",3);
|
||||
$priory = $npriorname;
|
||||
}
|
||||
else {
|
||||
$priory = "unavailable";
|
||||
}
|
||||
}
|
||||
chomp $priory;
|
||||
$statusy = substr($status,8);
|
||||
chomp $statusy;
|
||||
$statusy =~ s/\s/:/g;
|
||||
my $thimk = "$packv $group $priory $statusy";
|
||||
$sing->put($package[1],$thimk);
|
||||
$package[1] = "$packv";
|
||||
if(defined($essential[1])) {
|
||||
$col2 = "Essential: $essential[1]";
|
||||
@essential = ();
|
||||
}
|
||||
else {
|
||||
$col2 = "Essential: no\n";
|
||||
}
|
||||
write PRETTY;
|
||||
######################
|
||||
# SECTION & PRIORITY #
|
||||
######################
|
||||
if (defined $section) {
|
||||
$col1 = $section;
|
||||
}
|
||||
else {
|
||||
nsb(\%commands);
|
||||
$package[1] =~ m,(.*)_.*,;
|
||||
my $packthing = $1;
|
||||
if (defined $nsb{$packthing}) {
|
||||
my ($nvname,$ngname,$npriorname) =
|
||||
split(/\s/,"$nsb{$packthing}",3);
|
||||
$col1 = "Section: $ngname";
|
||||
# we can put it in now, no deletion needed
|
||||
if (!defined $gb{$group}) {
|
||||
$ging->put($group,$packthing);
|
||||
}
|
||||
else {
|
||||
my $change_group = "$gb{$group} $packthing";
|
||||
$ging->del($group);
|
||||
$ging->put($group,"$change_group");
|
||||
}
|
||||
}
|
||||
else {
|
||||
$col1 = "Section: unavailable";
|
||||
}
|
||||
}
|
||||
if (defined $priority) {
|
||||
$col2 = $priority;
|
||||
}
|
||||
else {
|
||||
nsb(\%commands);
|
||||
$package[1] =~ m,(.*)_.*,;
|
||||
my $packthing = $1;
|
||||
if (defined $nsb{$packthing}) {
|
||||
my ($nvname,$ngname,$npriorname) =
|
||||
split(/\s/,"$nsb{$packthing}",3);
|
||||
$col2 = "Section: $npriorname";
|
||||
}
|
||||
else {
|
||||
$col2 = "Priority: unavailable\n";
|
||||
}
|
||||
}
|
||||
write PRETTY;
|
||||
#my $cool = $installed_size . $maintainer;
|
||||
#print PRETTY $cool;
|
||||
$col1 = $installed_size;
|
||||
if (defined $source) {
|
||||
$col2 = $source;
|
||||
}
|
||||
else {
|
||||
$col2 = "";
|
||||
}
|
||||
write PRETTY;
|
||||
undef $source;
|
||||
print PRETTY $maintainer
|
||||
}
|
||||
|
||||
# This stuff will be available with seperate query flags or All
|
||||
elsif (/^Replaces:/) {
|
||||
$replaces = $_;
|
||||
if (defined($replaces)) {
|
||||
$ping->put("$package[1]REP",$replaces);
|
||||
}
|
||||
}
|
||||
elsif (/^Provides:/) {
|
||||
$provides = $_;
|
||||
if (defined($provides)) {
|
||||
$ping->put("$package[1]PRO",$provides);
|
||||
}
|
||||
}
|
||||
elsif (/^Depends:/) {
|
||||
$depends = $_;
|
||||
if (defined($depends)) {
|
||||
$ping->put("$package[1]DEP",$depends);
|
||||
}
|
||||
}
|
||||
elsif (/^Pre-Depends:/) {
|
||||
$pre_depends = $_;
|
||||
if (defined($pre_depends)) {
|
||||
$ping->put("$package[1]PRE",$pre_depends);
|
||||
}
|
||||
}
|
||||
elsif (/^Recommends:/) {
|
||||
$recommends = $_;
|
||||
if (defined($recommends)) {
|
||||
$ping->put("$package[1]REC",$recommends);
|
||||
}
|
||||
}
|
||||
elsif (/^Suggests:/) {
|
||||
$suggests = $_;
|
||||
if (defined($suggests)) {
|
||||
$ping->put("$package[1]SUG",$suggests);
|
||||
}
|
||||
}
|
||||
elsif (/^Conflicts:/) {
|
||||
$conflicts = $_;
|
||||
if (defined($conflicts)) {
|
||||
$ping->put("$package[1]CON",$conflicts);
|
||||
}
|
||||
}
|
||||
# Gather the Configuration Files, Description comes after.
|
||||
# Available with a single flag.
|
||||
elsif (/^Conffiles:/) {
|
||||
my $line = <AVAIL>;
|
||||
while ($line !~ /^Description:/) {
|
||||
push(@conffiles,$line);
|
||||
$line = <AVAIL>;
|
||||
if ($line =~ /^Description/) {
|
||||
$line_before = $line;
|
||||
# put conffiles into one variable
|
||||
if (defined $package[1]) {
|
||||
}
|
||||
my ($c, $cool);
|
||||
if ($#conffiles != 0) {
|
||||
for ($c = $#conffiles; $c >= 0; $c--) {
|
||||
if ($c > 0) {
|
||||
$cool = $conffiles[$c-1] .= $conffiles[$c];
|
||||
}
|
||||
} #end for
|
||||
}
|
||||
else {
|
||||
$cool = $conffiles[0];
|
||||
}
|
||||
@conffiles = ();
|
||||
$ping->put("$package[1]CONF",$cool);
|
||||
} #if ($line =~ /^Desc
|
||||
} # while ($line ! /^Desc
|
||||
} # elsif (/^Conffiles
|
||||
untie %nsb;
|
||||
|
||||
# Only interested in available packages..so this is fine.
|
||||
# To be combined with first fields.
|
||||
if (/Description:|^\s\w*|^\s\.\w*/ ||
|
||||
defined($line_before) =~ /^Description/){
|
||||
my $many_lines;
|
||||
if (defined($line_before)) {
|
||||
push(@ldescription, $line_before);
|
||||
push(@ldescription, $_);
|
||||
$line_before = ();
|
||||
}
|
||||
else {
|
||||
$many_lines = $_;
|
||||
}
|
||||
if ($_ !~ /^\n$/) {
|
||||
$count++;
|
||||
if ($count == 1) {
|
||||
if (defined $package[1]) {
|
||||
#chomp $package[1];
|
||||
#push(@dpackage,$package[1]);
|
||||
push(@description,$package[1]);
|
||||
}
|
||||
}
|
||||
if (defined($many_lines)) {
|
||||
push(@ldescription,$many_lines);
|
||||
}
|
||||
} # end if ($_ !~ /^\n$/
|
||||
else {
|
||||
$count = 0;
|
||||
# let's put each description into one scalar
|
||||
my ($c, $cool);
|
||||
if ($#ldescription != 0) {
|
||||
for ($c = $#ldescription; $c >= 0; $c--) {
|
||||
if ($c > 0) {
|
||||
$cool = $ldescription[$c-1] .= $ldescription[$c];
|
||||
}
|
||||
} #end for
|
||||
} # end if ($#ld
|
||||
else {
|
||||
$cool = $ldescription[0];
|
||||
}
|
||||
if (defined $cool) {
|
||||
push(@description,$cool);
|
||||
}
|
||||
@ldescription = ();
|
||||
} # end else
|
||||
$line_before = ();
|
||||
}
|
||||
untie $ping;
|
||||
untie $ging;
|
||||
untie $sing;
|
||||
} # end while (<AVAIL>)
|
||||
close(PRETTY);
|
||||
|
||||
|
||||
# Let's put together the description with the rest of its fields.
|
||||
open(FIELDS,"$format_deb");
|
||||
while (<FIELDS>) {
|
||||
push(@form,$_);
|
||||
}
|
||||
close(FIELDS);
|
||||
|
||||
foreach (@form) {
|
||||
push(@formly,$_);
|
||||
my ($cool);
|
||||
$count++;
|
||||
if ($count == 5) {
|
||||
my ($c, $cool);
|
||||
if ($#formly != 0) {
|
||||
for ($c = $#formly; $c >= 0; $c--) {
|
||||
if ($c > 0) {
|
||||
$cool = $formly[$c-1] .= $formly[$c];
|
||||
}
|
||||
} #end for
|
||||
} # end if ($#ld
|
||||
else {
|
||||
$cool = $formly[0];
|
||||
}
|
||||
push(@complete,$cool);
|
||||
@formly = ();
|
||||
$count = 0;
|
||||
}
|
||||
}
|
||||
|
||||
my $name_version;
|
||||
foreach (@description) {
|
||||
if ($count == 1) {
|
||||
# -i
|
||||
my $lingo = shift(@complete);
|
||||
$lingo = $lingo . $_;
|
||||
#push(@Tdescription, $lingo);
|
||||
$ping->put($name_version,$lingo);
|
||||
$lingo = ();
|
||||
$count = 1;
|
||||
}
|
||||
else {
|
||||
# packagename_version
|
||||
#push(@Tdescription, $_);
|
||||
$name_version = $_;
|
||||
$count = 0;
|
||||
}
|
||||
$count++;
|
||||
untie $ping;
|
||||
}
|
||||
undef $ping;
|
||||
|
||||
unlink($format_deb);
|
||||
|
||||
# Now time to do some file/dir stuff. A backup of *list needs to be
|
||||
# made, might as well use this. There is a possibility this can be
|
||||
# used instead of fastswim for initial fileindex.deb.
|
||||
my $package_name;
|
||||
if (!-d "$parent$base/info/backup") {
|
||||
mkdir("$parent$base/info/backup",0666);
|
||||
}
|
||||
print "\n" if $#NEW != -1; $x = 1;
|
||||
|
||||
foreach $package_name (@NEW) {
|
||||
open(FILENAME,"$parent$base/info/$package_name.list");
|
||||
open(CP,">$parent$base/info/backup/$package_name.list.bk");
|
||||
while (<FILENAME>) {
|
||||
print CP $_;
|
||||
}
|
||||
close(FILENAME);
|
||||
close(CP);
|
||||
|
||||
my $file = "$parent$base/info/backup/$package_name.list.bk";
|
||||
print "#$x"; print " N|C $package_name.list \r";
|
||||
$x++;
|
||||
open(LIST,"$file");
|
||||
while (<LIST>) {
|
||||
chomp;
|
||||
|
||||
# Better add the new stuff to the flat files first
|
||||
if (!defined $ib{$_}) {
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
open(SEARCHINDEX,">>$parent$library/searchindex.deb");
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
open(SEARCHINDEX,">>$parent$base/searchindex.deb");
|
||||
}
|
||||
if (!-d) {
|
||||
print SEARCHINDEX "$_\n";
|
||||
}
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
open(DIRINDEX,">>$parent$library/dirindex.deb");
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
open(DIRINDEX,">>$parent$base/dirindex.deb");
|
||||
}
|
||||
if (-d) {
|
||||
print DIRINDEX "$_\n";
|
||||
}
|
||||
} # !defined
|
||||
|
||||
# If the directory already exists we can just append
|
||||
# to the end of the value
|
||||
if (defined $ib{$_}) {
|
||||
dbi(\%commands);
|
||||
my $cvalue = $ib{$_} . " $db{$package_name}";
|
||||
# put overwrites by default!
|
||||
$zing->put($_,$cvalue);
|
||||
} # if defined
|
||||
else {
|
||||
dbi(\%commands);
|
||||
$zing->put($_,$db{$package_name});
|
||||
}
|
||||
untie %db;
|
||||
untie $zing;
|
||||
}
|
||||
close(LIST);
|
||||
close(SEARCHINDEX);
|
||||
close(DIRINDEX);
|
||||
|
||||
my $zit; my ($nit,$yit) = (split(/\s/,$sb{$package_name}))[0,3];
|
||||
if ($yit eq "deinstall:ok:config-files" ||
|
||||
$yit eq "purge:ok:config-files") {
|
||||
($zit = $nit) =~ s,\+,\\\+,;
|
||||
if ($ib{"/."} !~ m,$zit,) {
|
||||
$ib{"/."} = $ib{"/."} . " $zit";
|
||||
}
|
||||
}
|
||||
|
||||
} # end foreach NEW
|
||||
print "\n" if $#NEW != -1;
|
||||
|
||||
} # end sub db
|
||||
|
||||
# Generally, it's unecessary to rebuild the flat databases unless major
|
||||
# changes have occurred to a person's installation, and the database has
|
||||
# become very repetitive, or a file has changed into a directory. This
|
||||
# function has also been tried by tieing the flat file to an array, but
|
||||
# there doesn't seem to be that much of a speed advantage unless ib()
|
||||
# happens to be in memory, but more experimentation will be tried in the
|
||||
# future.
|
||||
sub rebuildflatdb {
|
||||
|
||||
my($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
ib(\%commands);
|
||||
|
||||
print scalar(localtime), "\n";
|
||||
|
||||
my $file;
|
||||
my $dir;
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
!($commands->{"dbpath"} && $commands->{"root"})) {
|
||||
if (-e "$parent$library/searchindex.deb") {
|
||||
$dir = "$parent$library/dirindex.deb";
|
||||
$file = "$parent$library/searchindex.deb";
|
||||
unlink($file);
|
||||
unlink("$file.gz") if -e "$file.gz";
|
||||
unlink($dir);
|
||||
unlink("$dir.gz") if -e "$dir.gz";
|
||||
}
|
||||
else {
|
||||
print "swim: operation only implemented for installed system\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (-e "$parent$base/searchindex.deb") {
|
||||
$file = "$parent$base/searchindex.deb";
|
||||
$dir = "$parent$base/dirindex.deb";
|
||||
unlink($file);
|
||||
unlink("$file.gz") if -e "$file.gz";
|
||||
unlink($dir);
|
||||
unlink("$dir.gz") if -e "$dir.gz";
|
||||
}
|
||||
else {
|
||||
print "swim: operation only implemented for installed system\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
open(DIR,">$dir");
|
||||
open(FILE,">$file");
|
||||
# We need to reconstruct long.debian & DEBIAN*, but can't take into account
|
||||
# weirdisms with the database - NEW packages which aren't NEW.
|
||||
foreach (keys %ib) {
|
||||
if (defined $ib{$_}) {
|
||||
my $filedir = $_;
|
||||
my $package = $ib{$_};
|
||||
#$package =~ s/\s/\n/g;
|
||||
my @the_amount = split(/\s/, $package);
|
||||
if ($#the_amount > 0) {
|
||||
print DIR "$filedir\n";
|
||||
}
|
||||
elsif ($#the_amount == 0) {
|
||||
print FILE "$filedir\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
untie %ib;
|
||||
print scalar(localtime), "\n";
|
||||
|
||||
} # end sub rebuildflatdb
|
||||
|
||||
|
||||
|
||||
1;
|
||||
648
SWIM/DB_Init.pm
Normal file
648
SWIM/DB_Init.pm
Normal file
@ -0,0 +1,648 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::DB_Init;
|
||||
use strict;
|
||||
use SWIM::Conf qw(:Path $fastswim $imswim $slowswim $sort);
|
||||
#use SWIM::Global;
|
||||
use SWIM::Format;
|
||||
use SWIM::MD;
|
||||
use DB_File;
|
||||
use vars qw(@ISA @EXPORT);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(database);
|
||||
|
||||
|
||||
# database() md() --initdb --rebuilddb
|
||||
|
||||
# Time to get serious and make a database
|
||||
sub database {
|
||||
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
print scalar(localtime), "\n";
|
||||
|
||||
#my whatever that is
|
||||
my @dpackage; # passes name_version to md()
|
||||
my @Tdescription;
|
||||
my @description;
|
||||
my @ldescription;
|
||||
my @package;
|
||||
my %db;
|
||||
my @name;
|
||||
my $count = 0;
|
||||
|
||||
my $the_status;
|
||||
|
||||
my $status;
|
||||
my @essential;
|
||||
my $priority;
|
||||
my $section;
|
||||
my $installed_size;
|
||||
my $maintainer;
|
||||
my $source;
|
||||
my $version;
|
||||
my $ver;
|
||||
|
||||
my %gb;
|
||||
my %group;
|
||||
my $group;
|
||||
|
||||
# Keeps a package->version database
|
||||
# to save time over using status
|
||||
my %sb;
|
||||
my @status;
|
||||
|
||||
my ($replaces, @REPLACE, $provides, $depends, $pre_depends,
|
||||
$recommends, $suggests, $conflicts);
|
||||
|
||||
my @conffiles;
|
||||
my $line_before;
|
||||
my @conf;
|
||||
my @complete;
|
||||
my @form;
|
||||
my @formly;
|
||||
my $format_deb = "$tmp/format.deb";
|
||||
|
||||
# Let's decide whether we should even go on. If it is --initdb, and
|
||||
# the databases already exist, nothing should be touched, but if it is
|
||||
# --rebuilddb and they exist, then they are removed and remade from
|
||||
# scratch.
|
||||
|
||||
# But first, better clean up any files in $tmp in case of an aborted
|
||||
# database formation
|
||||
unlink(<$tmp/DEBIAN*>) if -e "$tmp/DEBIANaa";
|
||||
unlink("$tmp/transfer.deb") if -e "$tmp/transfer.deb";
|
||||
unlink("$tmp/big.debian") if -e "$tmp/big.debian";
|
||||
unlink("$tmp/long.debian") if -e "$tmp/long.debian";
|
||||
|
||||
|
||||
if (-e "$parent$base/status" && -e "$parent$base/info") {
|
||||
$the_status = "$parent$base/status";
|
||||
}
|
||||
else {
|
||||
print "swim: crucial file(s)/directories are missing in $parent\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if ($commands->{"initdb"}) {
|
||||
if (-e "$parent$library/packages.deb" &&
|
||||
-e "$parent$library/fileindex.deb") {
|
||||
print "swim: use --rebuilddb\n";
|
||||
exit;
|
||||
}
|
||||
else {
|
||||
# if a database happens to be missing
|
||||
if (-e "$parent$library/packages.deb") {
|
||||
unlink("$parent$library/packages.deb");
|
||||
}
|
||||
if (-e "$parent$library/fileindex.deb") {
|
||||
unlink("$parent$library/fileindex.deb");
|
||||
}
|
||||
if (-e "$parent$library/groupindex.deb") {
|
||||
unlink("$parent$library/groupindex.deb");
|
||||
}
|
||||
if (-e "$parent$library/statusindex.deb") {
|
||||
unlink("$parent$library/statusindex.deb");
|
||||
}
|
||||
if (-e "$parent$library/searchindex.deb") {
|
||||
unlink("$parent$library/searchindex.deb");
|
||||
}
|
||||
if (-e "$parent$library/searchindex.deb.gz") {
|
||||
unlink("$parent$library/searchindex.deb.gz");
|
||||
}
|
||||
if (-e "$parent$library/dirindex.deb") {
|
||||
unlink("$parent$library/dirindex.deb");
|
||||
}
|
||||
if (-e "$parent$library/dirindex.deb.gz") {
|
||||
unlink("$parent$library/dirindex.deb.gz");
|
||||
}
|
||||
}
|
||||
}
|
||||
# this only works if all databases exist.
|
||||
elsif ($commands->{"rebuilddb"}) {
|
||||
if (-e "$parent$library/packages.deb" &&
|
||||
-e "$parent$library/fileindex.deb") {
|
||||
unlink("$parent$library/packages.deb");
|
||||
unlink("$parent$library/fileindex.deb");
|
||||
unlink("$parent$library/groupindex.deb");
|
||||
unlink("$parent$library/statusindex.deb");
|
||||
unlink("$parent$library/searchindex.deb");
|
||||
unlink("$parent$library/searchindex.deb")
|
||||
if -e "$parent$library/searchindex.deb";
|
||||
unlink("$parent$library/dirindex.deb");
|
||||
unlink("$parent$library/dirindex.deb")
|
||||
if -e "$parent$library/dirindex.deb.gz";
|
||||
}
|
||||
else {
|
||||
print "swim: use --initdb to create databases\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if ($commands->{"initdb"}) {
|
||||
if (-e "$parent$base/packages.deb" &&
|
||||
-e "$parent$base/fileindex.deb") {
|
||||
print "swim: use --rebuilddb\n";
|
||||
exit;
|
||||
}
|
||||
else {
|
||||
# if a database happens to be missing
|
||||
if (-e "$parent$base/packages.deb") {
|
||||
unlink("$parent$base/packages.deb");
|
||||
}
|
||||
if (-e "$parent$base/fileindex.deb") {
|
||||
unlink("$parent$base/fileindex.deb");
|
||||
}
|
||||
if (-e "$parent$base/groupindex.deb") {
|
||||
unlink("$parent$base/groupindex.deb");
|
||||
}
|
||||
if (-e "$parent$library/statusindex.deb") {
|
||||
unlink("$parent$library/statusindex.deb");
|
||||
}
|
||||
if (-e "$parent$library/searchindex.deb") {
|
||||
unlink("$parent$library/searchindex.deb");
|
||||
}
|
||||
if (-e "$parent$library/searchindex.deb.gz") {
|
||||
unlink("$parent$library/searchindex.deb.gz");
|
||||
}
|
||||
if (-e "$parent$library/dirindex.deb") {
|
||||
unlink("$parent$library/dirindex.deb");
|
||||
}
|
||||
if (-e "$parent$library/dirindex.deb.gz") {
|
||||
unlink("$parent$library/dirindex.deb.gz");
|
||||
}
|
||||
}
|
||||
}
|
||||
# this only works if all databases exist.
|
||||
elsif ($commands->{"rebuilddb"}) {
|
||||
if (-e "$parent$base/packages.deb" &&
|
||||
-e "$parent$base/fileindex.deb") {
|
||||
unlink("$parent$base/packages.deb");
|
||||
unlink("$parent$base/fileindex.deb");
|
||||
unlink("$parent$base/groupindex.deb");
|
||||
unlink("$parent$base/statusindex.deb");
|
||||
unlink("$parent$library/searchindex.deb");
|
||||
unlink("$parent$library/searchindex.deb")
|
||||
if -e "$parent$library/searchindex.deb";
|
||||
unlink("$parent$library/dirindex.deb");
|
||||
unlink("$parent$library/dirindex.deb")
|
||||
if -e "$parent$library/dirindex.deb.gz";
|
||||
}
|
||||
else {
|
||||
print "swim: use --initdb to create databases\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# This makes a backup of all the *.list files in ./backup. When
|
||||
# --initdb/--rebuilddb runs these files should be built or rebuilt,
|
||||
# but if changes have occured and --db(-i wasn't used) wasn't run
|
||||
# this won't cause problems because everything is rebuilt, there may
|
||||
# just be some lingering small files in backup.
|
||||
|
||||
# Seems like both approaches are about the same speed.
|
||||
#use File::Copy;
|
||||
print "Making backups of *.list\n";
|
||||
if (!-d "$parent$base/info/backup") {
|
||||
mkdir("$parent$base/info/backup",0666);
|
||||
}
|
||||
opendir(COPY,"$parent$base/info");
|
||||
foreach (sort grep(/\.list$/, readdir(COPY))) {
|
||||
#copy ("$parent$base/info/$_","$parent$base/info/backup/$_.bk");
|
||||
open(FILENAME,"$parent$base/info/$_");
|
||||
open(CP,">$parent$base/info/backup/$_.bk");
|
||||
while (<FILENAME>) {
|
||||
print CP $_;
|
||||
}
|
||||
}
|
||||
closedir(COPY);
|
||||
|
||||
print "Description Database is being made\n";
|
||||
|
||||
$| = 1; my $x = 0;
|
||||
open(PRETTY, ">$format_deb");
|
||||
open(AVAIL, "$the_status");
|
||||
while (<AVAIL>) {
|
||||
# Package name
|
||||
if (/^Package:|^PACKAGE:/) {
|
||||
@package = split(/: /,$_);
|
||||
chomp $package[1];
|
||||
$x = 1 if $x == 6;
|
||||
print "|\r" if $x == 1 || $x == 4; print "/\r" if $x == 2;
|
||||
print "-\r" if $x == 3 || $x == 6; print "\\\r" if $x == 5;
|
||||
$x++;
|
||||
}
|
||||
# Some other pertinent fields
|
||||
# All this stuff can be placed together..since it is generally nice
|
||||
# to know these things at one glance, in this order.
|
||||
# Package: Status:
|
||||
# Version: Essential: (yes or no)
|
||||
# Section: Priority:
|
||||
# Installed-Size:
|
||||
# Maintainer:
|
||||
# Description:
|
||||
|
||||
elsif (/^Status:/) {
|
||||
$status = $_;
|
||||
}
|
||||
elsif (/^Essential/) {
|
||||
@essential = split(/: /,$_);
|
||||
}
|
||||
elsif (/^Priority:/) {
|
||||
$priority = $_;
|
||||
}
|
||||
elsif (/^Section:/) {
|
||||
$section = $_;
|
||||
# make the hash for the groupindex.deb
|
||||
$group = substr($section,9);
|
||||
chomp $group;
|
||||
# we will put not-installed in their own group for reference
|
||||
if ($status !~ /not-installed/) {
|
||||
if (!defined $group{$group}) {
|
||||
$group{$group} = $package[1];
|
||||
}
|
||||
else {
|
||||
$group{$group} = "$group{$group} $package[1]";
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif (/^Installed-Size:/) {
|
||||
$installed_size = $_;
|
||||
}
|
||||
elsif (/^Maintainer:/) {
|
||||
$maintainer = $_;
|
||||
}
|
||||
elsif (/^Source:/) {
|
||||
$source = $_;
|
||||
}
|
||||
# hold ok not-installed - may want to change this just to
|
||||
# non-installed.
|
||||
elsif (/^Version:/ && $status !~ /not-installed/) {
|
||||
$version = $_;
|
||||
chomp($version, $section);
|
||||
$col1 = "Package: $package[1]";
|
||||
$col2 = $status;
|
||||
write PRETTY;
|
||||
$col1 = $version;
|
||||
$ver = m,Version:\s(.*),;
|
||||
# This creates a name -> version index in package.deb,
|
||||
# and the statusindex.deb database which will serve to
|
||||
# determine if the status has changed when --db or -i is
|
||||
# ran.
|
||||
push(@name, $package[1]);
|
||||
push(@status, $package[1]);
|
||||
$package[1] = "$package[1]_$1";
|
||||
push(@name, $package[1]);
|
||||
my $priory = substr($priority,10);
|
||||
chomp $priory;
|
||||
my $statusy = substr($status,8);
|
||||
chomp $statusy;
|
||||
$statusy =~ s/\s/:/g;
|
||||
my $thimk = "$package[1] $group $priory $statusy";
|
||||
push(@status, $thimk);
|
||||
if(defined($essential[1])) {
|
||||
$col2 = "Essential: $essential[1]";
|
||||
@essential = ();
|
||||
}
|
||||
else {
|
||||
$col2 = "Essential: no\n";
|
||||
}
|
||||
write PRETTY;
|
||||
if (defined $section) {
|
||||
$col1 = $section;
|
||||
}
|
||||
else {
|
||||
$col1 = "Section: unavailable";
|
||||
}
|
||||
if (defined $priority) {
|
||||
$col2 = $priority;
|
||||
}
|
||||
else {
|
||||
$col2 = "Priority: unavailable\n";
|
||||
}
|
||||
write PRETTY;
|
||||
#my $cool = $installed_size . $maintainer;
|
||||
$col1 = $installed_size;
|
||||
if (defined $source) {
|
||||
$col2 = $source;
|
||||
}
|
||||
else {
|
||||
$col2 = "";
|
||||
}
|
||||
write PRETTY;
|
||||
undef $source;
|
||||
print PRETTY $maintainer
|
||||
}
|
||||
|
||||
# This stuff will be available with seperate query flags or All
|
||||
elsif (/^Replaces:/) {
|
||||
$replaces = $_;
|
||||
if (defined($replaces)) {
|
||||
push(@REPLACE, "$package[1]REP");
|
||||
push(@REPLACE, $replaces);
|
||||
}
|
||||
}
|
||||
elsif (/^Provides:/) {
|
||||
$provides = $_;
|
||||
if (defined($provides)) {
|
||||
push(@REPLACE, "$package[1]PRO");
|
||||
push(@REPLACE, $provides);
|
||||
}
|
||||
}
|
||||
elsif (/^Depends:/) {
|
||||
$depends = $_;
|
||||
if (defined($depends)) {
|
||||
push(@REPLACE, "$package[1]DEP");
|
||||
push(@REPLACE, $depends);
|
||||
}
|
||||
}
|
||||
elsif (/^Pre-Depends:/) {
|
||||
$pre_depends = $_;
|
||||
if (defined($pre_depends)) {
|
||||
push(@REPLACE, "$package[1]PRE");
|
||||
push(@REPLACE, $pre_depends);
|
||||
}
|
||||
}
|
||||
elsif (/^Recommends:/) {
|
||||
$recommends = $_;
|
||||
if (defined($recommends)) {
|
||||
push(@REPLACE, "$package[1]REC");
|
||||
push(@REPLACE, $recommends);
|
||||
}
|
||||
}
|
||||
elsif (/^Suggests:/) {
|
||||
$suggests = $_;
|
||||
if (defined($suggests)) {
|
||||
push(@REPLACE, "$package[1]SUG");
|
||||
push(@REPLACE, $suggests);
|
||||
}
|
||||
}
|
||||
elsif (/^Conflicts:/) {
|
||||
$conflicts = $_;
|
||||
if (defined($conflicts)) {
|
||||
push(@REPLACE, "$package[1]CON");
|
||||
push(@REPLACE, $conflicts);
|
||||
}
|
||||
}
|
||||
# Gather the Configuration Files, Description comes after.
|
||||
# Available with a single flag.
|
||||
elsif (/^Conffiles:/) {
|
||||
my $line = <AVAIL>;
|
||||
while ($line !~ /^Description:/) {
|
||||
push(@conffiles,$line);
|
||||
$line = <AVAIL>;
|
||||
if ($line =~ /^Description/) {
|
||||
$line_before = $line;
|
||||
# put conffiles into one variable
|
||||
if (defined $package[1]) {
|
||||
#chomp $package[1];
|
||||
push(@conf,"$package[1]CONF");
|
||||
}
|
||||
my ($c, $cool);
|
||||
if ($#conffiles != 0) {
|
||||
for ($c = $#conffiles; $c >= 0; $c--) {
|
||||
if ($c > 0) {
|
||||
$cool = $conffiles[$c-1] .= $conffiles[$c];
|
||||
}
|
||||
} #end for
|
||||
}
|
||||
else {
|
||||
$cool = $conffiles[0];
|
||||
}
|
||||
@conffiles = ();
|
||||
push(@conf,$cool);
|
||||
} #if ($line =~ /^Desc
|
||||
} # while ($line ! /^Desc
|
||||
} # elsif (/^Conffiles
|
||||
|
||||
# Only interested in available packages..so this is fine.
|
||||
# To be combined with first fields.
|
||||
if (/Description:|^\s\w*|^\s\.\w*/ ||
|
||||
defined($line_before) =~ /^Description/){
|
||||
my $many_lines;
|
||||
if (defined($line_before)) {
|
||||
push(@ldescription, $line_before);
|
||||
push(@ldescription, $_);
|
||||
$line_before = ();
|
||||
}
|
||||
else {
|
||||
$many_lines = $_;
|
||||
}
|
||||
if ($_ !~ /^\n$/) {
|
||||
$count++;
|
||||
if ($count == 1) {
|
||||
if (defined $package[1]) {
|
||||
#chomp $package[1];
|
||||
push(@dpackage,$package[1]);
|
||||
push(@description,$package[1]);
|
||||
}
|
||||
}
|
||||
if (defined($many_lines)) {
|
||||
push(@ldescription,$many_lines);
|
||||
}
|
||||
} # end if ($_ !~ /^\n$/
|
||||
else {
|
||||
$count = 0;
|
||||
# let's put each description into one scalar
|
||||
my ($c, $cool);
|
||||
if ($#ldescription != 0) {
|
||||
for ($c = $#ldescription; $c >= 0; $c--) {
|
||||
if ($c > 0) {
|
||||
$cool = $ldescription[$c-1] .= $ldescription[$c];
|
||||
}
|
||||
} #end for
|
||||
} # end if ($#ld
|
||||
else {
|
||||
$cool = $ldescription[0];
|
||||
}
|
||||
if (defined $cool) {
|
||||
push(@description,$cool);
|
||||
}
|
||||
@ldescription = ();
|
||||
} # end else
|
||||
$line_before = ();
|
||||
}
|
||||
} # end while (<AVAIL>)
|
||||
close(PRETTY);
|
||||
|
||||
# Let's put together the description with the rest of its fields.
|
||||
open(FIELDS,"$format_deb");
|
||||
while (<FIELDS>) {
|
||||
push(@form,$_);
|
||||
}
|
||||
close(FIELDS);
|
||||
|
||||
foreach (@form) {
|
||||
push(@formly,$_);
|
||||
my ($cool);
|
||||
$count++;
|
||||
if ($count == 5) {
|
||||
my ($c, $cool);
|
||||
if ($#formly != 0) {
|
||||
for ($c = $#formly; $c >= 0; $c--) {
|
||||
if ($c > 0) {
|
||||
$cool = $formly[$c-1] .= $formly[$c];
|
||||
}
|
||||
} #end for
|
||||
} # end if ($#ld
|
||||
else {
|
||||
$cool = $formly[0];
|
||||
}
|
||||
push(@complete,$cool);
|
||||
@formly = ();
|
||||
$count = 0;
|
||||
}
|
||||
}
|
||||
|
||||
foreach (@description) {
|
||||
if ($count == 1) {
|
||||
my $lingo = shift(@complete);
|
||||
$lingo = $lingo . $_;
|
||||
push(@Tdescription, $lingo);
|
||||
$lingo = ();
|
||||
$count = 1;
|
||||
}
|
||||
else {
|
||||
push(@Tdescription, $_);
|
||||
$count = 0;
|
||||
}
|
||||
$count++;
|
||||
|
||||
}
|
||||
unlink($format_deb);
|
||||
|
||||
# We'll keep databases local so that md() doesn't get confused with
|
||||
# database().
|
||||
|
||||
# Put the groups into the groupindex.deb database.
|
||||
print "Group Database is being made\n";
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
tie %gb, 'DB_File', "$parent$library/groupindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
tie %gb, 'DB_File', "$parent$base/groupindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
|
||||
%gb = %group;
|
||||
|
||||
untie %gb;
|
||||
undef %gb;
|
||||
undef %group;
|
||||
|
||||
# Create the important status database.
|
||||
print "Status Database is being made\n";
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
tie %sb, 'DB_File', "$parent$library/statusindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
tie %sb, 'DB_File', "$parent$base/statusindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
|
||||
%sb = @status;
|
||||
|
||||
untie %sb;
|
||||
undef %sb;
|
||||
undef @status;
|
||||
|
||||
# Put everything into the package.deb database.
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
tie %db, 'DB_File', "$parent$library/packages.deb" or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
tie %db, 'DB_File', "$parent$base/packages.deb" or die "DB_File: $!";
|
||||
}
|
||||
|
||||
%db = (@name,@Tdescription,@conf,@REPLACE);
|
||||
untie %db;
|
||||
undef @Tdescription;
|
||||
undef @conf;
|
||||
undef @REPLACE;
|
||||
undef %db;
|
||||
|
||||
|
||||
# To the total db thing.
|
||||
if ($commands->{"initdb"} || $commands->{"rebuilddb"}) {
|
||||
md(\@dpackage,\%commands);
|
||||
}
|
||||
|
||||
|
||||
} # end sub database
|
||||
|
||||
|
||||
# Basically, this writes @dpackage to transfer.deb, which is processed by
|
||||
# either fastswim into two files big.debian and long.debian for further
|
||||
# processing by process_md() or is processed by imswim, then slowswim into
|
||||
# the two files big.debian and long.debian then finished by process_md()
|
||||
sub md {
|
||||
|
||||
my($dpackage,$commands) = @_; # creates transfer.deb
|
||||
my %commands = %$commands;
|
||||
|
||||
|
||||
unless (-e "$parent$base/info") {
|
||||
die 'This program requires the /var/lib/dpkg/info directory set-up by dpkg';
|
||||
}
|
||||
|
||||
# Put all file/dir(*.list)->package_name(s) into an massive array.
|
||||
# fastswim runs this process separately.
|
||||
|
||||
# This enables info files to be used from a different root system
|
||||
my $argument2 = "$parent$base/info";
|
||||
|
||||
# This is just for testing purposes, and serves no real purpose.
|
||||
if (!defined(@$dpackage)) {
|
||||
system("$fastswim");
|
||||
}
|
||||
# This is what is used.
|
||||
else {
|
||||
open(TRANSFER, ">$tmp/transfer.deb");
|
||||
foreach (@$dpackage) {
|
||||
print TRANSFER "$_\n";
|
||||
}
|
||||
close(TRANSFER);
|
||||
if (!$commands->{"lowmem"}) {
|
||||
system $fastswim, "--transfer", $argument2, $tmp;
|
||||
}
|
||||
else {
|
||||
print "Gathering the file(s)/dir(s)\n";
|
||||
system $imswim, $argument2, $tmp;
|
||||
system $slowswim, $tmp, $sort;
|
||||
}
|
||||
}
|
||||
undef @$dpackage;
|
||||
process_md(\%commands);
|
||||
|
||||
} # end sub md
|
||||
|
||||
|
||||
|
||||
1;
|
||||
497
SWIM/DB_Library.pm
Normal file
497
SWIM/DB_Library.pm
Normal file
@ -0,0 +1,497 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::DB_Library;
|
||||
use strict;
|
||||
use SWIM::Conf;
|
||||
use SWIM::Global;
|
||||
use SWIM::Library;
|
||||
use DB_File;
|
||||
use vars qw(@ISA @EXPORT %EXPORT_TAGS);
|
||||
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(ib nib dbi ndb sb exist_sb nsb ping zing nzing ging gb
|
||||
ngb sing ram_on version ver nver nping nzing nging nsing);
|
||||
%EXPORT_TAGS = (
|
||||
Search => [ qw(ib dbi nib nsb ndb gb ram_on version ngb) ],
|
||||
Db => [ qw(sb ib gb nsb ver dbi zing ging ping sing) ],
|
||||
Md => [ qw(sb ib nsb nzing) ],
|
||||
Deb => [ qw(sb nsb ndb) ],
|
||||
NDb => [ qw(ndb nsb ngb nver nping nzing nging nsing
|
||||
exist_sb sb) ],
|
||||
Groups => [ qw(gb ngb) ],
|
||||
Xyz => [ qw(dbi ndb) ]
|
||||
);
|
||||
|
||||
|
||||
# functions which use DB_File
|
||||
|
||||
|
||||
sub ib {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if (-e "$parent$library/fileindex.deb") {
|
||||
tie %ib, 'DB_File', "$parent$library/fileindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (-e "$parent$base/fileindex.deb") {
|
||||
tie %ib, 'DB_File', "$parent$base/fileindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
}
|
||||
} # end sub ib
|
||||
|
||||
sub dbi {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if (-e "$parent$library/packages.deb" ||
|
||||
($commands->{"initndb"} || $commands->{"rebuildndb"})) {
|
||||
tie %db, 'DB_File', "$parent$library/packages.deb" or die "DB_File: $!";
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (-e "$parent$base/packages.deb" ||
|
||||
($commands->{"initndb"} || $commands->{"rebuildndb"})) {
|
||||
tie %db, 'DB_File', "$parent$base/packages.deb" or die "DB_File: $!";
|
||||
}
|
||||
}
|
||||
} # end sub dbi
|
||||
|
||||
|
||||
|
||||
sub nib {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my ($arch,$dist) = which_archdist(\%commands);
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if (!-e "$parent$library/nfileindex$arch$dist.deb") {
|
||||
return;
|
||||
}
|
||||
tie %ib, 'DB_File', "$parent$library/nfileindex$arch$dist.deb" or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (!-e "$parent$base/nfileindex$arch$dist.deb") {
|
||||
return;
|
||||
}
|
||||
tie %ib, 'DB_File', "$parent$base/nfileindex$arch$dist.deb" or die "DB_File: $!";
|
||||
}
|
||||
} # end sub nib
|
||||
|
||||
|
||||
sub ndb {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my ($arch,$dist) = which_archdist(\%commands);
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if (-e "$parent$library/npackages$arch$dist.deb" ||
|
||||
($commands->{"initndb"} || $commands->{"rebuildndb"} ||
|
||||
$commands->{"ndb"})) {
|
||||
tie %db, 'DB_File', "$parent$library/npackages$arch$dist.deb"
|
||||
or die "swim: use pre-existing databases for this option";
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (-e "$parent$base/npackages$arch$dist.deb" ||
|
||||
($commands->{"initndb"} || $commands->{"rebuildndb"} ||
|
||||
$commands->{"ndb"})) {
|
||||
tie %db, 'DB_File', "$parent$base/npackages$arch$dist.deb"
|
||||
or die "swim: use pre-existing databases for this option";
|
||||
}
|
||||
}
|
||||
} # end sub ndb
|
||||
|
||||
|
||||
sub sb {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if (-e "$parent$library/statusindex.deb") {
|
||||
tie %sb, 'DB_File', "$parent$library/statusindex.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (-e "$parent$base/statusindex.deb") {
|
||||
tie %sb, 'DB_File', "$parent$base/statusindex.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
} # end sub sb
|
||||
|
||||
# exist_sb & sb seem to be used primarily in NDB_Init
|
||||
|
||||
# This first looks in the immediate directory for statusindex.deb, if it
|
||||
# isn't found here, it look in the default directory. It then returns
|
||||
# undef, or initializes the database based on its findings.
|
||||
sub exist_sb {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my $yep;
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if (-e "$parent$library/statusindex.deb") {
|
||||
$yep = "yes";
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (-e "$parent$base/statusindex.deb") {
|
||||
$yep = "yes";
|
||||
}
|
||||
}
|
||||
|
||||
if (!defined $yep) {
|
||||
if (-e "$parent$base/statusindex.deb") {
|
||||
tie %sb, 'DB_File', "$parent$base/statusindex.deb"
|
||||
or die "DB_File: $!";
|
||||
return "yes";
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
elsif (defined $yep) {
|
||||
sb(\%commands);
|
||||
return "yes";
|
||||
}
|
||||
|
||||
} # end sub exist_sb
|
||||
|
||||
sub nsb {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my($arch,$dist) = which_archdist(\%commands);
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if (-e "$parent$library/nstatusindex$arch$dist.deb" ||
|
||||
($commands->{"initndb"} || $commands->{"rebuildndb"} ||
|
||||
$commands->{"ndb"})) {
|
||||
tie %nsb, 'DB_File', "$parent$library/nstatusindex$arch$dist.deb"
|
||||
or die "swim: use pre-existing databases for this option";
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (-e "$parent$base/nstatusindex$arch$dist.deb" ||
|
||||
($commands->{"initndb"} || $commands->{"rebuildndb"} ||
|
||||
$commands->{"ndb"})) {
|
||||
tie %nsb, 'DB_File', "$parent$base/nstatusindex$arch$dist.deb" or die
|
||||
or die "swim: use pre-existing databases for this option";
|
||||
}
|
||||
}
|
||||
} # end sub nsb
|
||||
|
||||
sub ping {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$ping = tie %db, 'DB_File', "$parent$library/packages.deb" or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$ping = tie %db, 'DB_File', "$parent$base/packages.deb" or die "DB_File: $!";
|
||||
}
|
||||
}
|
||||
|
||||
sub nping {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my ($arch,$dist) = which_archdist(\%commands);
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$ping = tie %db, 'DB_File', "$parent$library/npackages$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$ping = tie %db, 'DB_File', "$parent$base/npackages$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
} # end sub nping
|
||||
|
||||
|
||||
sub zing {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$zing = tie %ib, 'DB_File', "$parent$library/fileindex.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$zing = tie %ib, 'DB_File', "$parent$base/fileindex.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
} # end sub zing
|
||||
|
||||
sub nzing {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my ($arch,$dist) = which_archdist(\%commands);
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$zing = tie %ib, 'DB_File', "$parent$library/nfileindex$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$zing = tie %ib, 'DB_File', "$parent$base/nfileindex$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
} # end sub nzing
|
||||
|
||||
|
||||
sub ging {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$ging = tie %gb, 'DB_File', "$parent$library/groupindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$ging = tie %gb, 'DB_File', "$parent$base/groupindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
} #end sub ging
|
||||
|
||||
|
||||
sub nging {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my ($arch,$dist) = which_archdist(\%commands);
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$ging = tie %gb, 'DB_File',"$parent$library/ngroupindex$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$ging = tie %gb, 'DB_File', "$parent$base/ngroupindex$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
} # end sub nging
|
||||
|
||||
|
||||
sub gb {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if (-e "$parent$library/groupindex.deb" ||
|
||||
($commands->{"initndb"} || $commands->{"rebuildndb"})) {
|
||||
tie %gb, 'DB_File', "$parent$library/groupindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (-e "$parent$base/groupindex.deb" ||
|
||||
($commands->{"initndb"} || $commands->{"rebuildndb"})) {
|
||||
tie %gb, 'DB_File', "$parent$base/groupindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub ngb {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my ($arch,$dist) = which_archdist(\%commands);
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
if (-e "$parent$library/ngroupindex$arch$dist.deb" ||
|
||||
($commands->{"initndb"} || $commands->{"rebuildndb"})) {
|
||||
tie %gb, 'DB_File', "$parent$library/ngroupindex$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
if (-e "$parent$base/ngroupindex$arch$dist.deb" ||
|
||||
($commands->{"initndb"} || $commands->{"rebuildndb"})) {
|
||||
tie %gb, 'DB_File', "$parent$base/ngroupindex$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub sing {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$sing = tie %sb, 'DB_File', "$parent$library/statusindex.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$sing = tie %sb, 'DB_File', "$parent$base/statusindex.deb" or die "DB_File: $!";
|
||||
}
|
||||
} # sub sing
|
||||
|
||||
sub nsing {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my ($arch,$dist) = which_archdist(\%commands);
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$sing = tie %nsb, 'DB_File', "$parent$library/nstatusindex$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$sing = tie %nsb, 'DB_File', "$parent$base/nstatusindex$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
} # end sub nsing
|
||||
|
||||
|
||||
# This doesn't depend on DB so it can be placed somewhere else if it is used by more
|
||||
# than SWIM::Search.
|
||||
|
||||
# checks to see if ramdisk is on, searchdf() & nfile()-process_nfile()
|
||||
# (used by file()) uses this
|
||||
sub ram_on {
|
||||
|
||||
my $ramdisk;
|
||||
|
||||
# this monster runs for every argument
|
||||
my $rambo = "$cat /proc/mounts|";
|
||||
open(RAM, "$rambo");
|
||||
while (<RAM>) {
|
||||
if (/ram/) {
|
||||
my($device,$mount) = split(/\s/,$_,2);
|
||||
if ($mount =~ /dramdisk/) {
|
||||
$ramdisk = "yes";
|
||||
return $ramdisk;
|
||||
}
|
||||
}
|
||||
}
|
||||
close(RAM);
|
||||
} # end sub ram_on
|
||||
|
||||
|
||||
|
||||
# finds package name and version
|
||||
sub version {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
if (!$commands{"n"}) {
|
||||
dbi(\%commands);
|
||||
}
|
||||
else {
|
||||
ndb(\%commands);
|
||||
}
|
||||
|
||||
if (defined $argument) {
|
||||
# We will check for more than two..just in case
|
||||
if ($argument !~ /_/) {
|
||||
if (defined $db{$argument}) {
|
||||
$argument = $db{$argument};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
} # end sub version
|
||||
# returns version but and then is untied
|
||||
sub ver {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
dbi(\%commands);
|
||||
|
||||
if (defined $argument) {
|
||||
# We will check for more than two..just in case
|
||||
if ($argument !~ /_/) {
|
||||
if (defined $db{$argument}) {
|
||||
$argument = $db{$argument};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
untie %db;
|
||||
|
||||
} # end sub ver
|
||||
|
||||
sub nver {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
ndb(\%commands);
|
||||
|
||||
if (defined $argument) {
|
||||
# We will check for more than two..just in case
|
||||
if ($argument !~ /_/) {
|
||||
if (defined $db{$argument}) {
|
||||
$argument = $db{$argument};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
untie %db;
|
||||
|
||||
} # end sub nver
|
||||
|
||||
1752
SWIM/Deb.pm
Normal file
1752
SWIM/Deb.pm
Normal file
File diff suppressed because it is too large
Load Diff
456
SWIM/Deps.pm
Normal file
456
SWIM/Deps.pm
Normal file
@ -0,0 +1,456 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Deps;
|
||||
use strict;
|
||||
use SWIM::Global qw(:Info);
|
||||
use SWIM::DB_Library qw(:Xyz);
|
||||
use vars qw(@ISA @EXPORT);
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(character s_character which_character the_character);
|
||||
|
||||
# the -T and siblings
|
||||
|
||||
# process the database for replaces
|
||||
sub replaces {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "REP";
|
||||
if (defined $db{$conf}) {
|
||||
return $db{$conf};
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub replaces
|
||||
|
||||
# process the database for provides
|
||||
sub provides {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "PRO";
|
||||
if (defined $db{$conf}) {
|
||||
return $db{$conf};
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub provides
|
||||
|
||||
# process the database for depends
|
||||
sub depends {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "DEP";
|
||||
if (defined $db{$conf}) {
|
||||
return $db{$conf};
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub depends
|
||||
|
||||
# process the database for replaces
|
||||
sub pre_depends {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "PRE";
|
||||
if (defined $db{$conf}) {
|
||||
return $db{$conf};
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub pre_depends
|
||||
|
||||
# process the database for replaces
|
||||
sub recommends {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "REC";
|
||||
if (defined $db{$conf}) {
|
||||
return $db{$conf};
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub recommends
|
||||
|
||||
# process the database for replaces
|
||||
sub suggests {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "SUG";
|
||||
if (defined $db{$conf}) {
|
||||
return $db{$conf};
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub suggests
|
||||
|
||||
# process the database for replaces
|
||||
sub conflicts {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "CON";
|
||||
if (defined $db{$conf}) {
|
||||
return $db{$conf};
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub conflicts
|
||||
|
||||
#These subroutines are for cases where only packages related to the
|
||||
# characteristics are printed out.
|
||||
# process the database for replaces
|
||||
sub s_replaces {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "REP";
|
||||
if (defined $db{$conf}) {
|
||||
return "$argument\n$db{$conf}";
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub s_replaces
|
||||
|
||||
# process the database for provides
|
||||
sub s_provides {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "PRO";
|
||||
if (defined $db{$conf}) {
|
||||
return "$argument\n$db{$conf}";
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub s_provides
|
||||
|
||||
# process the database for depends
|
||||
sub s_depends {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "DEP";
|
||||
if (defined $db{$conf}) {
|
||||
return "$argument\n$db{$conf}";
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub s_depends
|
||||
|
||||
# process the database for replaces
|
||||
sub s_pre_depends {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "PRE";
|
||||
if (defined $db{$conf}) {
|
||||
return "$argument\n$db{$conf}";
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub s_pre_depends
|
||||
|
||||
# process the database for replaces
|
||||
sub s_recommends {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "REC";
|
||||
if (defined $db{$conf}) {
|
||||
return "$argument\n$db{$conf}";
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub s_recommends
|
||||
|
||||
# process the database for replaces
|
||||
sub s_suggests {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "SUG";
|
||||
if (defined $db{$conf}) {
|
||||
return "$argument\n$db{$conf}";
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub s_suggests
|
||||
|
||||
# process the database for replaces
|
||||
sub s_conflicts {
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands);
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "CON";
|
||||
if (defined $db{$conf}) {
|
||||
return "$argument\n$db{$conf}";
|
||||
}
|
||||
else { return ""; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub s_conflicts
|
||||
|
||||
|
||||
# This figures out which characteristics (Replaces, Provides, etc) the
|
||||
# options are pointing to. Isn't choosey, prints all packages
|
||||
sub character {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
# for singular cases
|
||||
if ($commands->{"g"} && ($commands->{"T"} || $commands->{"pre_depends"} ||
|
||||
$commands->{"depends"} || $commands->{"recommends"} ||
|
||||
$commands->{"suggests"} || $commands->{"provides"} ||
|
||||
$commands->{"replaces"} || $commands->{"conflicts"}) &&
|
||||
!($commands->{"c"} || $commands->{"d"} || $commands->{"l"} ||
|
||||
$commands->{"i"})) {
|
||||
print "$argument\n";
|
||||
}
|
||||
|
||||
# all the characteristics
|
||||
if (defined $commands->{"T"}) {
|
||||
print pre_depends(\%commands);
|
||||
print depends(\%commands);
|
||||
print recommends(\%commands);
|
||||
print suggests(\%commands);
|
||||
print provides(\%commands);
|
||||
print replaces(\%commands);
|
||||
print conflicts(\%commands);
|
||||
}
|
||||
else {
|
||||
|
||||
if (defined $commands->{"pre_depends"}) {
|
||||
print pre_depends(\%commands);
|
||||
delete $commands{"pre_depends"} if !($commands->{"S"} || $commands->{"g"});
|
||||
}
|
||||
|
||||
if (defined $commands->{"depends"}) {
|
||||
print depends(\%commands);
|
||||
delete $commands{"depends"} if !($commands->{"S"} || $commands->{"g"});
|
||||
}
|
||||
|
||||
if (defined $commands->{"recommends"}) {
|
||||
print recommends(\%commands);
|
||||
delete $commands{"recommends"} if !($commands->{"S"} || $commands->{"g"});
|
||||
}
|
||||
|
||||
if (defined $commands->{"suggests"}) {
|
||||
print suggests(\%commands);
|
||||
delete $commands{"suggests"} if !($commands->{"S"} || $commands->{"g"});
|
||||
}
|
||||
|
||||
if (defined $commands->{"replaces"}) {
|
||||
print replaces(\%commands);
|
||||
delete $commands{"replaces"} if !($commands->{"S"} || $commands->{"g"});
|
||||
}
|
||||
|
||||
if (defined $commands->{"provides"}) {
|
||||
print provides(\%commands);
|
||||
delete $commands{"provides"} if !($commands->{"S"} || $commands->{"g"});
|
||||
}
|
||||
|
||||
if (defined $commands->{"conflicts"}) {
|
||||
print conflicts(\%commands);
|
||||
delete $commands{"conflicts"} if !($commands->{"S"} || $commands->{"g"});
|
||||
}
|
||||
}
|
||||
|
||||
} # end sub character
|
||||
|
||||
# Prints out the characteristics only for the packages which have them.
|
||||
sub s_character {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
if ($commands->{"pre_depends"}) {
|
||||
print s_pre_depends(\%commands);
|
||||
delete $commands{"pre_depends"};
|
||||
if (s_pre_depends(\%commands) ne "") {
|
||||
character(\%commands);
|
||||
}
|
||||
# else { s_character(\%commands) }
|
||||
}
|
||||
elsif ($commands->{"depends"}) {
|
||||
print s_depends(\%commands);
|
||||
delete $commands{"depends"};
|
||||
if (s_depends(\%commands) ne "") {
|
||||
character(\%commands);
|
||||
}
|
||||
# else { s_character(\%commands) }
|
||||
}
|
||||
elsif ($commands->{"recommends"}) {
|
||||
print s_recommends(\%commands);
|
||||
delete $commands{"recommends"};
|
||||
if (s_recommends(\%commands) ne "") {
|
||||
character(\%commands);
|
||||
}
|
||||
# else { s_character(\%commands) }
|
||||
}
|
||||
elsif ($commands->{"suggests"}) {
|
||||
print s_suggests(\%commands);
|
||||
delete $commands{"suggests"};
|
||||
if (s_suggests(\%commands) ne "") {
|
||||
character(\%commands);
|
||||
}
|
||||
# else { s_character(\%commands) }
|
||||
}
|
||||
elsif ($commands->{"replaces"}) {
|
||||
print s_replaces(\%commands);
|
||||
delete $commands{"replaces"};
|
||||
if (s_replaces(\%commands) ne "") {
|
||||
character(\%commands);
|
||||
}
|
||||
# else { s_character(\%commands) }
|
||||
}
|
||||
elsif ($commands->{"provides"}) {
|
||||
print s_provides(\%commands);
|
||||
delete $commands{"provides"};
|
||||
if (s_provides(\%commands) ne "") {
|
||||
character(\%commands);
|
||||
}
|
||||
# else { s_character(\%commands) }
|
||||
}
|
||||
elsif ($commands->{"conflicts"}) {
|
||||
print s_conflicts(\%commands);
|
||||
delete $commands{"conflicts"};
|
||||
if (s_conflicts(\%commands) ne "") {
|
||||
character(\%commands);
|
||||
}
|
||||
# else { s_character(\%commands) }
|
||||
}
|
||||
|
||||
# all the characteristics
|
||||
if ($commands->{"T"}) {
|
||||
print s_pre_depends(\%commands);
|
||||
print s_depends(\%commands);
|
||||
print s_recommends(\%commands);
|
||||
print s_suggests(\%commands);
|
||||
print s_provides(\%commands);
|
||||
print s_replaces(\%commands);
|
||||
print s_conflicts(\%commands);
|
||||
}
|
||||
|
||||
|
||||
} # end sub s_character
|
||||
|
||||
|
||||
# helps to determine if character(\%commands) should be used
|
||||
sub which_character {
|
||||
my ($commands) = @_;
|
||||
if ($commands->{"pre_depends"} || $commands->{"depends"} ||
|
||||
$commands->{"recommends"} || $commands->{"suggests"} ||
|
||||
$commands->{"replaces"} || $commands->{"provides"} ||
|
||||
$commands->{"conflicts"}) {
|
||||
return 1;
|
||||
}
|
||||
} # end sub which_character
|
||||
|
||||
# This runs a test to see whether or not the characters being asked for
|
||||
# apply to this package.
|
||||
sub the_character {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
if (defined $commands->{"pre_depends"}) {
|
||||
if (pre_depends(\%commands) eq "") {
|
||||
print "";
|
||||
}
|
||||
else { return "ok"; }
|
||||
}
|
||||
|
||||
if (defined $commands->{"depends"}) {
|
||||
if (depends(\%commands) eq "") {
|
||||
print "";
|
||||
}
|
||||
else { return "ok"; }
|
||||
}
|
||||
|
||||
if (defined $commands->{"recommends"}) {
|
||||
if (recommends(\%commands) eq "") {
|
||||
print "";
|
||||
}
|
||||
else { return "ok"; }
|
||||
}
|
||||
|
||||
if (defined $commands->{"suggests"}) {
|
||||
if (suggests(\%commands) eq "") {
|
||||
print "";
|
||||
}
|
||||
else { return "ok"; }
|
||||
}
|
||||
|
||||
if (defined $commands->{"replaces"}) {
|
||||
if (replaces(\%commands) eq "") {
|
||||
print "";
|
||||
}
|
||||
else { return "ok"; }
|
||||
}
|
||||
|
||||
if (defined $commands->{"provides"}) {
|
||||
if (provides(\%commands) eq "") {
|
||||
print "";
|
||||
}
|
||||
else { return "ok"; }
|
||||
}
|
||||
|
||||
if (defined $commands->{"conflicts"}) {
|
||||
if (conflicts(\%commands) eq "") {
|
||||
print "";
|
||||
}
|
||||
else { return "ok"; }
|
||||
}
|
||||
|
||||
} # end sub the_character
|
||||
|
||||
1;
|
||||
110
SWIM/Dir.pm
Normal file
110
SWIM/Dir.pm
Normal file
@ -0,0 +1,110 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Dir;
|
||||
use strict;
|
||||
use SWIM::Global qw($argument);
|
||||
use SWIM::Conf qw($pwd);
|
||||
use vars qw(@ISA @EXPORT @EXPORT_OK);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(dir fir);
|
||||
|
||||
# dir() fir()
|
||||
|
||||
# When --dir is used checks argument (when -f is called) and determines dir
|
||||
# stuff..is it real or not.
|
||||
sub dir {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
if ($commands->{"dir"}) {
|
||||
if (! -d $argument) {
|
||||
if (! -e $argument) {
|
||||
print "$argument is not a directory or file\n";
|
||||
}
|
||||
else {
|
||||
print "$argument is not a directory\n";
|
||||
}
|
||||
exit;
|
||||
}
|
||||
elsif ($argument =~ m,\/$,) {
|
||||
if ($argument !~ m,^\/,) {
|
||||
if ($pwd =~ m,^\/$,) {
|
||||
$argument =~ m,(.*)\/$,;
|
||||
$argument = "$pwd$1";
|
||||
}
|
||||
else {
|
||||
$argument =~ m,(.*)\/$,;
|
||||
$argument = "$pwd/$1";
|
||||
}
|
||||
}
|
||||
else {
|
||||
$argument =~ m,(.*)\/$,;
|
||||
$argument = $1;
|
||||
}
|
||||
}
|
||||
elsif ($argument !~ m,\/$|^\/, && $argument =~ m,\/,) {
|
||||
if ($pwd =~ m,^\/$,) {
|
||||
$argument = "/$argument";
|
||||
}
|
||||
else {
|
||||
$argument = "$pwd/$argument";
|
||||
}
|
||||
}
|
||||
}
|
||||
} # end sub dir
|
||||
|
||||
# when --dir isn't called...does the same thing as dir.
|
||||
sub fir {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
if ($argument =~ m,\/$,) {
|
||||
# Let's test to see whether it really is a file or directory.
|
||||
if (! -d $argument) {
|
||||
print "$argument is not a file\n";
|
||||
exit;
|
||||
}
|
||||
if ($argument !~ m,^\/,) {
|
||||
if ($pwd =~ m,^\/$,) {
|
||||
$argument =~ m,(.*)\/$,;
|
||||
$argument = "$pwd$1";
|
||||
}
|
||||
else {
|
||||
$argument =~ m,(.*)\/$,;
|
||||
$argument = "$pwd/$1";
|
||||
}
|
||||
}
|
||||
else {
|
||||
$argument =~ m,(.*)\/$,;
|
||||
$argument = $1;
|
||||
}
|
||||
}
|
||||
elsif ($argument !~ m,\/$|^\/, && $argument =~ m,\/,) {
|
||||
if ($pwd =~ m,^\/$,) {
|
||||
$argument = "/$argument";
|
||||
}
|
||||
else {
|
||||
$argument = "$pwd/$argument";
|
||||
}
|
||||
}
|
||||
} # end sub fir
|
||||
|
||||
1;
|
||||
|
||||
92
SWIM/F.pm
Normal file
92
SWIM/F.pm
Normal file
@ -0,0 +1,92 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::F;
|
||||
use Carp;
|
||||
use strict;
|
||||
use vars qw(@ISA @EXPORT);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(get);
|
||||
|
||||
|
||||
# This is Net::FTP::get with minor modifications. Not all the features
|
||||
# are used, but are kept, just in case they will be.
|
||||
|
||||
sub get
|
||||
{
|
||||
my($ftp,$remote,$local,$where) = @_;
|
||||
|
||||
my($loc,$len,$buf,$resp,$localfd,$data);
|
||||
local *FD;
|
||||
$| = 1;
|
||||
$localfd = ref($local) ? fileno($local)
|
||||
: undef;
|
||||
|
||||
($local = $remote) =~ s#^.*/##
|
||||
unless(defined $local);
|
||||
|
||||
${*$ftp}{'net_ftp_rest'} = $where
|
||||
if ($where);
|
||||
|
||||
delete ${*$ftp}{'net_ftp_port'};
|
||||
delete ${*$ftp}{'net_ftp_pasv'};
|
||||
|
||||
$data = $ftp->retr($remote) or
|
||||
return undef;
|
||||
|
||||
if(defined $localfd)
|
||||
{
|
||||
$loc = $local;
|
||||
}
|
||||
else
|
||||
{
|
||||
$loc = \*FD;
|
||||
|
||||
unless(($where) ? open($loc,">>$local") : open($loc,">$local"))
|
||||
{
|
||||
carp "Cannot open Local file $local: $!\n";
|
||||
$data->abort;
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
if($ftp->type eq 'I' && !binmode($loc))
|
||||
{
|
||||
carp "Cannot binmode Local file $local: $!\n";
|
||||
$data->abort;
|
||||
return undef;
|
||||
}
|
||||
|
||||
$buf = ''; my $amt = 0;
|
||||
#print "\n";
|
||||
do
|
||||
{
|
||||
$len = $data->read($buf,1024);
|
||||
$amt = $len + $amt;
|
||||
print "[$amt]\r";
|
||||
}
|
||||
while($len > 0 && syswrite($loc,$buf,$len) == $len);
|
||||
|
||||
close($loc)
|
||||
unless defined $localfd;
|
||||
|
||||
$data->close(); # implied $ftp->response
|
||||
|
||||
return $local;
|
||||
}
|
||||
877
SWIM/File.pm
Normal file
877
SWIM/File.pm
Normal file
@ -0,0 +1,877 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::File;
|
||||
use strict;
|
||||
use SWIM::Global;
|
||||
use SWIM::DB_Library qw(:Xyz ram_on nsb);
|
||||
use SWIM::Library;
|
||||
use SWIM::Conf qw(:Path $md5sum);
|
||||
use vars qw(@ISA @EXPORT);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(file);
|
||||
|
||||
|
||||
#=pod
|
||||
#
|
||||
#This provides the list of files belonging to a package. Although a
|
||||
#database could be used..it's probably faster, and cheaper on space
|
||||
#accessing from the /var/lib/dpkg/info* files. And if --md5sum is
|
||||
#called, the md5sums are shown for the -d ,-l, or -c files they exist for.
|
||||
#md5sums are checked for, and reported back as OK or FAILED. -l or
|
||||
#-d(overrides l). -qd(l) md5sum from RH has a slightly different
|
||||
#output.. filepath/filename: file OK before swim's output..this can be
|
||||
#altered
|
||||
#
|
||||
#=end
|
||||
|
||||
sub file {
|
||||
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my $file;
|
||||
my $md5;
|
||||
my @md5;
|
||||
my $path;
|
||||
my @path;
|
||||
my $md5sums;
|
||||
my $md5sums_conf;
|
||||
my %md5sums = ();
|
||||
my $orig_argument;
|
||||
my $count = 0;
|
||||
|
||||
|
||||
if (!$commands->{"n"}) {
|
||||
dbi(\%commands);
|
||||
}
|
||||
# files/dirs will be found from contents.deb (compressed)
|
||||
else {
|
||||
ndb(\%commands);
|
||||
}
|
||||
|
||||
if (defined $argument) {
|
||||
if ($argument =~ /_/) {
|
||||
my $check;
|
||||
if (defined $db{"$argument"}) {
|
||||
$check = $db{"$argument"};
|
||||
}
|
||||
$argument =~ m,(^.*)_(.*$),;
|
||||
if (defined $check) {
|
||||
$argument = $1;
|
||||
}
|
||||
else {}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
||||
if (defined $argument) {
|
||||
if (!$commands->{"n"}) {
|
||||
$file = "$parent$base/info/$argument.list";
|
||||
if (-e "$parent$base/info/$argument.md5sums") {
|
||||
$md5sums = "$parent$base/info/$argument.md5sums";
|
||||
}
|
||||
if (-e "$parent$base/info/$argument-conf.md5sums" && $commands->{"c"}) {
|
||||
$md5sums_conf = "$parent$base/info/$argument-conf.md5sums";
|
||||
}
|
||||
|
||||
|
||||
##################
|
||||
# MD5SUMS FOR -C #
|
||||
##################
|
||||
if ($commands->{"md5sum"} && $commands->{"c"} && !($commands->{"d"} ||
|
||||
$commands->{"l"})) {
|
||||
if (!defined $md5sums_conf && $commands->{"c"}) {
|
||||
$md5sums_conf = make_conf(\%commands);
|
||||
}
|
||||
# now we can process $md5sums and $md5sums_conf assuming one or
|
||||
# both actually exist
|
||||
if (defined $md5sums_conf) {
|
||||
chdir("/");
|
||||
my %path;
|
||||
open (MD5SUM, "$md5sums_conf");
|
||||
open (MD5SUMCHECK, "|$md5sum -c 2>$tmp/md5sumcheck");
|
||||
while (<MD5SUM>) {
|
||||
if ($_ =~ /newconffile/) {
|
||||
$path = substr($_, 13);
|
||||
push(@path,$path);
|
||||
$md5 = substr($_, 0, 11);
|
||||
push(@md5,$md5);
|
||||
chomp $path;
|
||||
chomp $md5;
|
||||
$path{"$path"} = $md5;
|
||||
print MD5SUMCHECK $_;
|
||||
next;
|
||||
}
|
||||
$path = substr($_, 34);
|
||||
push(@path,$path);
|
||||
$md5 = substr($_, 0, 32);
|
||||
push(@md5,$md5);
|
||||
chomp $path;
|
||||
chomp $md5;
|
||||
$path{"$path"} = $md5;
|
||||
print MD5SUMCHECK $_;
|
||||
}
|
||||
close(MD5SUMCHECK);
|
||||
close(MD5SUM);
|
||||
#now check with md5sum from the dpkg package
|
||||
my $check_md5sum;
|
||||
# won't bother going into this while unless there is a reason
|
||||
if (defined "$tmp/md5sumcheck" && $md5 ne "newconffile") {
|
||||
open(MD5SUMFILE, "$tmp/md5sumcheck");
|
||||
while (<MD5SUMFILE>) {
|
||||
if ($_ !~ /no files checked/) {
|
||||
if (/failed/) {
|
||||
# Humm may be two situations watch or due to coding change
|
||||
#$check_md5sum = substr($_,39);
|
||||
$check_md5sum = substr($_,30);
|
||||
$check_md5sum =~ s/'//;
|
||||
chomp $check_md5sum;
|
||||
$md5sums{"$check_md5sum"} = "FAILED";
|
||||
}
|
||||
elsif (/can't open/) {
|
||||
# Humm may be two situations watch or due to coding change
|
||||
#$check_md5sum = substr($_,28);
|
||||
$check_md5sum = substr($_,19);
|
||||
chomp $check_md5sum;
|
||||
$md5sums{"$check_md5sum"} = "MISSING";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
close(MD5SUMCHECK);
|
||||
unlink("$tmp/md5sumcheck");
|
||||
# This finishes everything
|
||||
open (LIST,"$md5sums_conf");
|
||||
while (<LIST>) {
|
||||
if ($_ =~ /newconffile/) {
|
||||
$_ = substr($_, 13);
|
||||
chomp;
|
||||
}
|
||||
else {
|
||||
$_ = substr($_, 34);
|
||||
chomp;
|
||||
}
|
||||
if (defined $path{$_}) {
|
||||
# humm file_now() not necessary here
|
||||
if (defined $md5sums{$_}) {
|
||||
print " /$_ $path{$_} $md5sums{$_}\n";
|
||||
}
|
||||
elsif ($path{$_} ne "newconffile") {
|
||||
print " /$_ $path{$_} OK";
|
||||
print "\n";
|
||||
}
|
||||
else {
|
||||
print " /$_ $path{$_}\n";
|
||||
}
|
||||
}
|
||||
} # last while
|
||||
close(LIST);
|
||||
%md5sums = ();
|
||||
%path = ();
|
||||
@path = ();
|
||||
@md5 = ();
|
||||
} # do the md5sum files even exist?
|
||||
}
|
||||
|
||||
########################
|
||||
# MD5SUMS FOR -C &| -L #
|
||||
########################
|
||||
# checking for -e $md5sums is a questionable practice because it
|
||||
# may not exist, but the conf files do.
|
||||
if ($commands->{"md5sum"} && !$commands->{"d"} &&
|
||||
(($commands->{"l"} && $commands->{"c"}) || $commands->{"l"})) {
|
||||
# I decided on three while loops, because it was the most practical
|
||||
# way to handle STDERR from md5sum, and all types of
|
||||
# experimentation didn't yield a better way of doing it, but there
|
||||
# is probably a better way.
|
||||
# first do things normally, and no chomping
|
||||
# but, first grab conf info.
|
||||
if (!defined $md5sums_conf && $commands->{"c"}) {
|
||||
$md5sums_conf = make_conf(\%commands);
|
||||
}
|
||||
# now we can process $md5sums and $md5sums_conf assuming one or
|
||||
# both actually exist
|
||||
if (defined $md5sums || defined $md5sums_conf) {
|
||||
#if ($md5sums_conf ne 1) {
|
||||
chdir("/");
|
||||
my %path;
|
||||
if ($commands->{"c"} && $md5sums_conf) {
|
||||
open (MD5SUM,"$md5sums_conf");
|
||||
}
|
||||
else {
|
||||
open (MD5SUM,"$md5sums");
|
||||
$count = 1;
|
||||
}
|
||||
while ($count <= 1) {
|
||||
if (($count == 1 && defined $md5sums) || $count == 0) {
|
||||
open (MD5SUMCHECK, "|$md5sum -c 2>$tmp/md5sumcheck");
|
||||
while (<MD5SUM>) {
|
||||
if ($_ =~ /newconffile/) {
|
||||
$path = substr($_, 13);
|
||||
push(@path,$path);
|
||||
$md5 = substr($_, 0, 11);
|
||||
push(@md5,$md5);
|
||||
chomp $path;
|
||||
chomp $md5;
|
||||
$path{"/$path"} = $md5;
|
||||
print MD5SUMCHECK $_;
|
||||
next;
|
||||
}
|
||||
$path = substr($_, 34);
|
||||
push(@path,$path);
|
||||
$md5 = substr($_, 0, 32);
|
||||
push(@md5,$md5);
|
||||
chomp $path;
|
||||
chomp $md5;
|
||||
$path{"/$path"} = $md5;
|
||||
print MD5SUMCHECK $_;
|
||||
}
|
||||
close(MD5SUMCHECK);
|
||||
close(MD5SUM);
|
||||
#now check with md5sum from the dpkg package
|
||||
my $check_md5sum;
|
||||
#my $count = 0;
|
||||
# won't bother going into this while unless there is a reason
|
||||
if (defined "$tmp/md5sumcheck" && $md5 ne "newconffile") {
|
||||
open(MD5SUMFILE, "$tmp/md5sumcheck");
|
||||
while (<MD5SUMFILE>) {
|
||||
if ($_ !~ /no files checked/) {
|
||||
if (/failed/) {
|
||||
$check_md5sum = substr($_,30);
|
||||
$check_md5sum =~ s/'//;
|
||||
chomp $check_md5sum;
|
||||
$md5sums{"/$check_md5sum"} = "FAILED";
|
||||
}
|
||||
elsif (/can't open/) {
|
||||
$check_md5sum = substr($_,19);
|
||||
#$check_md5sum =~ s/'//;
|
||||
chomp $check_md5sum;
|
||||
$md5sums{"/$check_md5sum"} = "MISSING";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
close(MD5SUMCHECK);
|
||||
unlink("$tmp/md5sumcheck");
|
||||
}
|
||||
# This finishes everything
|
||||
# This prunes stuff out and assumes that *.list and *.md5sums
|
||||
# overlap.
|
||||
open (LIST,"$file");
|
||||
######
|
||||
# -L #
|
||||
######
|
||||
if ($commands->{"l"} && !$commands->{"df"}) {
|
||||
while (<LIST>) {
|
||||
chomp;
|
||||
if (!-d $_ && $argument ne "base-files") {
|
||||
my $line = $_;
|
||||
file_now(\%commands);
|
||||
md5_print(\%path,\%md5sums,$line,$count);
|
||||
}
|
||||
##############
|
||||
# BASE-FILES #
|
||||
##############
|
||||
elsif ($argument eq "base-files") {
|
||||
my $line = $_;
|
||||
md5_print(\%path,\%md5sums,$line,$count);
|
||||
}
|
||||
} # last while
|
||||
}
|
||||
#############
|
||||
# -L & --DF #
|
||||
#############
|
||||
elsif ($commands->{"l"} && $commands->{"df"}) {
|
||||
while (<LIST>) {
|
||||
chomp;
|
||||
my $line = $_;
|
||||
file_now(\%commands);
|
||||
md5_print(\%path,\%md5sums,$line,$count);
|
||||
} # last while
|
||||
}
|
||||
close(LIST);
|
||||
%md5sums = ();
|
||||
%path = ();
|
||||
@path = ();
|
||||
@md5 = ();
|
||||
$count++;
|
||||
if ($count == 1) {
|
||||
open (MD5SUM,"$md5sums") if $md5sums;
|
||||
}
|
||||
} # loop through -c or not
|
||||
} # do the md5sum files even exist?
|
||||
#}
|
||||
}
|
||||
#@@ got to watch this for -l's called directly, will allow -l to
|
||||
# be seen whether or not --md5sum is used, changed elsif to if.
|
||||
# if already found above don't use below here.
|
||||
# && ||'s tricky here
|
||||
if (-e $file && !$commands->{"d"} && (!defined $md5sums &&
|
||||
!defined $md5sums_conf) || -e $file &&
|
||||
(!$commands->{"md5sum"} && !$commands->{"d"})) {
|
||||
file_now(\%commands) if !$commands->{"f"};
|
||||
open (LIST,"$file");
|
||||
while (<LIST>) {
|
||||
chomp;
|
||||
if ($commands->{"l"} && !$commands->{"df"}) {
|
||||
if (!-d $_ && $argument ne "base-files") {
|
||||
print "$_\n";
|
||||
}
|
||||
elsif ($argument eq "base-files") {
|
||||
print "$_\n";
|
||||
}
|
||||
}
|
||||
elsif ($commands->{"l"} && $commands->{"df"}) {
|
||||
if ($argument ne "base-files") {
|
||||
print "$_\n";
|
||||
}
|
||||
elsif ($argument eq "base-files") {
|
||||
print "$_\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
########################
|
||||
# MD5SUMS FOR -C &| -D #
|
||||
########################
|
||||
# for Documentation.
|
||||
elsif ($commands->{"md5sum"} && ($commands->{"d"} || ($commands->{"d"} &&
|
||||
$commands->{"c"}))) {
|
||||
if (!defined $md5sums_conf && $commands->{"c"}) {
|
||||
$md5sums_conf = make_conf(\%commands);
|
||||
}
|
||||
# now we can process $md5sums and $md5sums_conf assuming one or
|
||||
# both actually exist
|
||||
if (defined $md5sums || defined $md5sums_conf) {
|
||||
chdir("/");
|
||||
my %path;
|
||||
if ($commands->{"c"} && $md5sums_conf) {
|
||||
open (MD5SUM,"$md5sums_conf");
|
||||
}
|
||||
else {
|
||||
open (MD5SUM,"$md5sums");
|
||||
$count = 1;
|
||||
}
|
||||
while ($count <= 1) {
|
||||
if (($count == 1 && defined $md5sums) || $count == 0) {
|
||||
open (MD5SUMCHECK, "|$md5sum -c 2>$tmp/md5sumcheck");
|
||||
while (<MD5SUM>) {
|
||||
if ($_ =~ /newconffile/) {
|
||||
$path = substr($_, 13);
|
||||
push(@path,$path);
|
||||
$md5 = substr($_, 0, 11);
|
||||
push(@md5,$md5);
|
||||
chomp $path;
|
||||
chomp $md5;
|
||||
$path{"/$path"} = $md5;
|
||||
print MD5SUMCHECK $_;
|
||||
next;
|
||||
}
|
||||
$path = substr($_, 34);
|
||||
push(@path,$path);
|
||||
$md5 = substr($_, 0, 32);
|
||||
push(@md5,$md5);
|
||||
chomp $path;
|
||||
chomp $md5;
|
||||
$path{"/$path"} = $md5;
|
||||
print MD5SUMCHECK $_;
|
||||
}
|
||||
close(MD5SUMCHECK);
|
||||
close(MD5SUM);
|
||||
#now check with md5sum from the dpkg package
|
||||
my $check_md5sum;
|
||||
# won't bother going into this while unless there is a reason
|
||||
if (defined "$tmp/md5sumcheck") {
|
||||
open(MD5SUMFILE, "$tmp/md5sumcheck");
|
||||
while (<MD5SUMFILE>) {
|
||||
if ($_ !~ /no files checked/) {
|
||||
if (/failed/) {
|
||||
$check_md5sum = substr($_,30);
|
||||
$check_md5sum =~ s/'//;
|
||||
chomp $check_md5sum;
|
||||
$md5sums{"/$check_md5sum"} = "FAILED";
|
||||
}
|
||||
elsif (/can't open/) {
|
||||
$check_md5sum = substr($_,19);
|
||||
chomp $check_md5sum;
|
||||
$md5sums{"/$check_md5sum"} = "MISSING";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
close(MD5SUMCHECK);
|
||||
unlink("$tmp/md5sumcheck");
|
||||
}
|
||||
# This finishes everything
|
||||
open (LIST,"$file");
|
||||
while (<LIST>) {
|
||||
chomp;
|
||||
# humm, checking for existence?
|
||||
#if (-e $_ && $argument ne "base-files") {
|
||||
if ($argument ne "base-files") {
|
||||
#@@
|
||||
######
|
||||
# -D #
|
||||
######
|
||||
if (defined $path{$_}) {
|
||||
if (defined $md5sums{$_}) {
|
||||
if ($count == 0) {
|
||||
print " $_ $path{$_} $md5sums{$_}" if $count == 0;
|
||||
print "$_ $path{$_} $md5sums{$_}" if $count == 1;
|
||||
print "\n";
|
||||
}
|
||||
elsif (m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, &&
|
||||
$count == 1) {
|
||||
print " $_ $path{$_} $md5sums{$_}" if $count == 0;
|
||||
print "$_ $path{$_} $md5sums{$_}" if $count == 1;
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
elsif ($path{$_} ne "newconffile") {
|
||||
if ($count == 0) {
|
||||
print " $_ $path{$_} OK" if $count == 0;
|
||||
print "$_ $path{$_} OK" if $count == 1;
|
||||
print "\n";
|
||||
}
|
||||
elsif (m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, &&
|
||||
$count == 1) {
|
||||
print " $_ $path{$_} OK" if $count == 0;
|
||||
print "$_ $path{$_} OK" if $count == 1;
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($count == 0) {
|
||||
print " $_ $path{$_}\n" if $count == 0;
|
||||
print "$_ $path{$_}\n" if $count == 1;
|
||||
print "\n";
|
||||
}
|
||||
elsif (m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, &&
|
||||
$count == 1) {
|
||||
print " $_ $path{$_} OK" if $count == 0;
|
||||
print "$_ $path{$_} OK" if $count == 1;
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($count == 1) {
|
||||
if (m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, && !-d) {
|
||||
file_now(\%commands);
|
||||
print "$_\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
# humm? treated specially, hopefully.
|
||||
######################
|
||||
# BASE-FILES PACKAGE #
|
||||
######################
|
||||
elsif ($argument eq "base-files") {
|
||||
my $line = $_;
|
||||
if ($line =~ m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, ||
|
||||
defined $path{$line}) {
|
||||
md5_print(\%path,\%md5sums,$line,$count);
|
||||
}
|
||||
}
|
||||
} # another while
|
||||
close(LIST);
|
||||
%md5sums = ();
|
||||
%path = ();
|
||||
@path = ();
|
||||
@md5 = ();
|
||||
$count++;
|
||||
if ($count == 1) {
|
||||
open (MD5SUM,"$md5sums") if $md5sums;
|
||||
}
|
||||
} # loop through -c or not
|
||||
} # do the md5sum files even exist?
|
||||
}
|
||||
#@@ another important change, print --md5sum and -l together
|
||||
if (-e $file && $commands->{"d"} && (!defined $md5sums &&
|
||||
!defined $md5sums_conf) || -e $file &&
|
||||
(!$commands->{"md5sum"} && $commands->{"d"})) {
|
||||
file_now(\%commands) if !$commands->{"f"};
|
||||
#if (-e $file && $commands->{"d"}) {
|
||||
open (LIST,"$file");
|
||||
while (<LIST>) {
|
||||
chomp;
|
||||
if (m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, && !-d) {
|
||||
print "$_\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
#if (!defined $md5sums || !defined $md5sums_conf) {
|
||||
if (!-e $file) {
|
||||
print "package $argument is not installed\n";
|
||||
}
|
||||
}
|
||||
} # if !--n
|
||||
else {
|
||||
# Let's check first if this package actually exists, files are checked
|
||||
# earlier.
|
||||
if (defined $argument) {
|
||||
if (!defined $db{"$argument"}) {
|
||||
print "package $argument is not installed\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
nfile(\%commands);
|
||||
}
|
||||
} # if defined $argument
|
||||
|
||||
untie %db;
|
||||
|
||||
|
||||
if (defined $file_now && !($commands->{"z"} ||
|
||||
$commands->{"ftp"} ||
|
||||
$commands->{"remove"} || $commands->{"r"} ||
|
||||
$commands->{"purge"})) {
|
||||
if ($commands{"x"} || $commands{"ftp"} || $commands{"source"} ||
|
||||
$commands{"source_only"} || $commands{"remove"} ||
|
||||
$commands{"r"} || $commands{"purge"}) {
|
||||
require SWIM::Safex;
|
||||
SWIM::Safex->import(qw(safex));
|
||||
safex(\%commands);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
} # end sub file
|
||||
|
||||
# this manages situation involving -qlcx & -qglx
|
||||
sub file_now {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
#if (!$commands->{"g"} && !defined $file_now) {
|
||||
if (!$commands->{"g"}) {
|
||||
if ($arg_count < $#ARGV) {
|
||||
push(@arg_holder,$argument);
|
||||
# humm
|
||||
#@PACKAGES = "DEFINEDONE";
|
||||
#@PACKAGES = "$ARGV[$#ARGV]";
|
||||
$arg_count++;
|
||||
}
|
||||
else {
|
||||
@PACKAGES = @arg_holder;
|
||||
push(@PACKAGES,$argument);
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($arg_count < $#stuff) {
|
||||
push(@arg_holder,$argument);
|
||||
#$arg_count++;
|
||||
}
|
||||
else {
|
||||
@PACKAGES = @arg_holder;
|
||||
push(@PACKAGES,$argument);
|
||||
}
|
||||
}
|
||||
|
||||
} # end file_now
|
||||
|
||||
# In order to run a md5sum test on configuration files directly recognized
|
||||
# by dpkg, a file with package_name-conf.md5sums is created, in addition to
|
||||
# any existing package_name.md5sums file.
|
||||
sub make_conf {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my $md5sums_conf;
|
||||
if (!$commands->{"n"}) {
|
||||
dbi(\%commands);
|
||||
}
|
||||
# humm, just a trap
|
||||
else {
|
||||
ndb(\%commands);
|
||||
}
|
||||
|
||||
if ($argument !~ /_/ ) {
|
||||
# I guess we can stop here here is there are no configuration
|
||||
# files
|
||||
if (defined $db{$argument}) {
|
||||
require SWIM::Info;
|
||||
SWIM::Info->import(qw(conf));
|
||||
my $orig_argument = $argument;
|
||||
$argument = $db{$argument};
|
||||
my ($conf, @conf, %conf);
|
||||
my ($m5, $dir, $thing);
|
||||
if (conf(\%commands) ne 0) {
|
||||
$conf = conf(\%commands);
|
||||
@conf = split(/\n/, $conf);
|
||||
open(PACKCONF,">$parent$base/info/$orig_argument-conf.md5sums");
|
||||
foreach (@conf) {
|
||||
$_ =~ m,( \/)(.*$),;
|
||||
($dir, $m5) = split(/ /, $2, 2);
|
||||
$thing = "$m5 $dir\n";
|
||||
print PACKCONF $thing;
|
||||
}
|
||||
close(PACKCONF);
|
||||
$md5sums_conf =
|
||||
"$parent$base/info/$orig_argument-conf.md5sums";
|
||||
return $md5sums_conf;
|
||||
}
|
||||
else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
untie %db;
|
||||
|
||||
} # end sub make_conf
|
||||
|
||||
|
||||
# prints out the results from the md5sum test for -l & -l --df
|
||||
sub md5_print {
|
||||
|
||||
my ($path, $md5sums, $line, $count) = @_;
|
||||
|
||||
if (defined $path->{$line}) {
|
||||
if (defined $md5sums->{$line}) {
|
||||
print " $line $path->{$line} $md5sums->{$line}" if $count == 0;
|
||||
print "$line $path->{$line} $md5sums->{$line}" if $count == 1;
|
||||
print "\n";
|
||||
}
|
||||
elsif ($path->{$line} ne "newconffile") {
|
||||
print " $line $path->{$line} OK" if $count == 0;
|
||||
print "$line $path->{$line} OK" if $count == 1;
|
||||
print "\n";
|
||||
}
|
||||
else {
|
||||
print " $line $path->{$line}\n" if $count == 0;
|
||||
print "$line $path->{$line}\n" if $count == 1;
|
||||
}
|
||||
}
|
||||
elsif ($count == 1) {
|
||||
print "$line\n";
|
||||
}
|
||||
|
||||
} # end md5_print
|
||||
|
||||
|
||||
# -n The list of files/dirs belonging to a package. No md5sum here.
|
||||
sub nfile {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my $ramdisk = ram_on(\%commands);
|
||||
|
||||
# Here's a case where gnu grep is faster than using open.
|
||||
if ($ramdisk eq "yes") {
|
||||
my $what = "yes";
|
||||
process_nfile($what,\%commands);
|
||||
} # if ramdisk
|
||||
|
||||
elsif ($ramdisk eq 1) {
|
||||
my $what = "no";
|
||||
process_nfile($what,\%commands);
|
||||
}
|
||||
|
||||
} # end sub nfile
|
||||
|
||||
# -n figure out --df, -d & -l using the contents db
|
||||
sub process_nfile {
|
||||
|
||||
my ($what,$commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my $contentsdb = finddb(\%commands);
|
||||
my ($arch,$dist) = which_archdist(\%commands);
|
||||
my ($Contents,$subject);
|
||||
|
||||
|
||||
# the + solution
|
||||
nsb(\%commands);
|
||||
$subject = (split(/\s/,$nsb{$argument}))[1];
|
||||
$argument =~ s,\+,\\\\+,g if $argument =~ m,\+,;
|
||||
untie %nsb;
|
||||
|
||||
if ($what eq "no") {
|
||||
if (-e "$contentsdb/ncontentsindex$arch$dist.deb.gz") {
|
||||
$Contents = "zgrep -E $argument\ $contentsdb/ncontentsindex$arch$dist.deb.gz|";
|
||||
}
|
||||
else {
|
||||
print "swim: stopping, cannot perform this operation without contents\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
elsif ($what eq "yes") {
|
||||
if (-e "$contentsdb/dramdisk/ncontentsindex$arch$dist.deb.gz") {
|
||||
$Contents = "zgrep -E $argument\ $contentsdb/dramdisk/ncontentsindex$arch$dist.deb.gz|";
|
||||
}
|
||||
else {
|
||||
print "swim: stopping, cannot perform this operation without contents\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
my($dirfile,$package,@dirfile,@comma,%all,%again);
|
||||
open(CONTENTSDB, "$Contents");
|
||||
while (<CONTENTSDB>) {
|
||||
# changed for >= 0.2.9 - will have to watch for these
|
||||
# guys net/sendfile, x11/xscreensaver, x11/xscreensaver,
|
||||
# graphics/ucbmpeg, admin/cfengine .. there is a space before them
|
||||
#if (/^FILE\s*LOCATION$/) {
|
||||
#while (<CONTENTSDB>) {
|
||||
if (!$commands->{"df"}) {
|
||||
# this isn't acurate for groups of packages ,,, so will use the
|
||||
# subject section instead of \b and $
|
||||
$argument =~ s,\\\\+,\\\+,g if $argument =~ m,\+,;
|
||||
if (m,$subject/$argument,) {
|
||||
######################
|
||||
# DOESN'T END WITH / #
|
||||
######################
|
||||
if ($_ !~ m,.*/\s+\w*,) {
|
||||
($dirfile,$package) = split(/\s+/,$_,2);
|
||||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) {
|
||||
my @more_things = split(/\s+/,$package);
|
||||
$package = $more_things[$#more_things];
|
||||
(my $backpackage = $package) =~ s,\+,\\+,g;
|
||||
my @dirfile = split(/\s+$backpackage/,$_);
|
||||
$dirfile = $dirfile[0];
|
||||
}
|
||||
$dirfile = "/$dirfile";
|
||||
######
|
||||
# -L #
|
||||
######
|
||||
if (!$commands->{"d"} && $commands->{"l"}) {
|
||||
print "$dirfile\n";
|
||||
}
|
||||
######
|
||||
# -D #
|
||||
######
|
||||
elsif ($commands->{"d"}) {
|
||||
if ($dirfile =~ m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/,) {
|
||||
print "$dirfile\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
########
|
||||
# --DF #
|
||||
########
|
||||
elsif ($commands->{"df"} && $commands->{"l"} && !$commands->{"d"}) {
|
||||
$argument =~ s,\\\\+,\\\+,g if $argument =~ m,\+,;
|
||||
if (m,$subject/$argument,) {
|
||||
#if (m,\b$argument\b,) {
|
||||
|
||||
######################
|
||||
# ENDS WITH / #
|
||||
######################
|
||||
if (m,.*/\s+\w*,) {
|
||||
($dirfile,$package) = split(/\s+/,$_,2);
|
||||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) {
|
||||
my @more_things = split(/\s+/,$package);
|
||||
$package = $more_things[$#more_things];
|
||||
(my $backpackage = $package) =~ s,\+,\\+,g;
|
||||
my @dirfile = split(/\s+$backpackage/,$_);
|
||||
$dirfile = $dirfile[0];
|
||||
}
|
||||
@dirfile = split(/\//,$dirfile); $dirfile =~ s,/$,,;
|
||||
}
|
||||
######################
|
||||
# DOESN'T END WITH / #
|
||||
######################
|
||||
else {
|
||||
($dirfile,$package) = split(/\s+/,$_,2);
|
||||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) {
|
||||
my @more_things = split(/\s+/,$package);
|
||||
$package = $more_things[$#more_things];
|
||||
(my $backpackage = $package) =~ s,\+,\\+,g;
|
||||
my @dirfile = split(/\s+$backpackage/,$_);
|
||||
$dirfile = $dirfile[0];
|
||||
}
|
||||
@dirfile = split(/\//,$dirfile);
|
||||
}
|
||||
###########################
|
||||
# PROCESS INTO FILES/DIRS #
|
||||
###########################
|
||||
my ($count,$holder);
|
||||
for ($count = 0; $count <= $#dirfile; $count++) {
|
||||
if ($count == 0) {
|
||||
$holder = "/$dirfile[$count]";
|
||||
my $again = "$dirfile[$count]";
|
||||
my $all = "/.";
|
||||
$again{$again}++;
|
||||
$all{$all}++;
|
||||
if ($all{$all} == 1) {
|
||||
print "/.\n";
|
||||
}
|
||||
if ($again{$again} == 1) {
|
||||
print "/$dirfile[$count]\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
$holder = $holder . "/$dirfile[$count]";
|
||||
my $again = "$holder";
|
||||
$again{$again}++;
|
||||
if ($again{$again} == 1) {
|
||||
print "$holder\n";
|
||||
}
|
||||
}
|
||||
} # end for
|
||||
}
|
||||
}
|
||||
###################
|
||||
# -D & --DF &| -L #
|
||||
###################
|
||||
elsif (($commands->{"d"} && $commands->{"df"}) ||
|
||||
$commands->{"d"} && $commands->{"df"} && $commands->{"l"}) {
|
||||
$argument =~ s,\\\\+,\\\+,g if $argument =~ m,\+,;
|
||||
if (m,$subject/$argument,) {
|
||||
#if (m,\b$argument$,) {
|
||||
|
||||
######################
|
||||
# DOESN'T END WITH / #
|
||||
######################
|
||||
if ($_ !~ m,.*/\s+\w*,) {
|
||||
($dirfile,$package) = split(/\s+/,$_,2);
|
||||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) {
|
||||
my @more_things = split(/\s+/,$package);
|
||||
$package = $more_things[$#more_things];
|
||||
(my $backpackage = $package) =~ s,\+,\\+,g;
|
||||
my @dirfile = split(/\s+$backpackage/,$_);
|
||||
$dirfile = $dirfile[0];
|
||||
}
|
||||
$dirfile = "/$dirfile";
|
||||
######
|
||||
# -D #
|
||||
######
|
||||
if ($dirfile =~ m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/,) {
|
||||
print "$dirfile\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
#}
|
||||
#}
|
||||
} # while
|
||||
close(CONTENTSDB);
|
||||
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
358
SWIM/Findex.pm
Normal file
358
SWIM/Findex.pm
Normal file
@ -0,0 +1,358 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Findex;
|
||||
use strict;
|
||||
use SWIM::Global;
|
||||
use SWIM::Conf qw($my_number);
|
||||
use SWIM::DB_Library qw(:Xyz ib nib nsb);
|
||||
use SWIM::Info;
|
||||
use SWIM::Deps;
|
||||
use SWIM::Dir;
|
||||
use vars qw(@ISA @EXPORT_OK);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(findexer qindexer);
|
||||
|
||||
|
||||
# findexer(\%commands) and qindexer used for -a -n -f
|
||||
|
||||
# query filelist for file name.. -qfl -qal, but not -qfl(d)c ... actually
|
||||
# yes... -qlfd under certain conditions, but not with -c. And -T and
|
||||
# singular capabilities.
|
||||
sub findexer {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my @alot;
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
|
||||
|
||||
if (!$commands->{"n"}) {
|
||||
ib(\%commands);
|
||||
}
|
||||
else {
|
||||
my $return = nib(\%commands);
|
||||
if (!defined $return && $commands->{"a"}) {
|
||||
untie %ib;
|
||||
nsb(\%commands);
|
||||
$ib{"/."} = $nsb{"/."};
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $argument) {
|
||||
if ($commands->{"dir"}) {
|
||||
dir(\%commands);
|
||||
}
|
||||
elsif ($commands->{"f"}) {
|
||||
fir(\%commands);
|
||||
}
|
||||
if ($ib{"$argument"}){
|
||||
my $package = $ib{"$argument"};
|
||||
@alot = split(/\s/, $package);
|
||||
@PACKAGES = @alot;
|
||||
if ($commands->{"z"} || $commands->{"ftp"} ||
|
||||
$commands->{"remove"} || $commands->{"r"} ||
|
||||
$commands->{"purge"}) {
|
||||
require SWIM::Safex;
|
||||
SWIM::Safex->import(qw(safex));
|
||||
safex(\%commands);
|
||||
}
|
||||
@alot = @PACKAGES;
|
||||
if ($commands->{"total"} || $commands->{"t"}) {
|
||||
if ($commands->{"T"}) {
|
||||
foreach (@alot) {
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
# nice to print package names before file listings
|
||||
if (!$commands->{"i"} || !$commands->{"d"} || !$commands->{"c"}) {
|
||||
print "$argument\n";
|
||||
}
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
file(\%commands);
|
||||
print "\n";
|
||||
}
|
||||
} # if -T
|
||||
elsif (which_character(\%commands)) {
|
||||
foreach (@alot) {
|
||||
my %store_commands = %commands;
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
if (the_character(\%commands) ne "ok") {
|
||||
print "$argument\n";
|
||||
}
|
||||
if (defined s_character(\%commands)) {}
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
file(\%commands);
|
||||
print "\n";
|
||||
%commands = %store_commands;
|
||||
undef %store_commands;
|
||||
}
|
||||
}
|
||||
# no -Ts.
|
||||
foreach (@alot) {
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
if (defined $argument) {
|
||||
print "\n" if $commands->{"l"};
|
||||
print "$argument\n";
|
||||
}
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
file(\%commands);
|
||||
if ($commands->{"d"} && !$commands->{"T"} && !which_character(\%commands)) {
|
||||
print "\n" if !$commands->{"l"};
|
||||
}
|
||||
} # end not's
|
||||
} # if -t
|
||||
|
||||
|
||||
elsif ($#ARGV > $my_number) {
|
||||
my $total = $#ARGV + 1;
|
||||
print "use --total or -t to see all $total packages\n";
|
||||
exit;
|
||||
}
|
||||
elsif ($#alot > $my_number) {
|
||||
my $total = $#alot + 1;
|
||||
print "use --total or -t to see all $total packages\n";
|
||||
}
|
||||
|
||||
else {
|
||||
if ($commands->{"T"}) {
|
||||
foreach (@alot) {
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
print "$argument\n";
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
file(\%commands);
|
||||
print "\n";
|
||||
}
|
||||
} # end -T
|
||||
elsif (which_character(\%commands)) {
|
||||
foreach (@alot) {
|
||||
my %store_commands = %commands;
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
if (the_character($argument) ne "ok") {
|
||||
print "$argument\n";
|
||||
}
|
||||
if (defined s_character(\%commands)) {}
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
file(\%commands);
|
||||
print "\n";
|
||||
%commands = %store_commands;
|
||||
undef %store_commands;
|
||||
}
|
||||
} # which_character
|
||||
foreach (@alot) {
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
if (defined $argument) {
|
||||
print "$argument\n";
|
||||
}
|
||||
file(\%commands);
|
||||
if ($commands->{"d"} && !$commands->{"T"} && !which_character(\%commands)) {
|
||||
print "\n";
|
||||
}
|
||||
} # end not's
|
||||
} # else
|
||||
}
|
||||
else {
|
||||
$argument =~ m,.*\/(.*$),;
|
||||
if (defined $1) {
|
||||
my $file = $1;
|
||||
if (!$commands->{"n"} && -e "/usr/sbin/update-alternatives") {
|
||||
my $it = "update-alternatives --display $1|";
|
||||
open (IT,"$it") or exit;
|
||||
if (<IT> =~ /No alternatives/) {
|
||||
print "file $file is not owned by any package\n";
|
||||
}
|
||||
else {
|
||||
my @LINES = <IT>;
|
||||
print "For $argument ->\n";
|
||||
$LINES[0] =~ m,(/.*$),; $argument = $1;
|
||||
print "@LINES\n"; findexer(\%commands);
|
||||
}
|
||||
}
|
||||
else {
|
||||
print "file $file is not owned by any package\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
untie %ib;
|
||||
|
||||
if (!($commands->{"z"} || $commands->{"ftp"} ||
|
||||
$commands->{"remove"} || $commands->{"r"} ||
|
||||
$commands->{"purge"})) {
|
||||
if ($commands->{"x"} || $commands->{"ftp"} || $commands->{"source"} ||
|
||||
$commands->{"source_only"} || $commands->{"remove"} ||
|
||||
$commands->{"r"} || $commands->{"purge"}) {
|
||||
require SWIM::Safex;
|
||||
SWIM::Safex->import(qw(safex));
|
||||
safex(\%commands);
|
||||
}
|
||||
}
|
||||
|
||||
} # end sub findexer
|
||||
|
||||
|
||||
# query description of file name..-i (-qfi)
|
||||
sub qindexer {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
require SWIM::Ag;
|
||||
SWIM::Ag->import(qw(description));
|
||||
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
|
||||
my @alot;
|
||||
|
||||
if (!$commands->{"n"}) {
|
||||
ib(\%commands);
|
||||
}
|
||||
else {
|
||||
my $return = nib(\%commands);
|
||||
if (!defined $return && $commands->{"a"}) {
|
||||
untie %ib;
|
||||
nsb(\%commands);
|
||||
$ib{"/."} = $nsb{"/."};
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $argument) {
|
||||
dir(\%commands);
|
||||
fir(\%commands);
|
||||
|
||||
# this will be moved above for safex(\%commands)
|
||||
if ($ib{"$argument"}){
|
||||
my $package = $ib{"$argument"};
|
||||
@alot = split(/\s/, $package);
|
||||
@PACKAGES = @alot;
|
||||
if ($commands->{"z"} || $commands->{"ftp"} ||
|
||||
$commands->{"remove"} || $commands->{"r"} ||
|
||||
$commands->{"purge"}) {
|
||||
require SWIM::Safex;
|
||||
SWIM::Safex->import(qw(safex));
|
||||
safex(\%commands);
|
||||
}
|
||||
@alot = @PACKAGES;
|
||||
if ($commands->{"total"} || $commands->{"t"}) {
|
||||
foreach (@alot) {
|
||||
$argument = $_;
|
||||
description(\%commands);
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
elsif ($#ARGV > 0) {
|
||||
my $total = $#ARGV + 1;
|
||||
print "use --total or -t to see all $total packages\n";
|
||||
exit;
|
||||
}
|
||||
elsif ($#alot > 0) {
|
||||
my $total = $#alot + 1;
|
||||
print "use --total or -t to see all $total packages\n";
|
||||
}
|
||||
else {
|
||||
$argument = $package;
|
||||
description(\%commands);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$argument =~ m,.*\/(.*$),;
|
||||
if (defined $1) {
|
||||
my $file = $1;
|
||||
if (!$commands->{"n"} && -e "/usr/sbin/update-alternatives") {
|
||||
my $it = "update-alternatives --display $1|";
|
||||
open (IT,"$it") or exit;
|
||||
if (<IT> =~ /No alternatives/) {
|
||||
print "file $file is not owned by any package\n";
|
||||
}
|
||||
else {
|
||||
my @LINES = <IT>;
|
||||
print "For $argument ->\n";
|
||||
$LINES[0] =~ m,(/.*$),; $argument = $1;
|
||||
print "@LINES\n"; qindexer(\%commands);
|
||||
}
|
||||
}
|
||||
else {
|
||||
print "file $file is not owned by any package\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
untie %ib;
|
||||
|
||||
|
||||
|
||||
} # end sub qindexer
|
||||
|
||||
|
||||
1;
|
||||
62
SWIM/Format.pm
Normal file
62
SWIM/Format.pm
Normal file
@ -0,0 +1,62 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Format;
|
||||
use vars qw(@ISA @EXPORT);
|
||||
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(*PRETTY *ALLGROUPS *SUBJECT *CENTER *SDS $col1 $col2 $ag1
|
||||
$ag2 $ag3 $number $subsite $subdate $subsize $subrelease
|
||||
$center $number $sdsite $sdsdate $sdsize $sdsrelease);
|
||||
|
||||
|
||||
# A nice format to make things look prettier, hopefully.
|
||||
format PRETTY =
|
||||
@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
|
||||
$col1, $col2
|
||||
.
|
||||
|
||||
# A format for --allgroups, shouldn't run out of room.
|
||||
format ALLGROUPS =
|
||||
@<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<
|
||||
$ag1, $ag2, $ag3
|
||||
.
|
||||
|
||||
# center for DF|APT call
|
||||
format SUBJECT =
|
||||
@|| @||| @||| @||||||||||| @||||||
|
||||
$number, $subsite, $subdate, $subsize, $subrelease
|
||||
|
||||
.
|
||||
|
||||
|
||||
format CENTER =
|
||||
@|||||||||||||||||||||||
|
||||
$center
|
||||
.
|
||||
|
||||
|
||||
format SDS =
|
||||
@>> @||||||||||||||||||||| @||||||||||||||||||||||||||| @|||||||| @|||||
|
||||
$number, $sdsite, $sdsdate, $sdsize, $sdsrelease
|
||||
.
|
||||
|
||||
|
||||
|
||||
1;
|
||||
62
SWIM/Global.pm
Normal file
62
SWIM/Global.pm
Normal file
@ -0,0 +1,62 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Global;
|
||||
#use strict;
|
||||
use vars qw(@ISA @EXPORT %EXPORT_TAGS);
|
||||
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(%db $ping %ndb %ib $zing %gb $ging %sb $sing %nsb %commands
|
||||
$argument $save @stuff @PACKAGES @arg_holder $file_now
|
||||
$arg_count $aptor_count $aptor_group $swim_version);
|
||||
%EXPORT_TAGS = (
|
||||
Info => [ qw($argument %db) ]
|
||||
);
|
||||
|
||||
=pod
|
||||
|
||||
Globals used by all program, which are not related to SWIM::Conf globals.
|
||||
Most will probably be placed in SWIM::DB_Library.
|
||||
|
||||
=cut
|
||||
# Nothing to be done here.
|
||||
# these could be put into SWIM::DB_Library
|
||||
my (%db,$ping); # package.deb
|
||||
my %ndb; # npackage.deb
|
||||
my (%ib, $zing, %it); # fileindex.deb
|
||||
my (%gb, $ging); # groupindex.deb
|
||||
my (%sb, $sing); # statusindex.deb
|
||||
my %nsb; # nstatusindex.deb
|
||||
my %commands; # standard for Getopt::Long, but should usually
|
||||
# be passed from ::*, although it can be global to a module
|
||||
my $argument; # standard for package name
|
||||
my $save; #for pager
|
||||
|
||||
# Globals related to -xyz
|
||||
my @stuff; # for -g & x
|
||||
my @PACKAGES; # a replacement for @ARGV
|
||||
my @arg_holder; # helps in tricky situations -> -qxl|d
|
||||
my $file_now; # defined flag for -qlcx & -qglx for file()
|
||||
$arg_count = 0; # helps in tricky situations
|
||||
my $aptor_group; # helps when -z is called for groups
|
||||
|
||||
# Swim's version
|
||||
$swim_version = "0.3.6";
|
||||
|
||||
1;
|
||||
73
SWIM/Groups.pm
Normal file
73
SWIM/Groups.pm
Normal file
@ -0,0 +1,73 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Groups;
|
||||
use strict;
|
||||
use SWIM::DB_Library qw(:Groups);
|
||||
use SWIM::Format;
|
||||
use SWIM::Global qw(%gb);
|
||||
use vars qw(@ISA @EXPORT);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(allgroups);
|
||||
|
||||
|
||||
# show all the groups present on this system and exit
|
||||
sub allgroups {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
if (!($commands->{"q"} || $commands->{"query"}) && $commands->{"allgroups"}) {
|
||||
print "swim: --allgroups may only be used during queries\n";
|
||||
exit;
|
||||
}
|
||||
if ($commands->{"q"} && $commands->{"allgroups"}) {
|
||||
$~ = "ALLGROUPS";
|
||||
|
||||
if (!$commands->{"n"}) {
|
||||
gb(\%commands);
|
||||
}
|
||||
else {
|
||||
ngb(\%commands);
|
||||
}
|
||||
|
||||
my @complete = sort keys %gb;
|
||||
my $three = 0;
|
||||
while ($three <= $#complete) {
|
||||
if (defined $complete[$three]) {
|
||||
$ag1 = $complete[$three];
|
||||
}
|
||||
if (defined $complete[$three + 1]) {
|
||||
$ag2 = $complete[$three + 1];
|
||||
}
|
||||
if (defined $complete[$three + 2]) {
|
||||
$ag3 = $complete[$three + 2];
|
||||
}
|
||||
write STDOUT;
|
||||
$ag1 = "";
|
||||
$ag2 = "";
|
||||
$ag3 = "";
|
||||
$three = $three + 3;
|
||||
}
|
||||
exit;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
509
SWIM/Indexer.pm
Normal file
509
SWIM/Indexer.pm
Normal file
@ -0,0 +1,509 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Indexer;
|
||||
use strict;
|
||||
use SWIM::Global;
|
||||
use SWIM::Conf qw($my_number);
|
||||
use SWIM::DB_Library qw(:Xyz ib nib nsb);
|
||||
use SWIM::Info;
|
||||
use SWIM::Pn_print;
|
||||
use SWIM::Deps;
|
||||
use SWIM::Dir;
|
||||
use vars qw(@ISA @EXPORT_OK);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw(indexer);
|
||||
|
||||
|
||||
# The next few subs are provided to shorten indexer
|
||||
# for -d or -l, but not -c when -T
|
||||
sub T_indexer {
|
||||
|
||||
my ($alot,$commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
foreach (@$alot) {
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
# looks o.k.
|
||||
print "$argument\n";
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
if ($commands->{"d"} && !$commands->{"c"}) {
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
file(\%commands);
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
} # end sub T_indexer
|
||||
|
||||
|
||||
sub which_character_indexer {
|
||||
|
||||
my ($alot,$commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
foreach (@$alot) {
|
||||
my %store_commands = %commands;
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
if (the_character(\%commands) ne "ok") {
|
||||
print "$argument\n";
|
||||
}
|
||||
if (defined s_character(\%commands)) {}
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
if ($commands->{"d"} && !$commands->{"c"}) {
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
file(\%commands);
|
||||
}
|
||||
print "\n";
|
||||
%commands = %store_commands;
|
||||
undef %store_commands;
|
||||
}
|
||||
|
||||
} # end sub which_character_indexer
|
||||
|
||||
sub noT_indexer {
|
||||
|
||||
|
||||
my ($alot,$commands) = @_;
|
||||
my %commands = %$commands;
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
|
||||
foreach (@$alot) {
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
if (defined $argument) {
|
||||
# should be o.k., almost everything has documentation
|
||||
print "$argument\n";
|
||||
}
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
file(\%commands);
|
||||
if ($commands->{"d"} && !$commands->{"T"} && !which_character(\%commands)) {
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
|
||||
} # end sub noT_indexer
|
||||
|
||||
# different enough from noT_indexer, used when -c,-d,-l aren't called.
|
||||
sub nonoT_indexer {
|
||||
|
||||
my ($alot,$commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
foreach (@$alot) {
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
# package name will print out even if there is no script
|
||||
# definitely useful here
|
||||
singular(\%commands);
|
||||
if ($commands->{"scripts"}) {
|
||||
print "\n";
|
||||
}
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
}
|
||||
|
||||
|
||||
} # end sub nonoT_indexer
|
||||
|
||||
|
||||
# when -c is called with or without -l or -d. This sub got rather huge.
|
||||
sub c_indexer {
|
||||
|
||||
my ($alot,$commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my $arg_save;
|
||||
require SWIM::File;
|
||||
SWIM::File->import(qw(file));
|
||||
|
||||
foreach (@$alot) {
|
||||
$argument = $_;
|
||||
if (conf(\%commands) ne 0) {
|
||||
if ($commands->{"T"}) {
|
||||
# covers first argument, but not the rest.
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
print "$argument\n";
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
print conf(\%commands) if !$commands->{"md5sum"};
|
||||
file(\%commands);
|
||||
#file(\%commands) if $commands->{"md5sum"};
|
||||
if (($commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"}))) {
|
||||
print "\n";
|
||||
}
|
||||
$arg_save = $argument;
|
||||
} # end "T"
|
||||
|
||||
elsif (which_character(\%commands)) {
|
||||
my %store_commands = %commands;
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
if (the_character(\%commands) ne "ok") {
|
||||
print "$argument\n";
|
||||
}
|
||||
if (defined s_character(\%commands)) {}
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
print conf(\%commands) if !$commands->{"md5sum"};
|
||||
file(\%commands);
|
||||
#file(\%commands) if $commands->{"md5sum"};
|
||||
if (($commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"}))) {
|
||||
print "\n";
|
||||
}
|
||||
%commands = %store_commands;
|
||||
undef %store_commands;
|
||||
$arg_save = $argument;
|
||||
}
|
||||
|
||||
# no Ts.
|
||||
else {
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
print "$argument\n";
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
print conf(\%commands) if !$commands->{"md5sum"};
|
||||
file(\%commands);
|
||||
print "\n";
|
||||
}
|
||||
$arg_save = $argument;
|
||||
} # end if (conf(\%commands)
|
||||
|
||||
# this spot here can determine whether or not -c overrides l&d
|
||||
# in packages which don't have conf files. it's nicer to view
|
||||
# everything. watch this..these are packages which don't have
|
||||
# conf files
|
||||
if ($commands->{"d"} || $commands->{"l"}) {
|
||||
if (defined $arg_save) {
|
||||
if ($argument ne $arg_save) {
|
||||
#if (!defined $arg_save) {
|
||||
if (conf(\%commands) ne 0) {
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
file(\%commands);
|
||||
print "\n";
|
||||
}
|
||||
|
||||
# no conf files
|
||||
elsif (conf(\%commands) eq 0) {
|
||||
if ($commands->{"T"}) {
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
print "$argument\n";
|
||||
character(\%commands);
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
file(\%commands) if $commands->{"md5sum"};
|
||||
print "\n";
|
||||
} # end "T"
|
||||
|
||||
elsif (which_character(\%commands)) {
|
||||
my %store_commands = %commands;
|
||||
$argument = $_;
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
if (the_character(\%commands) ne "ok") {
|
||||
print "$argument\n";
|
||||
}
|
||||
if (defined s_character(\%commands)) {}
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
%commands = %store_commands;
|
||||
undef %store_commands;
|
||||
file(\%commands);
|
||||
print "\n";
|
||||
}
|
||||
|
||||
# no Ts.
|
||||
else {
|
||||
if ($commands->{"scripts"} || $commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"}) {
|
||||
scripts(\%commands);
|
||||
}
|
||||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"};
|
||||
copyright(\%commands) if $commands->{"copyright"};
|
||||
changelog(\%commands) if $commands->{"changelog"};
|
||||
singular(\%commands);
|
||||
if ($commands->{"scripts"}) {
|
||||
print "\n";
|
||||
}
|
||||
shlibs(\%commands) if $commands->{"shlibs"};
|
||||
file(\%commands);
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} # end if ($commands->{"d"} ||
|
||||
} # end foreach
|
||||
|
||||
} # end sub c_indexer
|
||||
|
||||
|
||||
# handles -qf by itself or with -l(-d)&-c or -d by itself, and -qa by itself
|
||||
# or with -c with -d and/or -l ...essentially not -i. <file> is the
|
||||
# argument And ofcourse -T or singular capabilities.
|
||||
sub indexer {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my @alot;
|
||||
|
||||
|
||||
if (!$commands->{"n"}) {
|
||||
ib(\%commands);
|
||||
}
|
||||
else {
|
||||
my $return = nib(\%commands);
|
||||
if (!defined $return && $commands->{"a"}) {
|
||||
untie %ib;
|
||||
nsb(\%commands);
|
||||
$ib{"/."} = $nsb{"/."};
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $argument) {
|
||||
dir(\%commands);
|
||||
fir(\%commands);
|
||||
if ($ib{"$argument"}){
|
||||
my $package = $ib{"$argument"};
|
||||
$package =~ s/\s/\n/g;
|
||||
@alot = split(/\s/, $package);
|
||||
if (defined @alot) {
|
||||
@PACKAGES = @alot;
|
||||
}
|
||||
if ($commands->{"z"} || $commands->{"ftp"}||
|
||||
$commands->{"remove"} || $commands->{"r"} ||
|
||||
$commands->{"purge"}) {
|
||||
require SWIM::Safex;
|
||||
SWIM::Safex->import(qw(safex));
|
||||
safex(\%commands);
|
||||
}
|
||||
|
||||
|
||||
@alot = @PACKAGES;
|
||||
if ($commands->{"total"} || $commands->{"t"}) {
|
||||
# The whole reason for the complicated if/elsif/else routines
|
||||
# below is to allow simultaneous printing of -c & -d|-l. Other
|
||||
# options can just be included within.
|
||||
|
||||
###########
|
||||
# -D & -t #
|
||||
###########
|
||||
if ($commands->{"d"} && !$commands->{"c"}) {
|
||||
if ($commands->{"T"}) {
|
||||
T_indexer(\@alot,\%commands);
|
||||
}
|
||||
elsif (which_character(\%commands)) {
|
||||
which_character_indexer(\@alot,\%commands);
|
||||
}
|
||||
# no -Ts.
|
||||
noT_indexer(\@alot,\%commands);
|
||||
}
|
||||
|
||||
#######################
|
||||
# -t BUT NOT -C,-D,-L #
|
||||
#######################
|
||||
elsif (!$commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"})) {
|
||||
if ($commands->{"T"}) {
|
||||
T_indexer(\@alot,\%commands);
|
||||
}
|
||||
elsif (which_character(\%commands)) {
|
||||
which_character_indexer(\@alot,\%commands);
|
||||
}
|
||||
# humm smail is missing mysteriously, like it never became part
|
||||
# of /.., basically, fastswim isn't placing it in long.debian.
|
||||
# no -Ts.
|
||||
else {
|
||||
nonoT_indexer(\@alot,\%commands);
|
||||
}
|
||||
}
|
||||
|
||||
#####################
|
||||
# -t -C &| -D || -L #
|
||||
#####################
|
||||
# conf stuf. Will only show stuff related to -a or -f with conf.
|
||||
elsif (($commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"})) ||
|
||||
($commands->{"c"} && ($commands->{"d"} || $commands->{"l"}))) {
|
||||
c_indexer(\@alot,\%commands);
|
||||
} # end elsif
|
||||
}
|
||||
|
||||
#########################
|
||||
# > NUMBER FOR -t #
|
||||
##########################
|
||||
elsif ($#ARGV > $my_number) {
|
||||
my $total = $#ARGV + 1;
|
||||
print "use --total or -t to see all $total packages\n";
|
||||
exit;
|
||||
}
|
||||
elsif ($#alot > $my_number) {
|
||||
my $total = $#alot + 1;
|
||||
print "use --total or -t to see all $total packages\n";
|
||||
}
|
||||
|
||||
# without -t
|
||||
else {
|
||||
|
||||
######
|
||||
# -D #
|
||||
######
|
||||
if ($commands->{"d"} && !$commands->{"c"}) {
|
||||
if ($commands->{"T"}) {
|
||||
T_indexer(\@alot,\%commands);
|
||||
}
|
||||
elsif (which_character(\%commands)) {
|
||||
which_character_indexer(\@alot,\%commands);
|
||||
}
|
||||
# the noties
|
||||
noT_indexer(\@alot,\%commands);
|
||||
}
|
||||
|
||||
################
|
||||
# NOT -C,-D,-L #
|
||||
################
|
||||
elsif (!$commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"})) {
|
||||
if ($commands->{"T"}) {
|
||||
T_indexer(\@alot,\%commands);
|
||||
}
|
||||
elsif (which_character(\%commands)) {
|
||||
which_character_indexer(\@alot,\%commands);
|
||||
}
|
||||
else {
|
||||
nonoT_indexer(\@alot,\%commands);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
##################
|
||||
# -C &| -D || -L #
|
||||
##################
|
||||
# conf stuf. Will only show stuff related to -a or -f with conf.
|
||||
elsif (($commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"})) ||
|
||||
($commands->{"c"} && ($commands->{"d"} || $commands->{"l"}))) {
|
||||
c_indexer(\@alot,\%commands);
|
||||
}
|
||||
|
||||
} # without -t
|
||||
}
|
||||
else {
|
||||
$argument =~ m,.*\/(.*$),;
|
||||
if (defined $1) {
|
||||
my $file = $1;
|
||||
if (!$commands->{"n"} && -e "/usr/sbin/update-alternatives") {
|
||||
my $it = "update-alternatives --display $1|";
|
||||
open (IT,"$it") or exit;
|
||||
if (<IT> =~ /No alternatives/) {
|
||||
print "file $file is not owned by any package\n";
|
||||
}
|
||||
else {
|
||||
my @LINES = <IT>;
|
||||
print "For $argument ->\n";
|
||||
$LINES[0] =~ m,(/.*$),; $argument = $1;
|
||||
print "@LINES\n"; indexer(\%commands);
|
||||
}
|
||||
}
|
||||
else {
|
||||
print "file $file is not owned by any package\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
untie %ib;
|
||||
|
||||
if (defined @alot) {
|
||||
@PACKAGES = @alot;
|
||||
}
|
||||
if (!($commands->{"z"} || $commands->{"ftp"} ||
|
||||
$commands->{"remove"} || $commands->{"r"} ||
|
||||
$commands->{"purge"})) {
|
||||
if ($commands->{"x"} || $commands->{"ftp"} || $commands->{"source"} ||
|
||||
$commands->{"source_only"} || $commands->{"remove"} ||
|
||||
$commands->{"r"} || $commands->{"purge"}) {
|
||||
require SWIM::Safex;
|
||||
SWIM::Safex->import(qw(safex));
|
||||
safex(\%commands);
|
||||
}
|
||||
}
|
||||
|
||||
} # end sub indexer
|
||||
|
||||
|
||||
1;
|
||||
586
SWIM/Info.pm
Normal file
586
SWIM/Info.pm
Normal file
@ -0,0 +1,586 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Info;
|
||||
use strict;
|
||||
use SWIM::Conf qw(:Info);
|
||||
use SWIM::Global qw(:Info);
|
||||
use SWIM::DB_Library qw(:Xyz);
|
||||
use vars qw(@ISA @EXPORT);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(scripts copyright changelog menu conf shlibs);
|
||||
|
||||
# scripts() copyright() changelog() menu() conf() shlibs()
|
||||
# the text stuff taken out of info for the installed system, though the
|
||||
# not-installed system in checked for, just in case.
|
||||
|
||||
# This shows all the scripts identified with a package(s). In certain
|
||||
# cases it is valuable to print a script without the name of the package,
|
||||
# so if --scripts, -a, or -t isn't called, the pure script will be
|
||||
# presented.
|
||||
sub scripts {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my ($file, $preinst, $postinst, $prerm,
|
||||
$postrm, $orig_argument);
|
||||
|
||||
|
||||
if ($commands->{"n"}) {
|
||||
print "swim: no scripts for not-installed, consider --diff\n"; exit;
|
||||
}
|
||||
|
||||
dbi(\%commands);
|
||||
|
||||
if ($argument =~ /_/) {
|
||||
$orig_argument = $argument;
|
||||
my $check = $db{"$argument"};
|
||||
$argument =~ m,(^.*)_(.*$),;
|
||||
if (defined $check) {
|
||||
$argument = $1;
|
||||
}
|
||||
else {};
|
||||
}
|
||||
untie %db;
|
||||
|
||||
|
||||
# here we will print out whatever we find including the file name.
|
||||
if ($commands->{"scripts"} && !($commands->{"preinst"} ||
|
||||
$commands->{"postinst"} || $commands->{"prerm"} ||
|
||||
$commands->{"postrm"})) {
|
||||
if (defined "$parent$base/info/$argument.preinst") {
|
||||
$preinst = "$parent$base/info/$argument.preinst";
|
||||
}
|
||||
if (defined "$parent$base/info/$argument.postinst") {
|
||||
$postinst = "$parent$base/info/$argument.postinst";
|
||||
}
|
||||
if (defined "$parent$base/info/$argument.prerm") {
|
||||
$prerm = "$parent$base/info/$argument.prerm";
|
||||
}
|
||||
if (defined "$parent$base/info/$argument.postrm") {
|
||||
$postrm = "$parent$base/info/$argument.postrm";
|
||||
}
|
||||
|
||||
if (-e $preinst) {
|
||||
print "#####$argument.preinst#####\n\n";
|
||||
open (LIST,"$preinst");
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
if (-e $postinst) {
|
||||
print "#####$argument.postinst#####\n\n";
|
||||
open (LIST,"$postinst");
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
if (-e $prerm) {
|
||||
open (LIST,"$prerm");
|
||||
print "#####$argument.prerm#####\n\n";
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
if (-e $postrm) {
|
||||
open (LIST,"$postrm");
|
||||
print "#####$argument.postrm#####\n\n";
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
} # if scripts
|
||||
|
||||
|
||||
# from here on we just print out the particular script(s) called
|
||||
# literally with no filename, unless -a or -t is called. This is one
|
||||
# situation in which -t has a use apart from the global default. A
|
||||
|
||||
# title is printed out for singular scripts in this case.
|
||||
|
||||
if ($commands->{"preinst"}) {
|
||||
if (defined "$parent$base/info/$argument.preinst") {
|
||||
$preinst = "$parent$base/info/$argument.preinst";
|
||||
}
|
||||
if (-e $preinst) {
|
||||
if ($commands->{"a"} || $commands->{"t"}) {
|
||||
print "#####$argument.preinst#####\n\n";
|
||||
open (LIST,"$preinst");
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
open (LIST,"$preinst");
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($commands->{"postinst"}) {
|
||||
if (defined "$parent$base/info/$argument.postinst") {
|
||||
$postinst = "$parent$base/info/$argument.postinst";
|
||||
}
|
||||
if (-e $postinst) {
|
||||
if ($commands->{"a"} || $commands->{"t"}) {
|
||||
print "#####$argument.postinst#####\n\n";
|
||||
open (LIST,"$postinst");
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
open (LIST,"$postinst");
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($commands->{"prerm"}) {
|
||||
if (defined "$parent$base/info/$argument.prerm") {
|
||||
$prerm = "$parent$base/info/$argument.prerm";
|
||||
}
|
||||
if (-e $prerm) {
|
||||
if ($commands->{"a"} || $commands->{"t"}) {
|
||||
print "#####$argument.prerm#####\n\n";
|
||||
open (LIST,"$prerm");
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
open (LIST,"$prerm");
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($commands->{"postrm"}) {
|
||||
if (defined "$parent$base/info/$argument.postrm") {
|
||||
$postrm = "$parent$base/info/$argument.postrm";
|
||||
}
|
||||
if (-e $postrm) {
|
||||
if ($commands->{"a"} || $commands->{"t"}) {
|
||||
print "#####$argument.postrm#####\n\n";
|
||||
open (LIST,"$postrm");
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
open (LIST,"$postrm");
|
||||
while (<LIST>) {
|
||||
print $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (!$commands->{"i"}) {
|
||||
if (defined $orig_argument) {
|
||||
$argument = $orig_argument;
|
||||
}
|
||||
}
|
||||
|
||||
} # end sub scripts
|
||||
|
||||
# show the scripts for /usr/lib/menu
|
||||
sub menu {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my $filelist;
|
||||
my $orig_argument = $argument;
|
||||
my %parent;
|
||||
|
||||
if ($commands->{"n"}) {
|
||||
print "swim: no menu for not-installed, consider --diff\n"; exit;
|
||||
}
|
||||
|
||||
dbi(\%commands);
|
||||
|
||||
|
||||
if ($argument =~ /_/) {
|
||||
$orig_argument = $argument;
|
||||
my $check = $db{"$argument"};
|
||||
$argument =~ m,(^.*)_(.*$),;
|
||||
if (defined $check) {
|
||||
$argument = $1;
|
||||
}
|
||||
else {};
|
||||
}
|
||||
untie %db;
|
||||
|
||||
if (defined $argument) {
|
||||
if (-e "$parent$base/info/$argument.list") {
|
||||
$filelist = "$parent$base/info/$argument.list";
|
||||
}
|
||||
if (defined $filelist) {
|
||||
# basically, re-find file/package passed to previous sub
|
||||
open(FINDMENU,"$filelist");
|
||||
while (<FINDMENU>) {
|
||||
chomp;
|
||||
if (m,^\/usr\/lib\/menu\/(.*(\w-\+\.)),) {
|
||||
if (!-d) {
|
||||
print "#####menu for $orig_argument($1)#####\n";
|
||||
open(MENU,"$_");
|
||||
while (<MENU>) {
|
||||
print;
|
||||
}
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
close(FINDMENU);
|
||||
close(MENU);
|
||||
}
|
||||
} # defined
|
||||
|
||||
if (!$commands->{"i"}) {
|
||||
$argument = $orig_argument;
|
||||
}
|
||||
|
||||
} # end sub menu
|
||||
|
||||
|
||||
# Show changelog, default zcat. This will show all the changelogs in
|
||||
# the directory /usr/doc/package_name/, there are cases where there is
|
||||
# a debian.changelog and one provided by the individual(s) working on the
|
||||
# software, as well as a variety of other cases.
|
||||
sub changelog {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my $file;
|
||||
my $orig_argument = $argument;
|
||||
|
||||
if ($commands->{"n"}) {
|
||||
print "swim: no changelog for not-installed, consider --diff\n"; exit;
|
||||
}
|
||||
|
||||
dbi(\%commands);
|
||||
|
||||
if ($argument =~ /_/) {
|
||||
$orig_argument = $argument;
|
||||
my $check = $db{"$argument"};
|
||||
$argument =~ m,(^.*)_(.*$),;
|
||||
if (defined $check) {
|
||||
$argument = $1;
|
||||
}
|
||||
else {};
|
||||
}
|
||||
untie %db;
|
||||
|
||||
|
||||
# Using swim -qadt | grep -i change it looks like all the files which
|
||||
# have change in their name are changelogs when in /usr/doc/$argument,
|
||||
# sometimes there are more above, but these are the most significant.
|
||||
my @fsstnd;
|
||||
if (-e "$parent/usr/doc/$argument" &&
|
||||
-d "$parent/usr/doc/$argument") {
|
||||
my $directory = "$parent/usr/doc/$argument";
|
||||
opendir(CHANGE, "$directory") || die "I thought it existed";
|
||||
my @change = sort grep(/change/i, readdir(CHANGE));
|
||||
closedir(CHANGE);
|
||||
foreach (@change) {
|
||||
if (m,\.gz$,i) {
|
||||
push(@fsstnd,$_);
|
||||
print "#####$_ for $argument#####\n\n";
|
||||
open(ZCAT,"|$zcat") || die "swim: this option requires zcat";
|
||||
open(CHANGELOG, "$directory/$_");
|
||||
while (<CHANGELOG>) {
|
||||
print ZCAT $_;
|
||||
}
|
||||
close(ZCAT);
|
||||
close(CHANGELOG);
|
||||
print "\n";
|
||||
}
|
||||
elsif ($_ !~ m,html$|htm$|ps$|dvi$|sgml$|gs$,) {
|
||||
push(@fsstnd,$_);
|
||||
print "#####$_ for $argument#####\n\n";
|
||||
open(CHANGELOG, "$directory/$_");
|
||||
while (<CHANGELOG>) {
|
||||
print "$_";
|
||||
}
|
||||
close(CHANGELOG);
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if (-e "$parent/usr/share/doc/$argument" &&
|
||||
-d "$parent/usr/share/doc/$argument") {
|
||||
my $directory = "$parent/usr/share/doc/$argument";
|
||||
opendir(CHANGE, "$directory") || die "I thought it existed";
|
||||
my @change = sort grep(/change/i, readdir(CHANGE));
|
||||
closedir(CHANGE);
|
||||
foreach (@change) {
|
||||
if (m,\.gz$,i) {
|
||||
my $cf = grep(m,^$_$,,@fsstnd);
|
||||
if ($cf == 0 ) {
|
||||
print "#####$_ for $argument#####\n\n";
|
||||
open(ZCAT,"|$zcat") || die "swim: this option requires zcat";
|
||||
open(CHANGELOG, "$directory/$_");
|
||||
while (<CHANGELOG>) {
|
||||
print ZCAT $_;
|
||||
}
|
||||
close(ZCAT);
|
||||
close(CHANGELOG);
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
elsif ($_ !~ m,html$|htm$|ps$|dvi$|sgml$|gs$,) {
|
||||
my $cf = grep(m,^$_$,,@fsstnd);
|
||||
if ($cf == 0 ) {
|
||||
print "#####$_ for $argument#####\n\n";
|
||||
open(CHANGELOG, "$directory/$_");
|
||||
while (<CHANGELOG>) {
|
||||
print "$_";
|
||||
}
|
||||
close(CHANGELOG);
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (!$commands->{"i"}) {
|
||||
$argument = $orig_argument;
|
||||
}
|
||||
|
||||
} # end sub changelog
|
||||
|
||||
# Show copyright, default zcat. This will show all the copyrights in
|
||||
# the directory /usr/doc/package_name/. Rather than passing the
|
||||
# greped argument to changelog(), this subroutine was created instead which
|
||||
# keeps things sensible.
|
||||
sub copyright {
|
||||
|
||||
my $file;
|
||||
my $orig_argument = $argument;
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
|
||||
if ($commands->{"n"}) {
|
||||
print "swim: no copyright for not-installed, consider --diff\n"; exit;
|
||||
}
|
||||
|
||||
dbi(\%commands);
|
||||
|
||||
|
||||
if ($argument =~ /_/) {
|
||||
$orig_argument = $argument;
|
||||
my $check = $db{"$argument"};
|
||||
$argument =~ m,(^.*)_(.*$),;
|
||||
if (defined $check) {
|
||||
$argument = $1;
|
||||
}
|
||||
else {};
|
||||
}
|
||||
untie %db;
|
||||
|
||||
|
||||
# Using swim -qadt | grep -i copy it looks like all the files which
|
||||
# have copy in their name are generally copyrights when in
|
||||
# /usr/doc/$argument, sometimes there are more above, but these are
|
||||
# the most significant.
|
||||
my @fsstnd;
|
||||
if (-e "$parent/usr/doc/$argument" &&
|
||||
-d "$parent/usr/doc/$argument") {
|
||||
my $directory = "$parent/usr/doc/$argument";
|
||||
opendir(CHANGE, "$directory") || die "I thought it existed";
|
||||
my @change = sort grep(/copy|license/i, readdir(CHANGE));
|
||||
closedir(CHANGE);
|
||||
foreach (@change) {
|
||||
if (defined $_) {
|
||||
if (m,\.gz$,i) {
|
||||
push(@fsstnd,$_);
|
||||
print "#####$_ for $orig_argument#####\n\n";
|
||||
open(ZCAT,"|$zcat") || die "swim: this option requires zcat";
|
||||
open(COPYRIGHT, "$directory/$_");
|
||||
while (<COPYRIGHT>) {
|
||||
print ZCAT $_;
|
||||
}
|
||||
# Sometimes these next two mysteriously open, and don't close
|
||||
# even when no previous gz file was found, causing error output,
|
||||
# but doesn't effect what's trying to be accomplished. Doesn't
|
||||
# happen with changelog().
|
||||
close(ZCAT);
|
||||
close(COPYRIGHT);
|
||||
print "\n";
|
||||
}
|
||||
elsif ($_ !~ m,html$|htm$|ps$|dvi$|sgml$|gs$,) {
|
||||
push(@fsstnd,$_);
|
||||
print "#####$_ for $orig_argument#####\n\n";
|
||||
open(COPYRIGHT, "$directory/$_");
|
||||
while (<COPYRIGHT>) {
|
||||
print "$_";
|
||||
}
|
||||
close(COPYRIGHT);
|
||||
print "\n";
|
||||
}
|
||||
} # if defined
|
||||
}
|
||||
}
|
||||
|
||||
if (-e "$parent/usr/share/doc/$argument" &&
|
||||
-d "$parent/usr/share/doc/$argument") {
|
||||
my $directory = "$parent/usr/share/doc/$argument";
|
||||
opendir(CHANGE, "$directory") || die "I thought it existed";
|
||||
my @change = sort grep(/copy|license/i, readdir(CHANGE));
|
||||
closedir(CHANGE);
|
||||
foreach (@change) {
|
||||
if (defined $_) {
|
||||
if (m,\.gz$,i) {
|
||||
my $cf = grep(m,^$_$,,@fsstnd);
|
||||
if ($cf == 0 ) {
|
||||
print "#####$_ for $orig_argument#####\n\n";
|
||||
open(ZCAT,"|$zcat") || die "swim: this option requires zcat";
|
||||
open(COPYRIGHT, "$directory/$_");
|
||||
while (<COPYRIGHT>) {
|
||||
print ZCAT $_;
|
||||
}
|
||||
# Sometimes these next two mysteriously open, and don't close
|
||||
# even when no previous gz file was found, causing error output,
|
||||
# but doesn't effect what's trying to be accomplished. Doesn't
|
||||
# happen with changelog().
|
||||
close(ZCAT);
|
||||
close(COPYRIGHT);
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
elsif ($_ !~ m,html$|htm$|ps$|dvi$|sgml$|gs$,) {
|
||||
my $cf = grep(m,^$_$,,@fsstnd);
|
||||
if ($cf == 0 ) {
|
||||
print "#####$_ for $orig_argument#####\n\n";
|
||||
open(COPYRIGHT, "$directory/$_");
|
||||
while (<COPYRIGHT>) {
|
||||
print "$_";
|
||||
}
|
||||
close(COPYRIGHT);
|
||||
print "\n";
|
||||
}
|
||||
}
|
||||
} # if defined
|
||||
}
|
||||
}
|
||||
|
||||
if (!$commands->{"i"}) {
|
||||
$argument = $orig_argument;
|
||||
}
|
||||
|
||||
} # end copyright
|
||||
|
||||
# process the database for the configuration files
|
||||
sub conf {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
# added for -xyz, but not necessary
|
||||
if (defined $argument) {
|
||||
if ($argument !~ /_/) {
|
||||
if (defined $db{$argument}) {
|
||||
$argument = $db{$argument};
|
||||
}
|
||||
}
|
||||
}
|
||||
if (!$commands->{"n"}) {
|
||||
dbi(\%commands);
|
||||
}
|
||||
else {}
|
||||
if (defined $argument) {
|
||||
my $conf = $argument . "CONF";
|
||||
if (defined $db{$conf}) {
|
||||
return $db{$conf};
|
||||
}
|
||||
else { return 0; }
|
||||
}
|
||||
untie %db;
|
||||
} # end sub conf
|
||||
|
||||
# shared libraries provided by the package
|
||||
sub shlibs {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my $shlibs;
|
||||
my $orig_argument;
|
||||
|
||||
if ($commands->{"n"}) {
|
||||
print "catswim: no shlibs for not-installed, consider --diff\n"; exit;
|
||||
}
|
||||
|
||||
|
||||
dbi(\%commands);
|
||||
|
||||
if (defined $argument) {
|
||||
if ($argument =~ /_/) {
|
||||
$orig_argument = $argument;
|
||||
my $check;
|
||||
if (defined $db{"$argument"}) {
|
||||
$check = $db{"$argument"};
|
||||
}
|
||||
$argument =~ m,(^.*)_(.*$),;
|
||||
if (defined $check) {
|
||||
$argument = $1;
|
||||
}
|
||||
else {}
|
||||
}
|
||||
else {
|
||||
$orig_argument = $argument;
|
||||
}
|
||||
}
|
||||
untie %db;
|
||||
|
||||
if (defined $argument) {
|
||||
if (-e "$parent$base/info/$argument.shlibs") {
|
||||
$shlibs = "$parent$base/info/$argument.shlibs";
|
||||
}
|
||||
}
|
||||
|
||||
if (defined $shlibs) {
|
||||
print "Shlibs:\n";
|
||||
open(SHLIBS,"$shlibs");
|
||||
while (<SHLIBS>) {
|
||||
if ($_ !~ m,^\n$,) {
|
||||
print;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$argument = $orig_argument;
|
||||
|
||||
} # end sub shlibs
|
||||
|
||||
|
||||
1;
|
||||
144
SWIM/Library.pm
Normal file
144
SWIM/Library.pm
Normal file
@ -0,0 +1,144 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Library;
|
||||
use strict;
|
||||
use SWIM::Conf;
|
||||
use SWIM::Global;
|
||||
use vars qw(@ISA @EXPORT);
|
||||
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(which_archdist finddb root compress_contents);
|
||||
|
||||
|
||||
# functions which do not use DB_File which_archdist() finddb() root()
|
||||
|
||||
# which archictecture and distribution does this database involve
|
||||
sub which_archdist {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
my ($arch,$dist);
|
||||
#if ($commands->{"initndb"} || $commands->{"rebuildndb"}) {
|
||||
if ($commands->{"arch"}) {
|
||||
$arch = "-" . $commands->{"arch"};
|
||||
}
|
||||
else {
|
||||
$arch = "-$architecture";
|
||||
}
|
||||
|
||||
if ($commands->{"dists"}) {
|
||||
$dist = "-" . $commands->{"dists"};
|
||||
}
|
||||
else {
|
||||
$dist = "-$distribution";
|
||||
}
|
||||
return ($arch,$dist);
|
||||
# }
|
||||
|
||||
} # end sub which_archdist
|
||||
|
||||
|
||||
# finding any database
|
||||
sub finddb {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
my $fileplace;
|
||||
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$fileplace = "$parent$library";
|
||||
return $fileplace;
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$fileplace = "$parent$base";
|
||||
return $fileplace;
|
||||
}
|
||||
|
||||
} # end sub finddb
|
||||
|
||||
# This gives the option to be able to used -d & -l, but not -f, by only
|
||||
# copying Contents over to contentsindex*.deb.gz. This the fast way.
|
||||
sub compress_contents {
|
||||
|
||||
my ($Contents,$commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my $contentsdb = finddb(\%commands);
|
||||
my($arch,$dist) = which_archdist(\%commands);
|
||||
my $contentsindex = "$contentsdb/ncontentsindex$arch$dist.deb";
|
||||
my ($contentsindexgz, $mtime);
|
||||
if (-e "$contentsdb/ncontentsindex$arch$dist.deb.gz") {
|
||||
$contentsindexgz = "$contentsdb/ncontentsindex$arch$dist.deb.gz";
|
||||
$mtime = (stat("$contentsindexgz"))[9];
|
||||
}
|
||||
else {
|
||||
$contentsindexgz = "$contentsdb/ncontentsindex$arch$dist.deb.gz";
|
||||
}
|
||||
|
||||
my $ex;
|
||||
my $Contents_mtime = (stat("$Contents"))[9];
|
||||
my $BContents = $Contents;
|
||||
$Contents = -B $Contents || $Contents =~ m,\.(gz|Z)$, ?
|
||||
"$gzip -dc $Contents|" : "cat $Contents|";
|
||||
if (defined $mtime) {
|
||||
if ($mtime == $Contents_mtime) {
|
||||
print "Same Contents files, won't compress\n";
|
||||
exit if !$commands->{"ndb"};
|
||||
$ex = "stop";
|
||||
}
|
||||
else {
|
||||
unlink($contentsindexgz);
|
||||
}
|
||||
}
|
||||
if (!defined $ex) {
|
||||
print "Copying new Contents\n";
|
||||
#system $copy, $BContents, $contentsindexgz;
|
||||
|
||||
# changed for >= 0.2.9
|
||||
# changed again >= 0.3.4
|
||||
open(CONTENTS, "$Contents") or die "where is it?\n";
|
||||
open(CONTENTSDB,">$contentsindex");
|
||||
while (<CONTENTS>) {
|
||||
##if (/^FILE\s*LOCATION$/) {
|
||||
##while (<CONTENTS>) {
|
||||
s,^(\./)+,,; # filter for Debians altered dir structure
|
||||
print CONTENTSDB $_;
|
||||
##}
|
||||
##}
|
||||
}
|
||||
print "Compressing Contents\n";
|
||||
# added -f just in case
|
||||
system "$gzip", "-f", "-9", "$contentsindex";
|
||||
utime(time,$Contents_mtime,$contentsindexgz);
|
||||
}
|
||||
|
||||
} # end sub compress_contents
|
||||
|
||||
# for / files
|
||||
sub root {
|
||||
|
||||
if ($argument eq "/") {
|
||||
$argument = "/.";
|
||||
}
|
||||
} # end sub root
|
||||
|
||||
|
||||
1;
|
||||
268
SWIM/MD.pm
Normal file
268
SWIM/MD.pm
Normal file
@ -0,0 +1,268 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::MD;
|
||||
use strict;
|
||||
use SWIM::Conf qw(:Path $splt);
|
||||
use SWIM::DB_Library qw(:Md);
|
||||
use SWIM::Library;
|
||||
use SWIM::Global;
|
||||
use vars qw(@ISA @EXPORT %EXPORT_TAGS);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(process_md);
|
||||
|
||||
# process_md used by both SWIM::DB_Init and SWIM::NDB_Init
|
||||
|
||||
=pod
|
||||
|
||||
Because many files and directories exist more than once, and it would be
|
||||
kind of cool to go up to a directory /usr/bin or /usr/bin/ and do a
|
||||
swim -qf and see all the packages that populate that directory...
|
||||
multi-dimensional is the way to go.
|
||||
|
||||
=cut
|
||||
|
||||
sub process_md {
|
||||
|
||||
print "File Database is being made\n";
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my @ppackage;
|
||||
my %md;
|
||||
my @md;
|
||||
my @mi;
|
||||
my $thingy;
|
||||
my @name;
|
||||
my $count = 0;
|
||||
my $count1 = 1;
|
||||
|
||||
my($place) = finddb(\%commands);
|
||||
|
||||
# Let's determine what architecture and distribution this person is
|
||||
# interested in.
|
||||
my ($arch, $dist, $not);
|
||||
if ($commands->{"initndb"} || $commands->{"rebuildndb"}) {
|
||||
($arch,$dist) = which_archdist(\%commands);
|
||||
$not = "n";
|
||||
}
|
||||
else {
|
||||
$arch = "";
|
||||
$dist = "";
|
||||
$not = "";
|
||||
}
|
||||
my $fileindex = $not . "fileindex";
|
||||
|
||||
|
||||
# Now we process the files made from the massive array, and create
|
||||
# fileindex.deb or nfileindex.deb
|
||||
# Let's just use split, and will allow for customized line adj.
|
||||
# 25000 is the default
|
||||
if ($commands->{"split_data"}) {
|
||||
my $split = $commands->{"split_data"};
|
||||
system("$splt -l $split $tmp/big.debian $tmp/DEBIAN");
|
||||
}
|
||||
else {
|
||||
# Seems like a good default
|
||||
system("$splt -l 25000 $tmp/big.debian $tmp/DEBIAN");
|
||||
}
|
||||
@ppackage = <$tmp/DEBIAN*>;
|
||||
# It's unlikely this file will ever get too massive.
|
||||
push(@ppackage, "$tmp/long.debian");
|
||||
print " Create the database\n";
|
||||
foreach $thingy (@ppackage) {
|
||||
open(PARTS, "$thingy");
|
||||
while (<PARTS>) {
|
||||
my @c;
|
||||
@md = split(/ -> /,$_);
|
||||
if (defined($md[1])) {
|
||||
chomp $md[0];
|
||||
chomp $md[1];
|
||||
@c = split(/\s/, $md[1]);
|
||||
}
|
||||
push(@mi,$md[0]);
|
||||
push(@mi,$md[1]);
|
||||
} # while
|
||||
print " $thingy\n";
|
||||
print " wait a few seconds\n";
|
||||
my $zing;
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$zing = tie %md, 'DB_File',"$parent$library/$fileindex$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$zing = tie %md, 'DB_File',"$parent$base/$fileindex$arch$dist.deb"
|
||||
or die "DB_File: $!";
|
||||
}
|
||||
while ($count <= $#mi) {
|
||||
$zing->put($mi[$count], $mi[$count1]);
|
||||
$count = $count + 2;
|
||||
$count1 = $count1 + 2;
|
||||
}
|
||||
undef $zing;
|
||||
untie %md;
|
||||
undef %md;
|
||||
@mi = ();
|
||||
@md = ();
|
||||
$count = 0;
|
||||
$count1 = 1;
|
||||
close(PARTS);
|
||||
} # end foreach
|
||||
|
||||
# now we get to take into account deinstall:ok:config-files
|
||||
# situations for an installed system.
|
||||
if ($commands->{"initdb"} || $commands->{"rebuilddb"}) {
|
||||
sb(\%$commands); ib(\%commands); my $yich;
|
||||
foreach (values %sb) {
|
||||
my $zit; my ($nit,$yit) = (split(/\s/,$_))[0,3];
|
||||
if ($yit eq "deinstall:ok:config-files" ||
|
||||
$yit eq "purge:ok:config-files") {
|
||||
($zit = $nit) =~ s,\+,\\\+,;
|
||||
if ($ib{"/."} !~ m,$zit,) {
|
||||
if (!defined $yich) {
|
||||
$yich = $nit;
|
||||
}
|
||||
else {
|
||||
$yich = $yich . " $nit";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
$ib{"/."} = $ib{"/."} . " $yich";
|
||||
}
|
||||
|
||||
# after much experimentation it turns out that a flat text file
|
||||
# is much faster for this particular application. This also
|
||||
# creates the hash database reference for -db or -i.
|
||||
my $searchindex = $not . "searchindex";
|
||||
open(FLATFILE, ">$place/$searchindex$arch$dist.deb");
|
||||
print "Create the powersearch flat database\n";
|
||||
foreach $thingy (@ppackage) {
|
||||
if ($thingy ne "$tmp/long.debian") {
|
||||
open(PARTS, "$thingy");
|
||||
while (<PARTS>) {
|
||||
@md = split(/ -> /,$_);
|
||||
if (defined($md[1])) {
|
||||
chomp $md[0];
|
||||
}
|
||||
push(@mi,$md[0]);
|
||||
} # while
|
||||
}
|
||||
print " $thingy\n";
|
||||
print " wait a few seconds\n";
|
||||
while ($count <= $#mi) {
|
||||
print FLATFILE "$mi[$count]\n";
|
||||
$count++;
|
||||
}
|
||||
$count = 0;
|
||||
@mi = ();
|
||||
@md = ();
|
||||
close(PARTS);
|
||||
} # end foreach
|
||||
close(FLATFILE);
|
||||
|
||||
# This creates the flatfile with the directories for --powersearch
|
||||
# --dir, which is probably a rare match in most cases. This doesn't
|
||||
# create a hash reference database for --db and -i because the only
|
||||
# package which could benifit from this is base-files, but it has
|
||||
# configuaration files, on the other hand RedHat has at least one
|
||||
# package without directories or files, but this is Debian.
|
||||
my $dirindex = $not . "dirindex";
|
||||
open(FLATFILE, ">$place/$dirindex$arch$dist.deb");
|
||||
print "Create the powersearch flat directory database\n";
|
||||
open(PARTS, "$ppackage[$#ppackage]");
|
||||
while (<PARTS>) {
|
||||
@md = split(/ -> /,$_);
|
||||
if (defined($md[1])) {
|
||||
chomp $md[0];
|
||||
}
|
||||
push(@mi,$md[0]);
|
||||
} # while
|
||||
print " $ppackage[$#ppackage]\n";
|
||||
while ($count <= $#mi) {
|
||||
print FLATFILE "$mi[$count]\n";
|
||||
$count++;
|
||||
}
|
||||
$count = 0;
|
||||
@mi = ();
|
||||
@md = ();
|
||||
close(PARTS);
|
||||
close(FLATFILE);
|
||||
|
||||
# compare nstatusindex*.deb to /. from nfileindex*.deb to find out if
|
||||
# any of the packages in Packages weren't represented in the Contents
|
||||
# file. This is different than the earlier report which shows packages
|
||||
# which weren't in Packages but were in Contents. This list is kept,
|
||||
# and used again in a future --ndb run to make the matches, if they
|
||||
# exist.
|
||||
if ($commands->{"initndb"} || $commands->{"rebuildndb"}) {
|
||||
nsb(\%$commands);
|
||||
nzing(\%commands);
|
||||
my @fileindex = split(/\s/,$ib{"/."});
|
||||
my @statusindex = split(/\s/,$nsb{"/."});
|
||||
if ($#fileindex < $#statusindex) {
|
||||
my $place = finddb(\%commands);
|
||||
open(DIFF, ">$place/.packagesdiff$arch$dist.deb")
|
||||
or warn "couldn't create diff file\n";
|
||||
my %uniques;
|
||||
@uniques{@fileindex} = ();
|
||||
foreach (@statusindex) {
|
||||
# no sense putting non-US or experimental in here unless this
|
||||
# is what is wanted. Only need to check for group non-us/*
|
||||
if (!$commands->{"nue"}) {
|
||||
my $name = (split(/_/,$_))[0];
|
||||
if (defined $nsb{$name}) {
|
||||
next if (split(/\s/,$nsb{$name}))[1] =~ m,non-us,;
|
||||
}
|
||||
if ($dist eq "experimental") {
|
||||
next;
|
||||
}
|
||||
}
|
||||
elsif ($dist eq "experimental") {
|
||||
if (!$commands->{"nue"}) {
|
||||
my $name = (split(/_/,$_))[0];
|
||||
if (defined $nsb{$name}) {
|
||||
next if (split(/\s/,$nsb{$name}))[1] =~ m,non-us,;
|
||||
}
|
||||
}
|
||||
}
|
||||
print DIFF "$_\n" unless exists $uniques{$_};
|
||||
}
|
||||
$zing->del("/.");
|
||||
$zing->put("/.",$nsb{"/."});
|
||||
}
|
||||
} # end if
|
||||
|
||||
# Will unlink transfer.deb, big.debian, long.debian.
|
||||
unlink(<$tmp/DEBIAN*>);
|
||||
unlink("$tmp/transfer.deb");
|
||||
unlink("$tmp/big.debian");
|
||||
unlink("$tmp/long.debian");
|
||||
|
||||
|
||||
#!!!
|
||||
print " over and out\n";
|
||||
print scalar(localtime), "\n";
|
||||
|
||||
} # end sub process_md
|
||||
|
||||
|
||||
1;
|
||||
1834
SWIM/NDB.pm
Normal file
1834
SWIM/NDB.pm
Normal file
File diff suppressed because it is too large
Load Diff
251
SWIM/NDB_File.pm
Normal file
251
SWIM/NDB_File.pm
Normal file
@ -0,0 +1,251 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
package SWIM::NDB_File;
|
||||
use strict;
|
||||
use SWIM::DB_Library qw(ram_on); # nzing nsb
|
||||
use SWIM::Library;
|
||||
use SWIM::Global qw($argument); # %ib $zing %nsb
|
||||
use SWIM::Conf qw($pwd $tmp);
|
||||
use SWIM::Dir;
|
||||
use SWIM::Ramdisk;
|
||||
use vars qw(@ISA @EXPORT);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(noram ncontents_exist find_contents remove_add_nfile);
|
||||
|
||||
# This program handles updating nfileindex-arch-dists.deb
|
||||
|
||||
# This checks if the ramdisk is on, we will want to turn it off, if it is.
|
||||
sub noram {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my $ramdisk = ram_on(\%commands);
|
||||
|
||||
if ($ramdisk eq "yes") {
|
||||
my $what = "yes";
|
||||
$commands{"ramdiskoff"} = 1;
|
||||
ramdisk(\%commands);
|
||||
} # if ramdisk
|
||||
|
||||
} # end sub nfile
|
||||
|
||||
# This will set-up the argument for ncontents if it can be found.
|
||||
sub ncontents_exist {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my $contentsdb = finddb(\%commands);
|
||||
my ($arch,$dist) = which_archdist(\%commands);
|
||||
|
||||
|
||||
if (-e "$contentsdb/ncontentsindex$arch$dist.deb.gz") {
|
||||
if (-e "$contentsdb/ndirindex$arch$dist.deb.gz") {
|
||||
unlink("$contentsdb/ndirindex$arch$dist.deb.gz");
|
||||
}
|
||||
if (-e "$contentsdb/nsearchindex$arch$dist.deb.gz") {
|
||||
unlink("$contentsdb/nsearchindex$arch$dist.deb.gz");
|
||||
}
|
||||
return " $contentsdb/ncontentsindex$arch$dist.deb.gz|";
|
||||
}
|
||||
else {
|
||||
return "no";
|
||||
}
|
||||
|
||||
} # end sub ncontents_exist
|
||||
|
||||
# Find where the new Contents is on the on the command line vs the old
|
||||
# Contents database (when the FDB argument isn't used).
|
||||
sub find_contents {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
############
|
||||
# CONTENTS #
|
||||
############
|
||||
# Figure out where Contents is
|
||||
if ($commands->{"Contents"}) {
|
||||
my ($Contents,$FDB);
|
||||
for ($commands->{"Contents"}) {
|
||||
|
||||
###############
|
||||
# SITUATION 0 #
|
||||
###############
|
||||
# this doesn't work to well for anything less simple than ../../
|
||||
if (m,^\.\./|^\.\.$,) {
|
||||
if ($_ !~ m,/[\w-+]+/[\.\$\^\+\?\*\[\]\w-]*$,) {
|
||||
my $dd; tr/\/// ? ($dd = tr/\///) : ($dd = 1);
|
||||
my @pwd = split(m,/,,$pwd);
|
||||
s,\.\./,,g;
|
||||
my $tpwd = "";
|
||||
for (1 .. $#pwd - $dd) {
|
||||
$_ == 1 ? ($tpwd = "/$pwd[$_]")
|
||||
: (x$tpwd = $tpwd . "/$pwd[$_]");
|
||||
}
|
||||
$_ ne ".." ? ($Contents = "$tpwd/$_") : ($Contents = "$tpwd/");
|
||||
}
|
||||
dir(\%commands);
|
||||
fir(\%commands);
|
||||
}
|
||||
|
||||
###############
|
||||
# SITUATION I #
|
||||
###############
|
||||
elsif ( m,\/,) {
|
||||
$Contents = $_;
|
||||
if ($Contents =~ m,^\.\/.*,) {
|
||||
if ($pwd !~ m,^\/$,) {
|
||||
$Contents =~ m,^\.([^\.].*$),;
|
||||
$Contents = "$pwd$1";
|
||||
}
|
||||
else {
|
||||
$Contents =~ m,^\.([^\.].*$),;
|
||||
$Contents = "$1";
|
||||
}
|
||||
}
|
||||
dir(\%commands);
|
||||
fir(\%commands);
|
||||
}
|
||||
|
||||
################
|
||||
# SITUATION II #
|
||||
################
|
||||
elsif ($pwd =~ m,^\/$,) {
|
||||
$Contents = "/$_";
|
||||
dir(\%commands);
|
||||
fir(\%commands);
|
||||
}
|
||||
|
||||
#################
|
||||
# SITUATION III #
|
||||
#################
|
||||
else {
|
||||
$Contents = "$pwd/$_";
|
||||
if ($Contents =~ m,\.$,) {
|
||||
$Contents =~ m,(.*)\.$,;
|
||||
$Contents = $1;
|
||||
}
|
||||
dir(\%commands);
|
||||
fir(\%commands);
|
||||
}
|
||||
}
|
||||
|
||||
return $Contents;
|
||||
|
||||
} # if Contents
|
||||
|
||||
} # end sub find_contents
|
||||
|
||||
# figure out --df and remove from nfileindex-arch-dists.deb
|
||||
sub remove_add_nfile {
|
||||
|
||||
my ($argument,$Contents,$subject,$commands) = @_;
|
||||
my %commands = %$commands;
|
||||
#my $contentsdb = finddb(\%commands);
|
||||
#my ($arch,$dist) = which_archdist(\%commands);
|
||||
##nzing(\%commands);
|
||||
|
||||
# the + solution
|
||||
$argument =~ s,\+,\\\\+,g if $argument =~ m,\+,;
|
||||
$Contents = "zgrep -E $argument\ $Contents";
|
||||
|
||||
my($dirfile,$package,@dirfile,%all,%again,
|
||||
@package_match,@more_things,@file);
|
||||
open(CONTENTSDB, "$Contents");
|
||||
while (<CONTENTSDB>) {
|
||||
# changed for >= 0.2.9
|
||||
#if (/^FILE\s*LOCATION$/) {
|
||||
#while (<CONTENTSDB>) {
|
||||
########
|
||||
# --DF #
|
||||
########
|
||||
$argument =~ s,\\\\+,\\\+,g if $argument =~ m,\+,;
|
||||
if (m,$subject/$argument,) {
|
||||
#if (m,\b$argument\b,) {
|
||||
|
||||
######################
|
||||
# ENDS WITH / #
|
||||
######################
|
||||
if (m,.*/\s+\w*,) {
|
||||
($dirfile,$package) = split(/\s+/,$_,2);
|
||||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) {
|
||||
my @more_things = split(/\s+/,$package);
|
||||
$package = $more_things[$#more_things];
|
||||
(my $backpackage = $package) =~ s,\+,\\+,g;
|
||||
my @dirfile = split(/\s+$backpackage/,$_);
|
||||
$dirfile = $dirfile[0];
|
||||
}
|
||||
@dirfile = split(/\//,$dirfile); $dirfile =~ s,/$,,;
|
||||
}
|
||||
######################
|
||||
# DOESN'T END WITH / #
|
||||
######################
|
||||
else {
|
||||
($dirfile,$package) = split(/\s+/,$_,2);
|
||||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) {
|
||||
my @more_things = split(/\s+/,$package);
|
||||
$package = $more_things[$#more_things];
|
||||
(my $backpackage = $package) =~ s,\+,\\+,g;
|
||||
my @dirfile = split(/\s+$backpackage/,$_);
|
||||
$dirfile = $dirfile[0];
|
||||
}
|
||||
@dirfile = split(/\//,$dirfile);
|
||||
}
|
||||
###########################
|
||||
# PROCESS INTO FILES/DIRS #
|
||||
###########################
|
||||
my ($count,$holder);
|
||||
for ($count = 0; $count <= $#dirfile; $count++) {
|
||||
if ($count == 0) {
|
||||
$holder = "/$dirfile[$count]";
|
||||
my $again = "$dirfile[$count]";
|
||||
$again{$again}++;
|
||||
#my $all = "/.";
|
||||
#$all{$all}++;
|
||||
#if ($all{$all} == 1) {
|
||||
#print FILELIST "/.\n";
|
||||
#}
|
||||
if ($again{$again} == 1) {
|
||||
push(@file,"/$dirfile[$count]");
|
||||
#print FILELIST "/$dirfile[$count]\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
$holder = $holder . "/$dirfile[$count]";
|
||||
my $again = "$holder";
|
||||
$again{$again}++;
|
||||
if ($again{$again} == 1) {
|
||||
push(@file,"$holder");
|
||||
#print FILELIST "$holder\n";
|
||||
}
|
||||
}
|
||||
} # end for
|
||||
}
|
||||
undef @package_match;
|
||||
#}
|
||||
#}
|
||||
} # while
|
||||
close(CONTENTSDB);
|
||||
undef @more_things; undef @dirfile; undef %again; undef %all;
|
||||
return @file;
|
||||
|
||||
|
||||
} # end sub remove_nfile
|
||||
|
||||
1;
|
||||
2366
SWIM/NDB_Init.pm
Normal file
2366
SWIM/NDB_Init.pm
Normal file
File diff suppressed because it is too large
Load Diff
97
SWIM/Pn_print.pm
Normal file
97
SWIM/Pn_print.pm
Normal file
@ -0,0 +1,97 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Pn_print;
|
||||
use strict;
|
||||
use SWIM::Global qw($argument);
|
||||
use vars qw(@ISA @EXPORT);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(singular);
|
||||
|
||||
|
||||
# There are times when it is good to print out the "package name_version"
|
||||
# and there are times when it is unecessary. This sub tries to resolve
|
||||
# these situations, basically it's printme()
|
||||
sub singular {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
# for files, dirs, or groups
|
||||
if (($commands->{"f"} || $commands->{"dir"} || $commands->{"g"} ||
|
||||
$commands->{"q"}) &&
|
||||
!($commands->{"i"} || $commands->{"l"} ||
|
||||
$commands->{"df"} || $commands->{"d"} || $commands->{"c"} ||
|
||||
$commands->{"scripts"} || $commands->{"preinst"} || $commands->{"postinst"} ||
|
||||
$commands->{"prerm"} || $commands->{"postrm"} || $commands->{"T"} ||
|
||||
$commands->{"pre_depends"} || $commands->{"depends"} ||
|
||||
$commands->{"recommends"} || $commands->{"suggests"} ||
|
||||
$commands->{"provides"} || $commands->{"replaces"} ||
|
||||
$commands->{"conflicts"} || $commands->{"requires"} ||
|
||||
$commands->{"changelog"} || $commands->{"m"} || $commands->{"menu"} ||
|
||||
$commands->{"copyright"})) {
|
||||
print "$argument\n";
|
||||
}
|
||||
elsif (($commands->{"f"} || $commands->{"dir"} || $commands->{"g"} ||
|
||||
$commands->{"q"}) &&
|
||||
$commands {"c"} && !($commands->{"i"} ||
|
||||
$commands->{"df"} || $commands->{"d"} || $commands->{"l"} ||
|
||||
$commands->{"scripts"} || $commands->{"preinst"} || $commands->{"postinst"} ||
|
||||
$commands->{"prerm"} || $commands->{"postrm"} || $commands->{"T"} &&
|
||||
$commands->{"pre_depends"} || $commands->{"depends"} ||
|
||||
$commands->{"recommends"} || $commands->{"suggests"} ||
|
||||
$commands->{"provides"} || $commands->{"replaces"} ||
|
||||
$commands->{"conflicts"} || $commands->{"requires"} ||
|
||||
$commands->{"changelog"} || $commands->{"m"} || $commands->{"menu"} ||
|
||||
$commands->{"copyright"})) {
|
||||
print "$argument\n";
|
||||
}
|
||||
elsif (($commands->{"f"} || $commands->{"dir"} || $commands->{"g"} ||
|
||||
$commands->{"q"}) &&
|
||||
$commands {"c"} && $commands->{"d"} &&
|
||||
!($commands->{"i"} || $commands->{"df"} || $commands->{"l"} ||
|
||||
$commands->{"scripts"} || $commands->{"preinst"} || $commands->{"postinst"} ||
|
||||
$commands->{"prerm"} || $commands->{"postrm"} || $commands->{"T"} ||
|
||||
$commands->{"pre_depends"} || $commands->{"depends"} ||
|
||||
$commands->{"recommends"} || $commands->{"suggests"} ||
|
||||
$commands->{"provides"} || $commands->{"replaces"} ||
|
||||
$commands->{"conflicts"} || $commands->{"requires"} ||
|
||||
$commands->{"changelog"} || $commands->{"m"} || $commands->{"menu"} ||
|
||||
$commands->{"copyright"})) {
|
||||
print "$argument\n";
|
||||
}
|
||||
elsif (($commands->{"f"} || $commands->{"dir"} || $commands->{"g"} ||
|
||||
$commands->{"q"}) &&
|
||||
$commands {"c"} && ($commands->{"d"} ||
|
||||
$commands->{"l"}) && !($commands->{"i"} || $commands->{"df"} ||
|
||||
$commands->{"scripts"} || $commands->{"preinst"} || $commands->{"postinst"} ||
|
||||
$commands->{"prerm"} || $commands->{"postrm"} || $commands->{"T"} ||
|
||||
$commands->{"pre_depends"} || $commands->{"depends"} ||
|
||||
$commands->{"recommends"} || $commands->{"suggests"} ||
|
||||
$commands->{"provides"} || $commands->{"replaces"} ||
|
||||
$commands->{"conflicts"} || $commands->{"requires"} ||
|
||||
$commands->{"changelog"} || $commands->{"m"} || $commands->{"menu"} ||
|
||||
$commands->{"copyright"})) {
|
||||
print "$argument\n";
|
||||
}
|
||||
|
||||
} # end sub singular
|
||||
|
||||
|
||||
1;
|
||||
951
SWIM/Qftp.pm
Normal file
951
SWIM/Qftp.pm
Normal file
@ -0,0 +1,951 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Qftp;
|
||||
use strict;
|
||||
use SWIM::Conf;
|
||||
use SWIM::Global qw(@PACKAGES $argument %db);
|
||||
use SWIM::DB_Library qw(:Xyz);
|
||||
use SWIM::Deb qw(md5sumo);
|
||||
use vars qw(@ISA @EXPORT);
|
||||
use Net::FTP;
|
||||
use SWIM::F;
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(qftp);
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
This is the ftp client when --ftp is called with -q, --search/--ps. The
|
||||
downloaded packages are put in the Default directory (DF) in a directory
|
||||
mirroring (in a way relative to the design of swim) the dists structure
|
||||
which is standard with Debian. This is desirable if a person wants to mirror
|
||||
parts of a remote ftp site above the
|
||||
default_directory/default_root_directory/; this also makes it easy for a
|
||||
person to make their own distribution if they want, and apt can be used to
|
||||
install the packages at a later time by temporarily placing them in
|
||||
/var/cache/apt/archives using --df2apt. Obviously, this is nicer than using
|
||||
apt just to download the packages, but the --nz option (apt) is provided
|
||||
just in case a person is too lazed to do the -T thing, then they can do the
|
||||
--apt2df thingy to move the packages from /var/cache/apt/archives to the
|
||||
appropriate place in the DF. Ofcourse, maybe the -T thing was what the
|
||||
person didn't want to do, or maybe the person wants to do a combination of
|
||||
both (like something in the -T apt doesn't care about), this would be an
|
||||
instance where --ftp would be more useful. The configuration file presents
|
||||
a way to set this up so that the directory particular to the local ftpd can
|
||||
be integrated into the DF. The DF can be given any unique named
|
||||
directories, and the permisions of the directories created above can also be
|
||||
specified. Other options to control the DF will be provided, and -h will be
|
||||
available for querying the database pertaining to the packages in the DF,
|
||||
thereby allowing manipulation of the packages in the DF. The database will
|
||||
be made from Packages databases updated whenever the DF is called. There
|
||||
will be two types of Packages, one pertaining to the state of the local
|
||||
system, and the other pertaining to the state of the real distribution.
|
||||
--file, and --http will also be integrated with DF when they become
|
||||
available.
|
||||
|
||||
IMPORTANT: Support will only be provided for not-installed databases, use a
|
||||
not-installed database which reflects the currently installed package you
|
||||
want to download in binary or source code. This is due to the fact that swim
|
||||
thinks in terms of distribution states, and your installed system may
|
||||
represent a combination of these things. The md5sum is currently checked
|
||||
for packages, but not for source, if the md5sum data exists (not a new
|
||||
debian-revision, for instance) the package will be checked. Whether or not
|
||||
the package is OK it will be placed in it's appropriate place if it
|
||||
downloads correctly. If you get FAILED, examine the package and alert
|
||||
the
|
||||
community (download place, what's wrong with the package), then delete the
|
||||
package.
|
||||
|
||||
=cut
|
||||
sub qftp {
|
||||
|
||||
my ($arg,$commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
|
||||
# Although the /dists/... could be found with -i, it's simpler
|
||||
# just to use name_versionFILENAME instead. People shouldn't
|
||||
# edit --stdin to combine different distributions when doing --ftp,
|
||||
# (note: ofcourse apt-cache dumpavail could be used, and
|
||||
# ncontentsindex could be put together from many dbs)
|
||||
# since swim can only figure out what distribution is wanted
|
||||
# from the default value or the one provided on the command line.
|
||||
# The same is true of using apt. Whatever package is
|
||||
# provided to --stdin is assumed to be of the specified distribution,
|
||||
# anyways.
|
||||
if (!$commands->{"n"}) {
|
||||
dbi(\%commands);
|
||||
@PACKAGES = map($db{$_},(@PACKAGES = split(/\s/,$arg)));
|
||||
}
|
||||
else {
|
||||
ndb(\%commands);
|
||||
@PACKAGES = map($db{$_},(@PACKAGES = split(/\s/,$arg)))
|
||||
}
|
||||
|
||||
|
||||
my @LOCATION;
|
||||
for (0 .. $#PACKAGES) {
|
||||
if (!defined $PACKAGES[$_]) {
|
||||
print "swim: specified package(s) not found in database\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
if (defined $db{$PACKAGES[0] . "FN"}) {
|
||||
@LOCATION = map($db{$_ . "FN"},@PACKAGES);
|
||||
}
|
||||
else {
|
||||
print "swim: incorrect database was specified\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
# might as well check for a temporary directory for downloads, if it
|
||||
# doesn't exist create it.
|
||||
mkdir("$default_directory/partial",$permission)
|
||||
if !-d "$default_directory/partial";
|
||||
|
||||
# Check if there is a sources.list specified
|
||||
if (-e "$swim_conf/swimz.list") {
|
||||
undef @FTP;
|
||||
open(SOURCES,"$swim_conf/swimz.list")
|
||||
or warn "swim: could not find swimz.list\n";
|
||||
while (<SOURCES>) {
|
||||
if ($_ !~ m,#.*|^\s+,) {
|
||||
chomp; push(@FTP,$_);
|
||||
}
|
||||
}
|
||||
if ($#FTP == -1) {
|
||||
print "swim: no sites specified in swimz.list, quiting\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
|
||||
# let's make unique sites
|
||||
my (%site,@sites,$site);
|
||||
foreach $site (@FTP) {
|
||||
my @parts = split(' ', $site);
|
||||
$parts[1] =~ m,^ftp:/+( (?: (?!/). ) *)(.*),sx;
|
||||
$site{$1}++;
|
||||
push(@sites,"$1!$site") if $site{$1} == 1;
|
||||
}
|
||||
|
||||
|
||||
foreach $site (@sites) {
|
||||
|
||||
# will provide all kinds of options for ftp..like firewall
|
||||
|
||||
my $uri; ($site, $uri) = split(/!/,$site);
|
||||
my $ftp = Net::FTP->new($site,
|
||||
Debug => $debug,
|
||||
Timeout => $timeout,
|
||||
Passive => $passive,
|
||||
Firewall => $firewall,
|
||||
Port => $port
|
||||
);
|
||||
|
||||
###########
|
||||
# CONNECT #
|
||||
###########
|
||||
if (defined $ftp) {
|
||||
my $connected = $ftp->code();
|
||||
if ($connected == 220) {
|
||||
print "swim: connected to $site\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
print "swim: could not find $site\n";
|
||||
next;
|
||||
}
|
||||
|
||||
|
||||
#########
|
||||
# LOGIN #
|
||||
#########
|
||||
$ftp->login("anonymous","swim\@the.netpedia.net");
|
||||
my $logged = $ftp->code();
|
||||
# we are logged, but what is the time difference.
|
||||
if ($logged == 230 || $logged == 332) {
|
||||
print "swim: logged in to $site\n";
|
||||
$ftp->binary;
|
||||
}
|
||||
else {
|
||||
# 530 "not logged in" will have to test this
|
||||
$ftp->code();
|
||||
print "swim: not logged in to $site\n";
|
||||
next;
|
||||
}
|
||||
|
||||
# find the base to the distribution
|
||||
my @parts = split(' ', $uri);
|
||||
$parts[1] =~ m,^ftp:/+( (?: (?!/). ) *)(.*),sx;
|
||||
my $base = $2;
|
||||
|
||||
# this finds the base, but it only needs to be found once, ofcourse
|
||||
# a foreach is totally unecessary unless the site has weird symlinks.
|
||||
my @tryme_again; my $base_count = 0;
|
||||
foreach (@FTP) {
|
||||
next if $base_count == 1;
|
||||
|
||||
############
|
||||
# SETUP #
|
||||
############
|
||||
LOCUS: foreach (@LOCATION) {
|
||||
m,(.*)/(.*)$,;
|
||||
my $uptopackage = $1;
|
||||
my $packagename = $2; my $packagen = $2;
|
||||
$packagename =~ s,\+,\\\+,g;
|
||||
my ($source_drd,$drd);
|
||||
# make directories with permissions if they don't already exist
|
||||
# and also establish standardized (swimy) debian-non-US and the
|
||||
# appropriate symlinks
|
||||
# if a non-US file is requested.
|
||||
if ($uptopackage !~ /non-US/) {
|
||||
if (!-d "$default_directory/$default_root_directory/$uptopackage") {
|
||||
my $place = "$default_directory/$default_root_directory";
|
||||
my @DP = split(m,/,,$uptopackage);
|
||||
my $placement = "/";
|
||||
for (0 .. $#DP) {
|
||||
$_ == 0 ? ($placement = "/$DP[$_]")
|
||||
: ($placement = $placement . "/" . $DP[$_]);
|
||||
mkdir("$place$placement",$permission);
|
||||
# will fix this later
|
||||
# or warn "swim: could not create dists directory\n";
|
||||
# Ofcourse there is even a better fix.
|
||||
}
|
||||
}
|
||||
}
|
||||
####################
|
||||
# ################ #
|
||||
# # NON-US FILES # #
|
||||
# ################ #
|
||||
####################
|
||||
else {
|
||||
(my $above_drd = $uptopackage) =~ s,dists,,;
|
||||
$above_drd =~ s,non-US/,,;
|
||||
$source_drd = (split(m,/,,$above_drd))[1];
|
||||
($drd = $default_root_directory) =~ s,/debian,,;
|
||||
if (!-e "$default_directory$drd/debian-non-US$above_drd") {
|
||||
my $place = "$default_directory";
|
||||
my $create = "$drd/debian-non-US$above_drd";
|
||||
my @DP = split(m,/,,$create);
|
||||
my $placement = "/";
|
||||
for (0 .. $#DP) {
|
||||
$_ == 0 ? ($placement = "/$DP[$_]")
|
||||
: ($placement = $placement . "/" . $DP[$_]);
|
||||
mkdir("$place$placement",$permission)
|
||||
or warn "swim: could not create debian-non-US directory\n";
|
||||
}
|
||||
if (!-d "$default_directory$drd/debian-non-US/$source_drd/source") {
|
||||
my $place = "$default_directory";
|
||||
my $create = "$drd/debian-non-US/$source_drd/source";
|
||||
my @DP = split(m,/,,$create);
|
||||
my $placement = "/";
|
||||
for (0 .. $#DP) {
|
||||
$_ == 0 ? ($placement = "/$DP[$_]")
|
||||
: ($placement = $placement . "/" . $DP[$_]);
|
||||
mkdir("$place$placement",$permission)
|
||||
or warn "swim: could not create debian-non-US directory\n";
|
||||
}
|
||||
}
|
||||
|
||||
$place = "$default_directory$drd/debian-non-US";
|
||||
my $disty = (split(m,/,))[1]; $create = "/dists/$disty";
|
||||
undef @DP;
|
||||
@DP = split(m,/,,$create);
|
||||
for (0 .. $#DP) {
|
||||
$_ == 0 ? ($placement = "/$DP[$_]")
|
||||
: ($placement = $placement . "/" . $DP[$_]);
|
||||
mkdir("$place$placement",$permission)
|
||||
or warn "swim: could not create debian-non-US directory\n";
|
||||
}
|
||||
|
||||
# make the symlinks
|
||||
chdir("$place$placement");
|
||||
symlink("../../$disty","non-US");
|
||||
symlink("../../$disty/source","source");
|
||||
|
||||
$place = "$default_directory$drd/debian"; $create = "/dists/$disty";
|
||||
undef @DP;
|
||||
@DP = split(m,/,,$create);
|
||||
for (0 .. $#DP) {
|
||||
$_ == 0 ? ($placement = "/$DP[$_]")
|
||||
: ($placement = $placement . "/" . $DP[$_]);
|
||||
mkdir("$place$placement",$permission)
|
||||
or warn "swim: could not create debian-non-US directory\n";
|
||||
}
|
||||
chdir("$place$placement");
|
||||
|
||||
# make more symlinks
|
||||
symlink
|
||||
("../../../debian-non-US/dists/$disty/non-US","non-US");
|
||||
} # if non-US dir !-e
|
||||
} # end non-us
|
||||
|
||||
|
||||
#######
|
||||
# GET #
|
||||
#######
|
||||
my $file;
|
||||
($packagen = $packagename) =~ s,\\\+,\+,g;
|
||||
my $localfile =
|
||||
"$default_directory/partial/$packagen";
|
||||
my $home =
|
||||
"$default_directory/$default_root_directory/$_";
|
||||
my $size = $ftp->size("$base/$_");
|
||||
my $rmtime = $ftp->mdtm("$base/$_");
|
||||
my $file_exist = $ftp->code();
|
||||
#########################
|
||||
# CHECK DEBIAN-REVISION #
|
||||
#########################
|
||||
# the way this is set up, it is assumed that something exists for
|
||||
# the -(debian-revision).
|
||||
if ($file_exist == 550) {
|
||||
print "swim: $packagen does not exist on the server\n";
|
||||
print "swim: checking to see if the debian-revision has changed\n";
|
||||
$packagename =~ m,^(.*)-[\dA-Za-z\.\+]+\.deb$,;
|
||||
my $matcher = $1;
|
||||
$_ =~ m,^(.*)/$matcher[-\da-zA-Z\.\+]+\.deb$,;
|
||||
my $otherthing = $1;
|
||||
my $REVISIONCHANGE = $ftp->ls("$base/$uptopackage");
|
||||
my $singfile;
|
||||
foreach (@{$REVISIONCHANGE}) {
|
||||
m,^.*/($matcher[-\dA-Za-z\.\+]+\.deb)$,
|
||||
? ($singfile = $1)
|
||||
: ($singfile = $_);
|
||||
if ($singfile =~ /^$matcher/) {
|
||||
$file = $singfile;
|
||||
}
|
||||
}
|
||||
my $checkfile;
|
||||
defined $file
|
||||
? ($checkfile = $otherthing . "/$file")
|
||||
: ($checkfile = "NOFILE");
|
||||
$size = $ftp->size("$base/$checkfile");
|
||||
$rmtime = $ftp->mdtm("$base/$checkfile");
|
||||
$file_exist = $ftp->code();
|
||||
print "swim: could not find $packagen debian-revision\n"
|
||||
if $file_exist == 550;
|
||||
push(@tryme_again,$_) if $file_exist == 550;
|
||||
next if $file_exist == 550;
|
||||
$localfile =~ s,$matcher[-\dA-Za-z\.\+]*\.deb$,$file,;
|
||||
$home =
|
||||
"$default_directory/$default_root_directory/$uptopackage/$file";
|
||||
$packagename = $file; $file = $otherthing . "/$file";
|
||||
} # END DEBIAN-REVISION
|
||||
else {$file = $_; }
|
||||
my ($lsize,$lmtime);
|
||||
|
||||
|
||||
########################
|
||||
# SAME PACKAGE LOCALLY #
|
||||
########################
|
||||
$packagename =~ m,(^[A-Za-z\d\+-\\+]*)_([\\+A-Za-z\d\+\.:]*)
|
||||
[-]?[\dA-Za-z\.\+]*\.deb$,x;
|
||||
my $spackage = $1; my $upstream_revision = $2;
|
||||
$spackage =~ s,\+,\\\+,g;
|
||||
if (-e $home) {
|
||||
($lsize,$lmtime) = (stat($home))[7,9];
|
||||
}
|
||||
# If the upstream-revision has changed and
|
||||
# a local package with the same name exists, we want to delete it.
|
||||
else {
|
||||
opendir(DF,"$default_directory/$default_root_directory/$uptopackage");
|
||||
my $grepthing = "^" . $spackage . "_";
|
||||
#my $grepthing = $spackage . "_" . $upstream_revision;
|
||||
foreach (sort grep(/$grepthing/, readdir(DF))) {
|
||||
m,(.*)_([\dA-Za-z\+\.:]+)[-]?[\dA-Za-z\+\.]*\.deb$,;
|
||||
my $lupstream_revision = $2;
|
||||
if ($lupstream_revision eq $upstream_revision) {
|
||||
print "swim: $_ with different debian-revision exists\n";
|
||||
$_ = "";
|
||||
|
||||
##########
|
||||
# SOURCE #
|
||||
##########
|
||||
if ($commands->{"source"} || $commands->{"source_only"}) {
|
||||
my (@SOURCE,$upstream_change);
|
||||
my ($matcher,$local_source,$remote_source,$base) =
|
||||
source_calc($base,$uptopackage,$packagename,$drd,$source_drd);
|
||||
my $REVISIONCHANGE = $ftp->ls("$base/$remote_source");
|
||||
my $singfile;
|
||||
foreach (@{$REVISIONCHANGE}) {
|
||||
m,^.*/($matcher.*)$,
|
||||
? ($singfile = $1)
|
||||
: ($singfile = $_);
|
||||
if ($singfile =~ /^$matcher/) {
|
||||
$file = $singfile;
|
||||
push(@SOURCE,"$base/$remote_source/$singfile");
|
||||
}
|
||||
}
|
||||
if (!defined @SOURCE) {
|
||||
print "swim: checking for upstream-revsion change\n";
|
||||
($matcher) = (split(/_/,$matcher))[0];
|
||||
foreach (@{$REVISIONCHANGE}) {
|
||||
m,^.*/($matcher.*)$,
|
||||
? ($singfile = $1)
|
||||
: ($singfile = $_);
|
||||
if ($singfile =~ /^$matcher/) {
|
||||
$file = $singfile;
|
||||
push(@SOURCE,"$base/$remote_source/$singfile");
|
||||
}
|
||||
}
|
||||
$upstream_change = "yes" if defined @SOURCE;
|
||||
}
|
||||
foreach (@SOURCE) {
|
||||
m,.*/(.*)$,; $packagename = $1;
|
||||
$lmtime = (stat("$local_source/$packagename"))[9];
|
||||
-e "$local_source/$packagename"
|
||||
? ($lmtime = (stat("$local_source/$packagename"))[9])
|
||||
: ($lmtime = -1);
|
||||
$size = $ftp->size("$_");
|
||||
$rmtime = $ftp->mdtm("$_");
|
||||
$file_exist = $ftp->code();
|
||||
if ($lmtime != $rmtime) {
|
||||
if (!$commands->{"diff"}) {
|
||||
$localfile = "$default_directory/partial/$packagename";
|
||||
!defined $upstream_change
|
||||
? print "swim: downloading $packagename ($size bytes)\n"
|
||||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n";
|
||||
get($ftp,"$_",$localfile);
|
||||
my $complete = $ftp->code();
|
||||
$lsize = (stat($localfile))[7];
|
||||
if ($lsize == $size && $complete == 226 &&
|
||||
$lmtime != $rmtime) {
|
||||
print "swim: successful retrieval of $packagename\n";
|
||||
rename("$localfile","$local_source/$packagename")
|
||||
or system "$mv","$localfile","$local_source/$packagename";
|
||||
}
|
||||
else {
|
||||
print "swim: unsuccessful retrieval of $packagename\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (m,diff\.gz,) {
|
||||
$localfile = "$default_directory/partial/$packagename";
|
||||
!defined $upstream_change
|
||||
? print "swim: downloading $packagename ($size bytes)\n"
|
||||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n";
|
||||
get($ftp,"$_",$localfile);
|
||||
my $complete = $ftp->code();
|
||||
$lsize = (stat($localfile))[7];
|
||||
if ($lsize == $size && $complete == 226 &&
|
||||
$lmtime != $rmtime) {
|
||||
print "swim: successful retrieval of $packagename\n";
|
||||
rename("$localfile","$local_source/$packagename")
|
||||
or system "$mv","$localfile","$local_source/$packagename";
|
||||
}
|
||||
else {
|
||||
print "swim: unsuccessful retrieval of $packagename\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
utime(time,$rmtime,"$local_source/$packagename");
|
||||
$_ = "";
|
||||
}
|
||||
else {
|
||||
print "swim: $packagename already exists\n"
|
||||
}
|
||||
}
|
||||
} # source
|
||||
next LOCUS;
|
||||
}
|
||||
elsif ($lupstream_revision ne $upstream_revision) {
|
||||
if (!$commands->{"source_only"}) {
|
||||
print "swim: replacing $_ with a different upstream-revision\n";
|
||||
unlink
|
||||
("$default_directory/$default_root_directory/$uptopackage/$_");
|
||||
}
|
||||
print "swim: $_ exists with a different upstream-revision\n";
|
||||
}
|
||||
}
|
||||
closedir(DF);
|
||||
}
|
||||
|
||||
##################
|
||||
# EXISTS LOCALLY #
|
||||
##################
|
||||
# got here but localtime was greater.
|
||||
if (defined $rmtime && defined $lmtime) {
|
||||
# ofcourse if the file does exist locally and has the same name
|
||||
# and version, and this exists, something strange is going on.
|
||||
if ($lmtime < $rmtime) {
|
||||
print "swim: downloading $packagen, strange.........
|
||||
same upstream version exists in the same package locally\n";
|
||||
get($ftp,"$base/$file",$localfile);
|
||||
my $complete = $ftp->code();
|
||||
$argument = $localfile;
|
||||
$commands{"md5sum"} = 1;
|
||||
md5sumo(\%commands) if $complete == 226;
|
||||
($packagen = $packagename) =~ s,\\\+,\+,g;
|
||||
print "swim: successful retrieval of $packagen\n"
|
||||
if $complete == 226;
|
||||
$_ = "" if $complete == 226;
|
||||
utime(time,$rmtime,$localfile);
|
||||
}
|
||||
elsif ($lmtime == $rmtime) {
|
||||
$_ = "";
|
||||
($packagen = $packagename) =~ s,\\\+,\+,g;
|
||||
print "swim: $packagen already exists\n";
|
||||
##########
|
||||
# SOURCE #
|
||||
##########
|
||||
if ($commands->{"source"} || $commands->{"source_only"}) {
|
||||
my (@SOURCE,$upstream_change);
|
||||
my ($matcher,$local_source,$remote_source,$base) =
|
||||
source_calc($base,$uptopackage,$packagename,$drd,$source_drd);
|
||||
my $REVISIONCHANGE = $ftp->ls("$base/$remote_source");
|
||||
my $singfile;
|
||||
foreach (@{$REVISIONCHANGE}) {
|
||||
m,^.*/($matcher.*)$,
|
||||
? ($singfile = $1)
|
||||
: ($singfile = $_);
|
||||
if ($singfile =~ /^$matcher/) {
|
||||
$file = $singfile;
|
||||
push(@SOURCE,"$base/$remote_source/$singfile");
|
||||
}
|
||||
}
|
||||
if (!defined @SOURCE) {
|
||||
print "swim: checking for upstream-revsion change\n";
|
||||
($matcher) = (split(/_/,$matcher))[0];
|
||||
foreach (@{$REVISIONCHANGE}) {
|
||||
m,^.*/($matcher.*)$,
|
||||
? ($singfile = $1)
|
||||
: ($singfile = $_);
|
||||
if ($singfile =~ /^$matcher/) {
|
||||
$file = $singfile;
|
||||
push(@SOURCE,"$base/$remote_source/$singfile");
|
||||
}
|
||||
}
|
||||
$upstream_change = "yes" if defined @SOURCE;
|
||||
}
|
||||
foreach (@SOURCE) {
|
||||
m,.*/(.*)$,; $packagename = $1;
|
||||
-e "$local_source/$packagename"
|
||||
? ($lmtime = (stat("$local_source/$packagename"))[9])
|
||||
: ($lmtime = -1);
|
||||
$size = $ftp->size("$_");
|
||||
$rmtime = $ftp->mdtm("$_");
|
||||
$file_exist = $ftp->code();
|
||||
if ($lmtime != $rmtime) {
|
||||
if (!$commands->{"diff"}) {
|
||||
$localfile = "$default_directory/partial/$packagename";
|
||||
!defined $upstream_change
|
||||
? print "swim: downloading $packagename ($size bytes)\n"
|
||||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n";
|
||||
get($ftp,"$_",$localfile);
|
||||
my $complete = $ftp->code();
|
||||
$lsize = (stat($localfile))[7];
|
||||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) {
|
||||
print "swim: successful retrieval of $packagename\n";
|
||||
rename("$localfile","$local_source/$packagename")
|
||||
or system "$mv","$localfile","$local_source/$packagename";
|
||||
}
|
||||
else {
|
||||
print "swim: unsuccessful retrieval of $packagename\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (m,diff\.gz,) {
|
||||
$localfile = "$default_directory/partial/$packagename";
|
||||
!defined $upstream_change
|
||||
? print "swim: downloading $packagename ($size bytes)\n"
|
||||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n";
|
||||
get($ftp,"$_",$localfile);
|
||||
my $complete = $ftp->code();
|
||||
$lsize = (stat($localfile))[7];
|
||||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) {
|
||||
print "swim: successful retrieval of $packagename\n";
|
||||
rename("$localfile","$local_source/$packagename")
|
||||
or system "$mv","$localfile","$local_source/$packagename";
|
||||
}
|
||||
else {
|
||||
print "swim: unsuccessful retrieval of $packagename\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
utime(time,$rmtime,"$local_source/$packagename");
|
||||
$_ = "";
|
||||
}
|
||||
else {
|
||||
print "swim: $packagename already exists\n"
|
||||
}
|
||||
}
|
||||
} # source
|
||||
}
|
||||
}
|
||||
#########################################################
|
||||
# DOESN'T EXIST LOCALLY OR DIFFERENT UPSTREAM-REVISION #
|
||||
#########################################################
|
||||
else {
|
||||
########################
|
||||
# BINARY AND/OR SOURCE #
|
||||
########################
|
||||
if (!$commands->{"source_only"}) {
|
||||
print "swim: downloading $packagen ($size bytes)\n";
|
||||
my $upstream_change;
|
||||
get($ftp,"$base/$file",$localfile);
|
||||
my $complete = $ftp->code();
|
||||
$lsize = (stat($localfile))[7];
|
||||
if ($lsize == $size && $complete == 226) {
|
||||
$argument = $localfile;
|
||||
$commands{"md5sum"} = 1; md5sumo(\%commands);
|
||||
($packagen = $packagename) =~ s,\\\+,\+,g;
|
||||
print "swim: successful retrieval of $packagen\n";
|
||||
rename("$localfile","$home")
|
||||
or system "$mv", "$localfile", "$home";
|
||||
utime(time,$rmtime,"$home");
|
||||
}
|
||||
else {
|
||||
print "swim: unsuccessful retrieval of $file\n";
|
||||
}
|
||||
$_ = "";
|
||||
##########
|
||||
# SOURCE #
|
||||
##########
|
||||
if ($commands->{"source"}) {
|
||||
my (@SOURCE,$upstream_change);
|
||||
my ($matcher,$local_source,$remote_source,$base) =
|
||||
source_calc($base,$uptopackage,$packagename,$drd,$source_drd);
|
||||
my $REVISIONCHANGE = $ftp->ls("$base/$remote_source");
|
||||
my $singfile;
|
||||
foreach (@{$REVISIONCHANGE}) {
|
||||
m,^.*/($matcher.*)$,
|
||||
? ($singfile = $1)
|
||||
: ($singfile = $_);
|
||||
if ($singfile =~ /^$matcher/) {
|
||||
$file = $singfile;
|
||||
push(@SOURCE,"$base/$remote_source/$singfile");
|
||||
}
|
||||
}
|
||||
if (!defined @SOURCE) {
|
||||
print "swim: checking for upstream-revsion change\n";
|
||||
($matcher) = (split(/_/,$matcher))[0];
|
||||
foreach (@{$REVISIONCHANGE}) {
|
||||
m,^.*/($matcher.*)$,
|
||||
? ($singfile = $1)
|
||||
: ($singfile = $_);
|
||||
if ($singfile =~ /^$matcher/) {
|
||||
$file = $singfile;
|
||||
push(@SOURCE,"$base/$remote_source/$singfile");
|
||||
}
|
||||
}
|
||||
$upstream_change = "yes" if defined @SOURCE;
|
||||
}
|
||||
foreach (@SOURCE) {
|
||||
m,.*/(.*)$,; $packagename = $1;
|
||||
-e "$local_source/$packagename"
|
||||
? ($lmtime = (stat("$local_source/$packagename"))[9])
|
||||
: ($lmtime = -1);
|
||||
$size = $ftp->size("$_");
|
||||
$rmtime = $ftp->mdtm("$_");
|
||||
$file_exist = $ftp->code();
|
||||
if ($lmtime != $rmtime) {
|
||||
if (!$commands->{"diff"}) {
|
||||
$localfile = "$default_directory/partial/$packagename";
|
||||
!defined $upstream_change
|
||||
? print "swim: downloading $packagename ($size bytes)\n"
|
||||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n";
|
||||
get($ftp,"$_",$localfile);
|
||||
my $complete = $ftp->code();
|
||||
$lsize = (stat($localfile))[7];
|
||||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) {
|
||||
print "swim: successful retrieval of $packagename\n";
|
||||
rename("$localfile","$local_source/$packagename")
|
||||
or system "$mv","$localfile","$local_source/$packagename";
|
||||
}
|
||||
else {
|
||||
print "swim: unsuccessful retrieval of $packagename\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (m,diff\.gz,) {
|
||||
$localfile = "$default_directory/partial/$packagename";
|
||||
!defined $upstream_change
|
||||
? print "swim: downloading $packagename ($size bytes)\n"
|
||||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n";
|
||||
get($ftp,"$_",$localfile);
|
||||
my $complete = $ftp->code();
|
||||
$lsize = (stat($localfile))[7];
|
||||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) {
|
||||
print "swim: successful retrieval of $packagename\n";
|
||||
rename("$localfile","$local_source/$packagename")
|
||||
or system "$mv","$localfile","$local_source/$packagename";
|
||||
}
|
||||
else {
|
||||
print "swim: unsuccessful retrieval of $packagename\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
utime(time,$rmtime,"$local_source/$packagename");
|
||||
$_ = "";
|
||||
}
|
||||
else {
|
||||
print "swim: $packagename already exists\n"
|
||||
}
|
||||
}
|
||||
} # source
|
||||
}
|
||||
###############
|
||||
# SOURCE-ONLY #
|
||||
###############
|
||||
else {
|
||||
my (@SOURCE,$upstream_change);
|
||||
my ($matcher,$local_source,$remote_source,$base) =
|
||||
source_calc($base,$uptopackage,$packagename,$drd,$source_drd);
|
||||
my $REVISIONCHANGE = $ftp->ls("$base/$remote_source");
|
||||
my $singfile;
|
||||
foreach (@{$REVISIONCHANGE}) {
|
||||
m,^.*/($matcher.*)$,
|
||||
? ($singfile = $1)
|
||||
: ($singfile = $_);
|
||||
if ($singfile =~ /^$matcher/) {
|
||||
$file = $singfile;
|
||||
push(@SOURCE,"$base/$remote_source/$singfile");
|
||||
}
|
||||
}
|
||||
if (!defined @SOURCE) {
|
||||
print "swim: checking for upstream-revsion change\n";
|
||||
($matcher) = (split(/_/,$matcher))[0];
|
||||
foreach (@{$REVISIONCHANGE}) {
|
||||
m,^.*/($matcher.*)$,
|
||||
? ($singfile = $1)
|
||||
: ($singfile = $_);
|
||||
if ($singfile =~ /^$matcher/) {
|
||||
$file = $singfile;
|
||||
push(@SOURCE,"$base/$remote_source/$singfile");
|
||||
}
|
||||
}
|
||||
$upstream_change = "yes" if defined @SOURCE;
|
||||
}
|
||||
foreach (@SOURCE) {
|
||||
m,.*/(.*)$,; $packagename = $1;
|
||||
-e "$local_source/$packagename"
|
||||
? ($lmtime = (stat("$local_source/$packagename"))[9])
|
||||
: ($lmtime = -1);
|
||||
$size = $ftp->size("$_");
|
||||
$rmtime = $ftp->mdtm("$_");
|
||||
$file_exist = $ftp->code();
|
||||
if ($lmtime != $rmtime) {
|
||||
if (!$commands->{"diff"}) {
|
||||
$localfile = "$default_directory/partial/$packagename";
|
||||
!defined $upstream_change
|
||||
? print "swim: downloading $packagename ($size bytes)\n"
|
||||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n";
|
||||
get($ftp,"$_",$localfile);
|
||||
my $complete = $ftp->code();
|
||||
$lsize = (stat($localfile))[7];
|
||||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) {
|
||||
print "swim: successful retrieval of $packagename\n";
|
||||
rename("$localfile","$local_source/$packagename")
|
||||
or system "$mv","$localfile","$local_source/$packagename";
|
||||
}
|
||||
else {
|
||||
print "swim: unsuccessful retrieval of $packagename\n";
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (m,diff\.gz,) {
|
||||
$localfile = "$default_directory/partial/$packagename";
|
||||
!defined $upstream_change
|
||||
? print "swim: downloading $packagename ($size bytes)\n"
|
||||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n";
|
||||
get($ftp,"$_",$localfile);
|
||||
my $complete = $ftp->code();
|
||||
$lsize = (stat($localfile))[7];
|
||||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) {
|
||||
print "swim: successful retrieval of $packagename\n";
|
||||
rename("$localfile","$local_source/$packagename")
|
||||
or system "$mv","$localfile","$local_source/$packagename";
|
||||
}
|
||||
else {
|
||||
print "swim: unsuccessful retrieval of $packagename\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
utime(time,$rmtime,"$local_source/$packagename");
|
||||
$_ = "";
|
||||
}
|
||||
else {
|
||||
print "swim: $packagename already exists\n"
|
||||
}
|
||||
}
|
||||
} # source-only
|
||||
}
|
||||
}
|
||||
$base_count++;
|
||||
} # foreach FTP
|
||||
undef @LOCATION;
|
||||
@LOCATION = @tryme_again;
|
||||
$ftp->quit() if !defined @LOCATION;
|
||||
my $good_bye = $ftp->code();
|
||||
print "swim: logged out\n" if $good_bye == 221;
|
||||
undef @sites if !defined @LOCATION;
|
||||
|
||||
} # foreach sites
|
||||
untie %db;
|
||||
|
||||
} # end sub qftp
|
||||
|
||||
|
||||
# figure out the source stuff, make appropriate directories for sections
|
||||
# which aren't non-US
|
||||
sub source_calc {
|
||||
|
||||
my($base,$uptopackage,$packagename,$drd,$source_drd) = @_;
|
||||
|
||||
|
||||
# if source is empty in %db we can use the package name, need
|
||||
# to watch for experimental
|
||||
my ($remote_source,$local_source,@SOURCE);
|
||||
# NON-US
|
||||
if ($uptopackage =~ /non-US/) {
|
||||
$local_source =
|
||||
"$default_directory$drd/debian-non-US/$source_drd/source";
|
||||
$uptopackage =~ m,(.*)/.*$,; $remote_source = $1;
|
||||
$remote_source = "$remote_source/source";
|
||||
# for safety's sake and because most sites don't have
|
||||
# /pub/debian/dists/unstable/non-US/source except for a
|
||||
# site made with swim, convert debian to debian-non-US and
|
||||
# hope everything is standard.
|
||||
if ($base !~ /debian-non-US/) {
|
||||
$base =~ s/debian/debian-non-US/;
|
||||
}
|
||||
}
|
||||
# EVERYTHING ELSE
|
||||
else {
|
||||
$uptopackage =~ m,(.*)/(.*)$,;
|
||||
my $subject = $2; $1 =~ m,(.*)/.*$,; $local_source = $1;
|
||||
#$remote_source =~ m,(.*)/.*$,; $remote_source = $1;
|
||||
$remote_source = $local_source;
|
||||
$local_source = "$remote_source/source/$subject";
|
||||
$remote_source = $local_source;
|
||||
$local_source =
|
||||
"$default_directory$default_root_directory/$local_source";
|
||||
}
|
||||
|
||||
# exciting matcher realities..if it isn't non-US than the
|
||||
# %db needs to be searched for anything found in Source:,
|
||||
# if it is defined, then vola, herein this section lays the
|
||||
# source, otherwise it's probably in the section which pertains
|
||||
# to the package being queried..we hope. Epochs aren't used
|
||||
# fortunately they aren't in package_versionFN, but they can
|
||||
# be in the Source: area so they need to be removed.
|
||||
$packagename =~ m,(^[A-Za-z\d\+-\\+]*_[\\+A-Za-z\d\+\.:]*)
|
||||
[-]?[\dA-Za-z\.\+]*\.deb$,x;
|
||||
|
||||
# everything, but revision
|
||||
my $matcher = $1;
|
||||
$matcher =~ m,^(.*)_(.*)$,; my $mat = $1;
|
||||
if (defined $db{$mat}) {
|
||||
$mat = $db{$mat}; $mat = $db{$mat};
|
||||
if ($mat =~ m,Installed-Size:\s\d+\s+Source:\s(.*),){
|
||||
$matcher = $1;
|
||||
##########################################
|
||||
# DIFFERENT VERSION AND DIFFERENT SOURCE #
|
||||
##########################################
|
||||
if ($matcher =~ m,[\(\)], ) {
|
||||
$matcher =~ /:/
|
||||
? $matcher =~ m,^(.*)
|
||||
\s\([\d]?[:]?
|
||||
([A-Za-z0-9\+\.]+)
|
||||
[-]?[\dA-Za-z\+\.]*\)$,x
|
||||
: $matcher =~ m,^(.*)
|
||||
\s\(
|
||||
([A-Za-z0-9\+\.]+)
|
||||
[-]?[\dA-Za-z\+\.]*\)$,x;
|
||||
|
||||
my $mat2 = $1; my $mat2_ver = $2;
|
||||
$matcher = $mat2 . "_" . $mat2_ver;
|
||||
if (defined $db{$mat2}) {
|
||||
$matcher = $mat2 . "_" . $mat2_ver;
|
||||
# time to change the $remote_source and $local_source
|
||||
if ($uptopackage !~ /non-US/) {
|
||||
my $change = $db{$mat2};
|
||||
$change = $db{$change ."FN"};
|
||||
$change =~ m,(.*)/(.*)$,;
|
||||
$uptopackage = $1; $uptopackage =~ m,(.*)/(.*)$,;
|
||||
my $subject = $2;
|
||||
$1 =~ m,(.*)/.*$,; $local_source = $1;
|
||||
$local_source = "$local_source/source/$subject";
|
||||
$remote_source = $local_source;
|
||||
$local_source =
|
||||
"$default_directory$default_root_directory/$local_source";
|
||||
}
|
||||
}
|
||||
}
|
||||
#####################################
|
||||
# SAME VERSION AND DIFFERENT SOURCE #
|
||||
#####################################
|
||||
else {
|
||||
if (defined $db{$matcher}) {
|
||||
# time to change the
|
||||
# $remote_source and $local_source
|
||||
if ($uptopackage !~ /non-US/) {
|
||||
my $change = $db{$matcher};
|
||||
$change = $db{$change ."FN"};
|
||||
$change =~ m,(.*)/(.*)$,;
|
||||
$uptopackage = $1; $uptopackage =~ m,(.*)/(.*)$,;
|
||||
my $subject = $2;
|
||||
$1 =~ m,(.*)/.*$,; $local_source = $1;
|
||||
$local_source = "$local_source/source/$subject";
|
||||
$remote_source = $local_source;
|
||||
$local_source =
|
||||
"$default_directory$default_root_directory/$local_source";
|
||||
}
|
||||
}
|
||||
}
|
||||
} # Source: found
|
||||
} # should be defined
|
||||
|
||||
|
||||
# time to make direcorties if $local_source isn't defined
|
||||
# non-US already made, if source if already made, just the
|
||||
# subject above needs to be made
|
||||
if (!-e $local_source) {
|
||||
my $place;
|
||||
my @LS = split(m,/,,$local_source);
|
||||
for (1 .. $#LS - 2) {
|
||||
$_ == 1 ? ($place = "/$LS[$_]")
|
||||
: ($place = $place . "/" . $LS[$_]);
|
||||
}
|
||||
my $create = "$LS[$#LS -1]/$LS[$#LS]";
|
||||
if (-d "$place/$LS[$#LS - 1]") {
|
||||
mkdir("$place/$create",$permission)
|
||||
or warn "swim: could not create source directory\n";
|
||||
}
|
||||
else {
|
||||
my @DP = split(m,/,,$create);
|
||||
my $placement = "/";
|
||||
for (0 .. $#DP) {
|
||||
$_ == 0 ? ($placement = "/$DP[$_]")
|
||||
: ($placement = $placement . "/" . $DP[$_]);
|
||||
mkdir("$place$placement",$permission)
|
||||
or warn "swim: could not create source directory\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return($matcher,$local_source,$remote_source,$base);
|
||||
|
||||
} # end source_calc
|
||||
|
||||
|
||||
|
||||
|
||||
1;
|
||||
180
SWIM/Ramdisk.pm
Normal file
180
SWIM/Ramdisk.pm
Normal file
@ -0,0 +1,180 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Ramdisk;
|
||||
use strict;
|
||||
use SWIM::Conf;
|
||||
use SWIM::Library;
|
||||
use vars qw(@ISA @EXPORT);
|
||||
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(ramdisk);
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
make access a lot faster for contentsindex.deb.gz, alternatively
|
||||
searchindex.deb & file/dirindex. Ramdisks don't work well for
|
||||
everything like the creation of a database. The goal is to
|
||||
automatically determine the size of the disk based on the files
|
||||
put into it (which will all be compressed) This also has a residual
|
||||
effect, so when the ramdisk is umounted stuff still stays in
|
||||
the memory.
|
||||
|
||||
=cut
|
||||
|
||||
sub ramdisk {
|
||||
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
# lot's of thing can be put into the ramdisk, ncontentsindex being the
|
||||
# most important, but flat search files, too. --ramdiskon -n would be
|
||||
# the most important application.
|
||||
my $size = 0;
|
||||
my (@storage,@files);
|
||||
my $count = 0;
|
||||
my %commands = %$commands;
|
||||
my $where = finddb(\%commands);
|
||||
my ($arch,$dist) = which_archdist(\%commands);
|
||||
my $not = "n" if defined $arch;
|
||||
$not = "" if !$commands->{"n"};
|
||||
$arch = "" if !$commands->{"n"};
|
||||
$dist = "" if !$commands->{"n"};
|
||||
my $contentsindex = "contentsindex";
|
||||
my $searchindex = "searchindex";
|
||||
my $dirindex = "dirindex";
|
||||
|
||||
if ($commands->{"ramdiskon"}) {
|
||||
|
||||
my $rambo = "$cat /proc/mounts|";
|
||||
open(RAM, "$rambo");
|
||||
while (<RAM>) {
|
||||
if (/ram/) {
|
||||
my($device,$mount) = split(/\s/,$_,2);
|
||||
if ($mount =~ /dramdisk/) {
|
||||
print "swim: use --ramdiskoff\n";
|
||||
exit;
|
||||
}
|
||||
$storage[$count] = $device;
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
close(RAM);
|
||||
|
||||
if (-e "$where/$not$contentsindex$arch$dist.deb.gz" &&
|
||||
-B "$where/$not$contentsindex$arch$dist.deb.gz") {
|
||||
$size = (stat("$where/$not$contentsindex$arch$dist.deb.gz"))[7];
|
||||
push(@files,"$where/$not$contentsindex$arch$dist.deb.gz");
|
||||
}
|
||||
|
||||
if ($commands->{"searchfile"}) {
|
||||
# stat caused some weirdisms based on the boolean logic
|
||||
#if (-e "$where/$not$searchindex$arch$dist.deb" &&
|
||||
# -e "$where/$not$dirindex$arch$dist.deb") {
|
||||
# compress the monsters
|
||||
if (!-e "$where/$not$dirindex$arch$dist.deb.gz") {
|
||||
print "swim: please wait while dirindex.deb is compressed\n";
|
||||
if (-e "$where/$not$dirindex$arch$dist.deb") {
|
||||
system "$gzip -c9 $where/$not$dirindex$arch$dist.deb > $where/$not$dirindex$arch$dist.deb.gz";
|
||||
}
|
||||
}
|
||||
if (!-e "$where/$not$searchindex$arch$dist.deb.gz") {
|
||||
print "swim: please wait while searchindex.deb is compressed\n";
|
||||
if (-e "$where/$not$searchindex$arch$dist.deb") {
|
||||
system "$gzip -c9 $where/$not$searchindex$arch$dist.deb > $where/$not$searchindex$arch$dist.deb.gz";
|
||||
}
|
||||
}
|
||||
push(@files,"$where/$not$dirindex$arch$dist.deb.gz");
|
||||
push(@files,"$where/$not$searchindex$arch$dist.deb.gz");
|
||||
my $size1 = (stat("$where/$not$searchindex$arch$dist.deb.gz"))[7];
|
||||
my $size2 = (stat("$where/$not$dirindex$arch$dist.deb.gz"))[7];
|
||||
if (defined $size) {
|
||||
$size = $size + $size1 + $size2;
|
||||
}
|
||||
else {
|
||||
$size = $size1 + $size2;
|
||||
}
|
||||
#}
|
||||
}
|
||||
|
||||
# it will be assumed that ext2 is used, and hopefully there isn't a mount
|
||||
# of the exact same name..hence dramdisk should be unusual
|
||||
my $number;
|
||||
if (defined @storage) {
|
||||
@storage = sort {$a cmp $b} @storage;
|
||||
$storage[$#storage] =~ s/\D//g;
|
||||
$number = $storage[$#storage] + 1;
|
||||
}
|
||||
else {
|
||||
$number = 0;
|
||||
}
|
||||
|
||||
# the size will be the sizes added together/1024 + (.15 of the total)
|
||||
if (-e "$where/dramdisk") {
|
||||
if (!-d "$where/dramdisk") {
|
||||
print "swim: --ramdiskon requires dir dramdisk, but a file named dramdisk already exists\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
elsif (!-d "$where/dramdisk") {
|
||||
mkdir("$where/dramdisk",0666);
|
||||
}
|
||||
|
||||
my $increase = $size * 0.15;
|
||||
$size = $increase + $size;
|
||||
$size = $size/1024;
|
||||
$size = sprintf("%.f",$size);
|
||||
if ($size > 0) {
|
||||
system "$mke2fs", "-m0", "/dev/ram$number", "$size";
|
||||
system "$mount", "-t", "ext2", "/dev/ram$number", "$where/dramdisk";
|
||||
foreach (@files) {
|
||||
system "$copy", "$_", "$where/dramdisk";
|
||||
}
|
||||
}
|
||||
} # if on
|
||||
else {
|
||||
|
||||
my $rambo = "$cat /proc/mounts|";
|
||||
open(RAM, "$rambo");
|
||||
while (<RAM>) {
|
||||
if (/ram/) {
|
||||
my($device,$mount) = split(/\s/,$_,2);
|
||||
if ($mount =~ /dramdisk/) {
|
||||
system "$umount", "$device";
|
||||
exit;
|
||||
}
|
||||
$storage[$count] = $device;
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
close(RAM);
|
||||
|
||||
|
||||
} # if off
|
||||
|
||||
exit;
|
||||
|
||||
} # end sub ramdisk
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
1;
|
||||
470
SWIM/Safex.pm
Normal file
470
SWIM/Safex.pm
Normal file
@ -0,0 +1,470 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Safex;
|
||||
use strict;
|
||||
use Term::ReadLine;
|
||||
use SWIM::Conf qw($apt_get $dpkg $tmp $HISTORY);
|
||||
use SWIM::Global qw(@PACKAGES $argument $aptor_group %db);
|
||||
use SWIM::DB_Library qw(:Xyz);
|
||||
use SWIM::Library;
|
||||
use vars qw(@ISA @EXPORT %EXPORT_TAGS);
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(safex);
|
||||
|
||||
|
||||
# when x is called
|
||||
sub safex {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
if ($commands->{"x"} || $commands->{"ftp"} || $commands->{"source"} ||
|
||||
$commands->{"source_only"} || $commands->{"remove"} || $commands->{"r"} ||
|
||||
$commands->{"purge"}) {
|
||||
|
||||
|
||||
if (!defined @PACKAGES) {
|
||||
if ($commands->{"search"} || $commands->{"ps"} || $commands->{"research"}
|
||||
|| $commands->{"refinesearch"}) {
|
||||
@PACKAGES = "NOPACKAGES";
|
||||
}
|
||||
else {
|
||||
@PACKAGES = @ARGV;
|
||||
}
|
||||
}
|
||||
|
||||
#print "PACKAGES @PACKAGES $argument\n";
|
||||
|
||||
my ($aptor,$arg);
|
||||
if (defined $argument) {
|
||||
if ($argument =~ /_/) {
|
||||
$argument =~ m,(.*)_.*,;
|
||||
$aptor = $1;
|
||||
}
|
||||
else {
|
||||
if (($argument =~ m,/, && ($commands->{"y"} || $commands->{"z"} ||
|
||||
$commands->{"ftp"} || $commands->{"nz"})) || defined $aptor_group ||
|
||||
$commands->{"ftp"} || $commands->{"purge"} || $commands->{"remove"} ||
|
||||
$commands->{"r"}) {
|
||||
if ($PACKAGES[$#PACKAGES] =~ /_/) {
|
||||
$PACKAGES[$#PACKAGES] =~ m,(.*)_.*,;
|
||||
$aptor = $1;
|
||||
}
|
||||
else {
|
||||
$aptor = $PACKAGES[$#PACKAGES];
|
||||
}
|
||||
}
|
||||
else {
|
||||
$aptor = $argument;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($commands->{"y"} || $commands->{"z"} || $commands->{"ftp"} ||
|
||||
$commands->{"nz"} || $commands->{"purge"} || $commands->{"remove"} ||
|
||||
$commands->{"r"}) {
|
||||
if ($PACKAGES[$#PACKAGES] =~ /_/) {
|
||||
$PACKAGES[$#PACKAGES] =~ m,(.*)_.*,;
|
||||
$aptor = $1;
|
||||
}
|
||||
else {
|
||||
$aptor = $PACKAGES[$#PACKAGES];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if ($PACKAGES[$#PACKAGES] =~ m,/,) {
|
||||
$PACKAGES[$#PACKAGES] =~ m,.*/(.*)$,;
|
||||
$arg = $1;
|
||||
foreach (@PACKAGES) {
|
||||
$_ =~ m,.*/(.*)$,;
|
||||
shift @PACKAGES;
|
||||
push(@PACKAGES,$1);
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($PACKAGES[$#PACKAGES] =~ /_/) {
|
||||
$PACKAGES[$#PACKAGES] =~ m,(.*)_.*,;
|
||||
$arg = $1;
|
||||
foreach (0 .. $#PACKAGES) {
|
||||
if ($PACKAGES[$_] =~ /_/) {
|
||||
$PACKAGES[$_] =~ m,^(.*)_.*$,;
|
||||
$PACKAGES[$_] = $1;
|
||||
}
|
||||
else {
|
||||
$PACKAGES[$_] = $PACKAGES[$_];
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$arg = $PACKAGES[$#PACKAGES];
|
||||
foreach (0 .. $#PACKAGES) {
|
||||
if ($PACKAGES[$_] =~ /_/) {
|
||||
$PACKAGES[$_] =~ m,^(.*)_.*$,;
|
||||
$PACKAGES[$_] = $1;
|
||||
}
|
||||
else {
|
||||
$PACKAGES[$_] = $PACKAGES[$_];
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$aptor = "DEFINEDONE" if !defined $aptor;
|
||||
if (($aptor eq $arg) || ($commands->{"search"} ||
|
||||
$commands->{"ps"} || $commands->{"research"} ||
|
||||
$commands->{"refinesearch"} || $aptor eq "/.") &&
|
||||
$PACKAGES[0] ne "NOPACKAGES") {
|
||||
xyz(\%commands);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
|
||||
|
||||
# swim provides a great interface to apt. The trick is to not actually
|
||||
# run apt-get until all the arguments are stored in an array. This is
|
||||
# done easily for xy and for for xyz which provides virtual installation
|
||||
# and querying completion after --db && --ndb updates. Obviously, the
|
||||
# package virtually installed needs to be the same architecture as the
|
||||
# machine running, since this is how apt works, but the databases can be
|
||||
# in any specified directory. This function also provides an interface for
|
||||
# ftp, as well as dpkg's --remove & --purge.
|
||||
sub xyz {
|
||||
|
||||
my ($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
if (!$commands->{"ftp"}) {
|
||||
if (!defined $apt_get) {
|
||||
print "swim: configure swimrc\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
|
||||
# error correcting
|
||||
if ($commands->{"ftp"} && ($commands->{"r"} || $commands->{"remove"} ||
|
||||
$commands->{"purge"})) {
|
||||
print "swim: --ftp cannot be used with ";
|
||||
print "-r " if defined $commands->{"r"};
|
||||
print "--remove " if defined $commands->{"remove"};
|
||||
print "--purge " if defined $commands->{"purge"};
|
||||
print "\n";
|
||||
exit;
|
||||
}
|
||||
if (($commands->{"r"} || $commands->{"remove"}) && $commands->{"purge"}) {
|
||||
print "swim: ";
|
||||
print "-r " if defined $commands->{"r"};
|
||||
print "--remove " if defined $commands->{"remove"};
|
||||
print "--purge " if defined $commands->{"purge"};
|
||||
print "cannot be used together\n";
|
||||
exit;
|
||||
}
|
||||
if (($commands->{"y"} || $commands->{"z"} || $commands->{"x"} ||
|
||||
$commands->{"nz"}) && ($commands->{"ftp"} || $commands->{"purge"})) {
|
||||
print "swim: -";
|
||||
print "x" if $commands->{"x"};
|
||||
print "y" if $commands->{"y"};
|
||||
print "z" if $commands->{"z"};
|
||||
print " --nz" if $commands->{"nz"};
|
||||
print " cannot be used with ";
|
||||
print "--purge " if defined $commands->{"purge"};
|
||||
print "--ftp " if defined $commands->{"ftp"};
|
||||
print "\n";
|
||||
exit;
|
||||
}
|
||||
if (($commands->{"source"} && $commands->{"source_only"})) {
|
||||
print "swim: --source and --source_only cannot be used together\n";
|
||||
exit;
|
||||
}
|
||||
if (($commands->{"source"} || $commands->{"source_only"}) &&
|
||||
!$commands->{"ftp"}) {
|
||||
print "swim: --";
|
||||
print "source" if $commands->{"source"};
|
||||
print "source_only" if $commands->{"source_only"};
|
||||
print " cannot be used without --ftp\n";
|
||||
exit;
|
||||
}
|
||||
if (($commands->{"y"} || $commands->{"z"} || $commands->{"nz"}) &&
|
||||
!$commands->{"x"}) {
|
||||
print "swim: requires -x option\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
if ($commands->{"x"}) {
|
||||
# There's no sense in doing this if the wrong architecture is called.
|
||||
if (defined $dpkg) {
|
||||
system "$dpkg --print-installation-architecture > $tmp/arch.deb";
|
||||
open(ARCH, "$tmp/arch.deb") or warn "couldn't find arch\n";
|
||||
my @arch = <ARCH>; chomp $arch[0];
|
||||
my($arch,$dist) = which_archdist(\%commands); $arch =~ m,^-(.*),;
|
||||
if ($1 ne $arch[0]) {
|
||||
print "swim: apt uses the $arch[0] architecture\n";
|
||||
exit;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
###############
|
||||
# SAFETY MODE #
|
||||
###############
|
||||
if ((($commands->{"x"} || ($commands->{"x"} && $commands->{"y"})) ||
|
||||
($commands->{"x"} && ($commands->{"r"} || $commands->{"remove"}) ||
|
||||
($commands->{"x"} && $commands->{"y"} && ($commands->{"r"} ||
|
||||
$commands->{"remove"})))) &&
|
||||
!($commands->{"z"} || $commands->{"nz"})) {
|
||||
my $arg;
|
||||
my $count = 0;
|
||||
foreach (@PACKAGES) {
|
||||
if ($count == 0) {
|
||||
$arg = "$_";
|
||||
}
|
||||
else {
|
||||
$arg = $arg . " " . "$_";
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
#########
|
||||
# STDIN #
|
||||
#########
|
||||
if ($commands->{"stdin"}) {
|
||||
my $term = Term::ReadLine->new("Simple Shell");
|
||||
my @HISTORY = history(\%commands);
|
||||
$term->addhistory(@HISTORY);
|
||||
my @history; push(@history,"$arg");
|
||||
print "swim: type exit to finish --stdin\n";
|
||||
my $termcount = 0;
|
||||
while ($termcount < 1 ) {
|
||||
$_ = $term->readline('swim: ',"$arg");
|
||||
push (@history,$_);
|
||||
$termcount++;
|
||||
} do { $_ = $term->readline('swim: ');
|
||||
push (@history,$_);
|
||||
} while $_ ne "exit";
|
||||
$arg = $history[$#history - 1];
|
||||
if ($arg ne $HISTORY[$#HISTORY]) {
|
||||
if ($arg =~ m,^[^\w],) {
|
||||
$arg =~ s,^\s+(\w+),$1,;
|
||||
}
|
||||
history_print($arg,\%commands);
|
||||
}
|
||||
}
|
||||
!($commands->{"r"} || $commands{"remove"}) ?
|
||||
system "$apt_get install -qs $arg" :
|
||||
system "$apt_get remove -qs $arg";
|
||||
}
|
||||
#####################
|
||||
# INSTALLATION MODE #
|
||||
#####################
|
||||
# provides optional --stdin to change packages to be installed
|
||||
# from the command line
|
||||
else {
|
||||
my $arg;
|
||||
my $count = 0;
|
||||
foreach (@PACKAGES) {
|
||||
if ($count == 0) {
|
||||
$arg = "$_";
|
||||
}
|
||||
else {
|
||||
$arg = $arg . " " . "$_";
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
#########
|
||||
# STDIN #
|
||||
#########
|
||||
if ($commands->{"stdin"}) {
|
||||
my $term = Term::ReadLine->new("Simple Shell");
|
||||
my @HISTORY = history(\%commands);
|
||||
$term->addhistory(@HISTORY);
|
||||
my @history; push(@history,"$arg");
|
||||
print "swim: type exit to finish --stdin\n";
|
||||
my $termcount = 0;
|
||||
while ($termcount < 1 ) {
|
||||
$_ = $term->readline('swim: ',"$arg");
|
||||
push (@history,$_);
|
||||
$termcount++;
|
||||
} do { $_ = $term->readline('swim: ');
|
||||
push (@history,$_);
|
||||
} while $_ ne "exit";
|
||||
$arg = $history[$#history - 1];
|
||||
if ("$arg" ne "$HISTORY[$#HISTORY]") {
|
||||
if ($arg =~ m,^[^\w],) {
|
||||
$arg =~ s,^\s+(\w+),$1,;
|
||||
}
|
||||
history_print($arg,\%commands);
|
||||
}
|
||||
}
|
||||
#######
|
||||
# XYZ #
|
||||
#######
|
||||
if (!($commands->{"ftp"} || $commands->{"purge"})) {
|
||||
if (!$commands->{"y"}) {
|
||||
if (!$commands->{"nz"}) {
|
||||
!($commands->{"r"} || $commands{"remove"}) ?
|
||||
system "$apt_get install $arg" :
|
||||
system "$apt_get remove $arg";
|
||||
}
|
||||
else {
|
||||
!($commands->{"r"} || $commands{"remove"}) ?
|
||||
system "$apt_get -d install $arg" :
|
||||
system "$apt_get remove $arg";
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (!$commands->{"nz"}) {
|
||||
!($commands->{"r"} || $commands{"remove"}) ?
|
||||
system "$apt_get install -y $arg" :
|
||||
system "$apt_get remove -y $arg";
|
||||
}
|
||||
else {
|
||||
# not that the y does anything
|
||||
!($commands->{"r"} || $commands{"remove"}) ?
|
||||
system "$apt_get install -y -d $arg" :
|
||||
system "$apt_get remove -y $arg";
|
||||
}
|
||||
}
|
||||
}
|
||||
#######
|
||||
# FTP #
|
||||
#######
|
||||
elsif ($commands->{"ftp"}) {
|
||||
require SWIM::Qftp;
|
||||
SWIM::Qftp->import(qw(qftp));
|
||||
qftp($arg,\%commands);
|
||||
}
|
||||
|
||||
##################
|
||||
# PURGE & REMOVE #
|
||||
##################
|
||||
elsif ($commands->{"purge"} || $commands->{"remove"} || $commands->{"r"}) {
|
||||
purge($arg,\%commands);
|
||||
}
|
||||
|
||||
# this is a good time to return the versions, too, as well as
|
||||
# including any NEW packages from --db and --ndb. We'll assume $arg
|
||||
# from qftp will never be too large
|
||||
if (!$commands->{"n"}) {
|
||||
dbi(\%commands);
|
||||
@PACKAGES = map($db{$_},(@PACKAGES = split(/\s/,$arg)));
|
||||
}
|
||||
else {
|
||||
ndb(\%commands);
|
||||
@PACKAGES = map($db{$_},(@PACKAGES = split(/\s/,$arg)));
|
||||
}
|
||||
untie %db;
|
||||
}
|
||||
|
||||
} # end sub xyz
|
||||
|
||||
|
||||
# Remove (keep configuration files) or purge everything for each package.
|
||||
sub purge {
|
||||
|
||||
my ($arg,$commands) = @_;
|
||||
|
||||
if (!$commands->{"n"}) {
|
||||
if ($commands->{"purge"}) {
|
||||
system "$dpkg --purge $arg";
|
||||
|
||||
}
|
||||
elsif ($commands->{"remove"} || $commands->{"r"}) {
|
||||
system "$dpkg -r $arg";
|
||||
}
|
||||
}
|
||||
else {
|
||||
print "swim: ";
|
||||
print "-r " if defined $commands->{"r"};
|
||||
print "--remove " if defined $commands->{"remove"};
|
||||
print "--purge " if defined $commands->{"purge"};
|
||||
print "can only be used with installed packages\n";
|
||||
}
|
||||
|
||||
|
||||
} # end sub purge
|
||||
|
||||
|
||||
# find the history file and return proper output
|
||||
sub history {
|
||||
|
||||
my($commands) = @_;
|
||||
my %commands = %$commands;
|
||||
|
||||
my($arch,$dist) = which_archdist(\%commands);
|
||||
my($place) = finddb(\%commands);
|
||||
my $swim_history;
|
||||
if ($commands->{"n"}) {
|
||||
$swim_history = "$place/.nswim$arch$dist" . "_history";
|
||||
}
|
||||
else {
|
||||
$swim_history = "$place/.swim" . "_history";
|
||||
}
|
||||
open(HISTORY,"$swim_history") or exit;
|
||||
my (@HISTORY,$line);
|
||||
while (<HISTORY>) {
|
||||
chomp;
|
||||
foreach (split(/\s/,$_)) {
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
}
|
||||
push(@HISTORY,$line); undef $line;
|
||||
}
|
||||
|
||||
return @HISTORY;
|
||||
|
||||
} # end sub history
|
||||
|
||||
# append history if it has changed
|
||||
sub history_print {
|
||||
|
||||
my($arg,$commands) = @_;
|
||||
my %commands = %$commands;
|
||||
my($arch,$dist) = which_archdist(\%commands);
|
||||
my($place) = finddb(\%commands);
|
||||
my $swim_history;
|
||||
if ($commands->{"n"}) {
|
||||
$swim_history = "$place/.nswim$arch$dist" . "_history";
|
||||
}
|
||||
else {
|
||||
$swim_history = "$place/.swim" . "_history";
|
||||
}
|
||||
open(HISTORY,"$swim_history") or exit;
|
||||
my @HISTORY = <HISTORY>;
|
||||
close(HISTORY);
|
||||
if ($#HISTORY < $HISTORY - 1) {
|
||||
push(@HISTORY,"$arg\n");
|
||||
}
|
||||
else {
|
||||
shift(@HISTORY);
|
||||
push(@HISTORY,"$arg\n");
|
||||
}
|
||||
open(HISTORY,">$swim_history") or exit;
|
||||
print HISTORY @HISTORY;
|
||||
|
||||
|
||||
} # end sub history_print
|
||||
|
||||
1;
|
||||
850
SWIM/Search.pm
Normal file
850
SWIM/Search.pm
Normal file
@ -0,0 +1,850 @@
|
||||
# Package administration and research tool for Debian
|
||||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum
|
||||
|
||||
# This program is free software; you can redistribute it and/or modify
|
||||
# it under the terms of the GNU General Public License as published by
|
||||
# the Free Software Foundation; either version 2 of the License, or
|
||||
# (at your option) any later version.
|
||||
|
||||
# This program is distributed in the hope that it will be useful,
|
||||
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
# GNU General Public License for more details.
|
||||
|
||||
# You should have received a copy of the GNU General Public License
|
||||
# along with this program; if not, write to the Free Software
|
||||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||||
|
||||
|
||||
package SWIM::Search;
|
||||
use vars qw(@ISA @EXPORT);
|
||||
use strict;
|
||||
use SWIM::Global;
|
||||
use SWIM::Conf;
|
||||
use SWIM::DB_Library qw(:Search);
|
||||
use SWIM::Library;
|
||||
use Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(search);
|
||||
|
||||
|
||||
# search() and searchdf() = mm --search, --ps --refinesearch --research
|
||||
|
||||
=pod
|
||||
|
||||
This searches for keyword(s) amongst the descriptions, and then
|
||||
shows the packages which match, a little more sophisticated than
|
||||
swim -qait | grep <keyword>, besides you can use perl regexping
|
||||
notation when you do your search. By default the description is
|
||||
automatically presented, but a list of package names which match is kept
|
||||
which can then be queried using -S in the normal fashion, until the
|
||||
next search.
|
||||
|
||||
=cut
|
||||
|
||||
sub search {
|
||||
|
||||
my ($search_mem,$commands,$num,$argv) = @_;
|
||||
|
||||
$argument = "/.";
|
||||
my %commands = %$commands;
|
||||
|
||||
my %morethanone;
|
||||
my $keyword = $commands->{"search"};
|
||||
if ($commands->{"search"}) {
|
||||
$keyword = $commands->{"search"};
|
||||
}
|
||||
elsif ($commands->{"research"}) {
|
||||
$keyword = $commands->{"research"};
|
||||
}
|
||||
elsif ($commands->{"refinesearch"}) {
|
||||
$keyword = $commands->{"refinesearch"};
|
||||
}
|
||||
elsif ($commands->{"powersearch"} || $commands->{"ps"}) {
|
||||
if ($commands->{"powersearch"}) {
|
||||
$keyword = $commands->{"powersearch"};
|
||||
}
|
||||
if ($commands->{"ps"}) {
|
||||
$keyword = $commands->{"ps"};
|
||||
}
|
||||
}
|
||||
my $count = 0;
|
||||
|
||||
my ($search_file, $search_dir);
|
||||
if (!$commands->{"n"}) {
|
||||
ib(\%commands);
|
||||
dbi(\%commands);
|
||||
if ($commands->{"ps"} || $commands->{"powersearch"}) {
|
||||
($search_file,$search_dir) = searchdf(\%commands);
|
||||
if (-B $search_file && -B $search_dir) {
|
||||
$search_file = "$gzip -dc $search_file|";
|
||||
$search_dir = "$gzip -dc $search_dir|";
|
||||
}
|
||||
}
|
||||
}
|
||||
#####
|
||||
# N #
|
||||
#####
|
||||
else {
|
||||
my $return = nib(\%commands);
|
||||
if (!defined $return) {
|
||||
untie %ib;
|
||||
nsb(\%commands);
|
||||
$ib{"/."} = $nsb{"/."};
|
||||
}
|
||||
ndb(\%commands);
|
||||
if ($commands->{"ps"} || $commands->{"powersearch"}) {
|
||||
($search_file,$search_dir) = searchdf(\%commands);
|
||||
if (!-e $search_file || !-e $search_dir) {
|
||||
delete $commands{"ps"} if defined $commands->{"ps"};
|
||||
delete $commands{"powersearch"} if defined $commands->{"powersearch"};
|
||||
}
|
||||
if (-B $search_file && -B $search_dir) {
|
||||
$search_file = "$gzip -dc $search_file|";
|
||||
$search_dir = "$gzip -dc $search_dir|";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
##########
|
||||
# #
|
||||
# SEARCH #
|
||||
# #
|
||||
##########
|
||||
# Here starts --search & optionally -g
|
||||
my ($line,@HISTORY);
|
||||
if ($commands->{"search"}) {
|
||||
my @stuff;
|
||||
if ($commands->{"g"}) {
|
||||
# check for some errors
|
||||
if ($commands->{"a"} || $commands->{"f"} || $commands->{"dir"}) {
|
||||
print "swim: one type of query/verify may be performed at a time\n";
|
||||
exit;
|
||||
}
|
||||
# extract the packages related to the group.
|
||||
if (!$commands->{"n"}) {
|
||||
gb(\%commands);
|
||||
}
|
||||
else {
|
||||
ngb(\%commands)
|
||||
}
|
||||
if ($#ARGV != -1) {
|
||||
foreach (@ARGV) {
|
||||
$argument = $_;
|
||||
if (defined $gb{$argument}) {
|
||||
@stuff = split(/\s/, $gb{$argument});
|
||||
}
|
||||
else {
|
||||
print "group $argument does not contain any packages\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
print "swim: no arguments given for query\n";
|
||||
}
|
||||
untie %gb;
|
||||
} # if ($commands->{"g"})
|
||||
|
||||
# not yet for -g
|
||||
if ($commands->{"search"} && !$commands->{"g"}) {
|
||||
if (defined $argument) {
|
||||
if ($ib{"$argument"}){
|
||||
foreach (split(/\s/, $ib{"$argument"})) {
|
||||
if ($keyword =~ /\/i$/) {
|
||||
$keyword =~ m,(.*)\/i$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$_} =~ /$1/i) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/m$/) {
|
||||
$keyword =~ m,(.*)\/m$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$_} =~ /$1/m ) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/.[im]$/) {
|
||||
$keyword =~ m,(.*)\/.[im]$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$_} =~ /$1/im ) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$_} =~ /$keyword/) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
print "swim: found $count package(s)\n";
|
||||
#exit;
|
||||
}
|
||||
if (!defined $line) {
|
||||
$line = "";
|
||||
}
|
||||
else {
|
||||
$line = "$line\n";
|
||||
}
|
||||
history($line,$search_mem);
|
||||
}
|
||||
}
|
||||
|
||||
# ok -g
|
||||
elsif ($commands->{"search"} && $commands->{"g"}) {
|
||||
if (defined @stuff) {
|
||||
#unlink("$search_mem");
|
||||
foreach (@stuff) {
|
||||
$argument = $_;
|
||||
version(\%commands);
|
||||
# if we just did a group search we don't want to append it to
|
||||
# the .search.deb file.
|
||||
if ($keyword =~ /\/i$/) {
|
||||
$keyword =~ m,(.*)\/i$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$argument} =~ /$1/i) {
|
||||
print "$db{$argument}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$argument);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/m$/) {
|
||||
$keyword =~ m,(.*)\/m$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$argument} =~ /$1/m ) {
|
||||
print "$db{$argument}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$argument);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/.[im]$/) {
|
||||
$keyword =~ m,(.*)\/.[im]$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$argument} =~ /$1/im ) {
|
||||
print "$db{$argument}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$argument);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$argument} =~ /$keyword/) {
|
||||
print "$db{$argument}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$argument);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
print "swim: found $count package(s)\n";
|
||||
if (!defined $line) {
|
||||
$line = "";
|
||||
}
|
||||
else {
|
||||
$line = "$line\n";
|
||||
}
|
||||
history($line,$search_mem);
|
||||
}
|
||||
}
|
||||
exit if !($commands->{"stdin"} || $commands->{"x"} || $commands->{"y"} ||
|
||||
$commands->{"z"} || $commands->{"ftp"});
|
||||
}
|
||||
|
||||
#############################
|
||||
# #
|
||||
# RESEARCH || REFINESEARCH #
|
||||
# #
|
||||
#############################
|
||||
# research time or refining time
|
||||
if ($commands->{"research"} || $commands{"refinesearch"}) {
|
||||
if ($commands->{"g"}) {
|
||||
print "swim: use -g only with a new search\n";
|
||||
exit;
|
||||
}
|
||||
foreach (@$argv) {
|
||||
if ($keyword =~ /\/i$/) {
|
||||
$keyword =~ m,(.*)\/i$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$db{$_}} =~ /$1/i) {
|
||||
print "$db{$db{$_}}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/m$/) {
|
||||
$keyword =~ m,(.*)\/m$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$db{$_}} =~ /$1/m ) {
|
||||
print "$db{$db{$_}}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/.[im]$/) {
|
||||
$keyword =~ m,(.*)\/.[im]$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$db{$_}} =~ /$1/im ) {
|
||||
print "$db{$db{$_}}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$db{$_}} =~ /$keyword/) {
|
||||
print "$db{$db{$_}}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
print "swim: found $count package(s)\n";
|
||||
if (!defined $line) {
|
||||
$line = "";
|
||||
}
|
||||
else {
|
||||
$line = "$line\n";
|
||||
}
|
||||
# refine the search
|
||||
if ($commands->{"refinesearch"}) {
|
||||
open(HISTORY, "$search_mem") || exit;
|
||||
my @HISTORY = reverse <HISTORY>;
|
||||
close(HISTORY);
|
||||
$HISTORY[$num - 1] = $line;
|
||||
open(HISTORY, ">$search_mem") || exit;
|
||||
print HISTORY reverse @HISTORY;
|
||||
close(HISTORY);
|
||||
}
|
||||
exit if !($commands->{"stdin"} || $commands->{"x"} ||
|
||||
$commands->{"y"} || $commands->{"z"} || $commands->{"ftp"});
|
||||
}
|
||||
|
||||
|
||||
################
|
||||
# #
|
||||
# POWERSEARCH #
|
||||
# #
|
||||
################
|
||||
# powersearch with no -g option since this searchs all files.
|
||||
if (($commands->{"powersearch"} || $commands->{"ps"}) && !$commands->{"g"}) {
|
||||
open(FLATFILE, "$search_file");
|
||||
while (<FLATFILE>) {
|
||||
chomp $_;
|
||||
if ($keyword =~ /\/i$/) {
|
||||
$keyword =~ m,(.*)\/i$,;
|
||||
if ($_ =~ /$1/i) {
|
||||
if (defined $ib{$_}) {
|
||||
$morethanone{$ib{$_}}++;
|
||||
if ($morethanone{$ib{$_}} == 1) {
|
||||
print "$db{$ib{$_}}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$ib{$_});
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$ib{$_}))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$ib{$_}))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/m$/) {
|
||||
$keyword =~ m,(.*)\/m$,;
|
||||
if ($_ =~ /$1/m ) {
|
||||
if (defined $ib{$_}) {
|
||||
$morethanone{$ib{$_}}++;
|
||||
if ($morethanone{$ib{$_}} == 1) {
|
||||
print "$db{$ib{$_}}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$ib{$_});
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$ib{$_}))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$ib{$_}))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/.[im]$/) {
|
||||
$keyword =~ m,(.*)\/.[im]$,;
|
||||
if ($_ =~ /$1/im ) {
|
||||
if (defined $ib{$_}) {
|
||||
$morethanone{$ib{$_}}++;
|
||||
if ($morethanone{$ib{$_}} == 1) {
|
||||
print "$db{$ib{$_}}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$ib{$_});
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$ib{$_}))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$ib{$_}))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($_ =~ /$keyword/) {
|
||||
if (defined $ib{$_}) {
|
||||
$morethanone{$ib{$_}}++;
|
||||
if ($morethanone{$ib{$_}} == 1) {
|
||||
# ofcourse this won't work if a dir filters through.
|
||||
# hummm.
|
||||
#print "HUMM DIR $_ ", $ib{$_}, "\n";
|
||||
print "$db{$ib{$_}}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$ib{$_});
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$ib{$_}))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$ib{$_}))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} # while (<FLATFILE>)
|
||||
close(FLATFILE);
|
||||
|
||||
#######
|
||||
# DIR #
|
||||
#######
|
||||
# Somebody wants to do a rare --dir search, but this is done by default
|
||||
# for the n* because often enough more than one package shares one
|
||||
# file.
|
||||
if ($commands->{"dir"} || $commands{"n"}) {
|
||||
open(FLATFILE, "$search_dir");
|
||||
while (<FLATFILE>) {
|
||||
chomp $_;
|
||||
if ($keyword =~ /\/i$/) {
|
||||
$keyword =~ m,(.*)\/i$,;
|
||||
if ($_ =~ /$1/i) {
|
||||
if (defined $ib{$_}) {
|
||||
$morethanone{$ib{$_}}++;
|
||||
if ($morethanone{$ib{$_}} == 1) {
|
||||
my @dir = split(/\s/,$ib{$_});
|
||||
foreach (@dir) {
|
||||
$morethanone{$_}++;
|
||||
if (defined $morethanone{$_}) {
|
||||
if ($morethanone{$_} == 1) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/m$/) {
|
||||
$keyword =~ m,(.*)\/m$,;
|
||||
if ($_ =~ /$1/m ) {
|
||||
if (defined $ib{$_}) {
|
||||
$morethanone{$ib{$_}}++;
|
||||
if ($morethanone{$ib{$_}} == 1) {
|
||||
my @dir = split(/\s/,$ib{$_});
|
||||
foreach (@dir) {
|
||||
$morethanone{$_}++;
|
||||
if (defined $morethanone{$_}) {
|
||||
if ($morethanone{$_} == 1) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/.[im]$/) {
|
||||
$keyword =~ m,(.*)\/.[im]$,;
|
||||
if ($_ =~ /$1/im ) {
|
||||
if (defined $ib{$_}) {
|
||||
$morethanone{$ib{$_}}++;
|
||||
if ($morethanone{$ib{$_}} == 1) {
|
||||
my @dir = split(/\s/,$ib{$_});
|
||||
foreach (@dir) {
|
||||
$morethanone{$_}++;
|
||||
if (defined $morethanone{$_}) {
|
||||
if ($morethanone{$_} == 1) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($_ =~ /$keyword/) {
|
||||
if (defined $ib{$_}) {
|
||||
#my @dir = split(/\s/,$ib{$_});
|
||||
#foreach (@dir) {
|
||||
$morethanone{$ib{$_}}++;
|
||||
if ($morethanone{$ib{$_}} == 1) {
|
||||
my @dir = split(/\s/,$ib{$_});
|
||||
foreach (@dir) {
|
||||
$morethanone{$_}++;
|
||||
if (defined $morethanone{$_}) {
|
||||
if ($morethanone{$_} == 1) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
} # while (<FLATFILE>)
|
||||
close(FLATFILE);
|
||||
}
|
||||
|
||||
#################
|
||||
# NORMAL SEARCH #
|
||||
#################
|
||||
# now we can do a normal search for the powersearch
|
||||
if (defined $argument) {
|
||||
if ($ib{"$argument"}){
|
||||
foreach (split(/\s/, $ib{$argument})) {
|
||||
if ($keyword =~ /\/i$/) {
|
||||
$morethanone{$_}++;
|
||||
if ($morethanone{$_} == 1) {
|
||||
$keyword =~ m,(.*)\/i$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$_} =~ /$1/i) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/m$/) {
|
||||
$morethanone{$_}++;
|
||||
if ($morethanone{$_} == 1) {
|
||||
$keyword =~ m,(.*)\/m$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$_} =~ /$1/m ) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($keyword =~ /\/.[im]$/) {
|
||||
$morethanone{$_}++;
|
||||
if ($morethanone{$_} == 1) {
|
||||
$keyword =~ m,(.*)\/.[im]$,;
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$_} =~ /$1/im ) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$morethanone{$_}++;
|
||||
if ($morethanone{$_} == 1) {
|
||||
if (defined $db{$_}) {
|
||||
if ($db{$_} =~ /$keyword/) {
|
||||
print "$db{$_}\n" if !$commands->{"no"};
|
||||
push(@PACKAGES,$_);
|
||||
if (!defined $line) {
|
||||
$line = (split(/_/,$_))[0];
|
||||
}
|
||||
else {
|
||||
$line = $line . " " . (split(/_/,$_))[0];
|
||||
}
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
print "swim: found $count package(s)\n";
|
||||
if (!defined $line) {
|
||||
$line = "";
|
||||
}
|
||||
else {
|
||||
$line = "$line\n";
|
||||
}
|
||||
history($line,$search_mem);
|
||||
#exit if !($commands->{"stdin"} || $commands->{"x"} ||
|
||||
# $commands->{"y"} || $commands->{"z"} || $commands->{"ftp"});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
untie %ib;
|
||||
untie %db;
|
||||
|
||||
|
||||
} # end sub search
|
||||
|
||||
# for finding the search flatfiles
|
||||
sub searchdf {
|
||||
|
||||
my ($commands) = @_;
|
||||
|
||||
my($sfile,$sdir);
|
||||
if (!$commands->{"n"}) {
|
||||
my ($ramdisk) = ram_on();
|
||||
if ($ramdisk eq 1) {
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$sfile = "$parent$library/searchindex.deb";
|
||||
$sdir = "$parent$library/dirindex.deb";
|
||||
return ($sfile,$sdir);
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$sfile = "$parent$base/searchindex.deb";
|
||||
$sdir = "$parent$base/dirindex.deb";
|
||||
return ($sfile,$sdir);
|
||||
}
|
||||
}
|
||||
elsif ($ramdisk eq "yes") {
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$sfile = "$parent$library/dramdisk/searchindex.deb.gz";
|
||||
$sdir = "$parent$library/dramdisk/dirindex.deb.gz";
|
||||
if (!-e $sdir && !-e $sfile) {
|
||||
print "swim: found wrong database(s), use --ramdiskoff\n";
|
||||
exit;
|
||||
}
|
||||
return ($sfile,$sdir);
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$sfile = "$parent$base/dramdisk/searchindex.deb.gz";
|
||||
$sdir = "$parent$base/dramdisk/dirindex.deb.gz";
|
||||
if (!-e $sdir && !-e $sfile) {
|
||||
print "swim: found wrong database(s), use --ramdiskoff\n";
|
||||
exit;
|
||||
}
|
||||
return ($sfile,$sdir);
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
my ($ramdisk) = ram_on();
|
||||
my($arch,$dist) = which_archdist(\%commands);
|
||||
if ($ramdisk eq 1) {
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$sfile = "$parent$library/nsearchindex$arch$dist.deb";
|
||||
$sdir = "$parent$library/ndirindex$arch$dist.deb";
|
||||
return ($sfile,$sdir);
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$sfile = "$parent$base/nsearchindex$arch$dist.deb";
|
||||
$sdir = "$parent$base/ndirindex$arch$dist.deb";
|
||||
return ($sfile,$sdir);
|
||||
}
|
||||
}
|
||||
elsif ($ramdisk eq "yes") {
|
||||
if (($commands->{"dbpath"} && $commands->{"root"}) ||
|
||||
($commands->{"dbpath"} && !$commands->{"root"}) ||
|
||||
(!$commands->{"dbpath"} && !$commands->{"root"})) {
|
||||
$sfile = "$parent$library/dramdisk/nsearchindex$arch$dist.deb.gz";
|
||||
$sdir = "$parent$library/dramdisk/ndirindex$arch$dist.deb.gz";
|
||||
if (!-e $sdir && !-e $sfile) {
|
||||
print "swim: found wrong database(s), use --ramdiskoff\n";
|
||||
exit;
|
||||
}
|
||||
return ($sfile,$sdir);
|
||||
}
|
||||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) {
|
||||
$sfile = "$parent$base/dramdisk/nsearchindex$arch$dist.deb.gz";
|
||||
$sdir = "$parent$base/dramdisk/ndirindex$arch$dist.deb.gz";
|
||||
if (!-e $sdir && !-e $sfile) {
|
||||
print "swim: found wrong database(s), use --ramdiskoff\n";
|
||||
exit;
|
||||
}
|
||||
return ($sfile,$sdir);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
} # end sub searchdf
|
||||
|
||||
# print the search out to the right spot on the HISTORY
|
||||
# this is just shift and push
|
||||
sub history {
|
||||
|
||||
my($line,$file) = @_;
|
||||
my @HISTORY;
|
||||
|
||||
if (-e "$file") {
|
||||
open(HISTORY,"$file");
|
||||
@HISTORY = <HISTORY>;
|
||||
close(HISTORY);
|
||||
if ($#HISTORY < $HISTORY - 1) {
|
||||
push(@HISTORY,$line);
|
||||
}
|
||||
else {
|
||||
shift(@HISTORY);
|
||||
push(@HISTORY,$line);
|
||||
}
|
||||
}
|
||||
else {
|
||||
@HISTORY = $line;
|
||||
}
|
||||
|
||||
open(HISTORY,">$file") or exit;
|
||||
print HISTORY @HISTORY;
|
||||
close(HISTORY);
|
||||
|
||||
} # end sub history
|
||||
|
||||
|
||||
1;
|
||||
Loading…
x
Reference in New Issue
Block a user