bike
/
dswim
mirror of https://github.com/fspc/dswim
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

Changed order.

master
freesource 23 years ago
parent
c013a4564c
commit
f794069a62
28 changed files with 0 additions and 16953 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 263
      lib/Ag.pm
  2. 1219
      lib/Apt.pm
  3. 358
      lib/Compare.pm
  4. 673
      lib/Conf.pm
  5. 947
      lib/DB.pm
  6. 648
      lib/DB_Init.pm
  7. 497
      lib/DB_Library.pm
  8. 1752
      lib/Deb.pm
  9. 456
      lib/Deps.pm
  10. 110
      lib/Dir.pm
  11. 92
      lib/F.pm
  12. 877
      lib/File.pm
  13. 358
      lib/Findex.pm
  14. 62
      lib/Format.pm
  15. 62
      lib/Global.pm
  16. 73
      lib/Groups.pm
  17. 509
      lib/Indexer.pm
  18. 586
      lib/Info.pm
  19. 144
      lib/Library.pm
  20. 268
      lib/MD.pm
  21. 1834
      lib/NDB.pm
  22. 251
      lib/NDB_File.pm
  23. 2366
      lib/NDB_Init.pm
  24. 97
      lib/Pn_print.pm
  25. 951
      lib/Qftp.pm
  26. 180
      lib/Ramdisk.pm
  27. 470
      lib/Safex.pm
  28. 850
      lib/Search.pm

263
lib/Ag.pm
View File

@ -1,263 +0,0 @@
# 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
lib/Apt.pm
View File

File diff suppressed because it is too large

358
lib/Compare.pm
View File

@ -1,358 +0,0 @@
# 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
lib/Conf.pm
View File

@ -1,673 +0,0 @@
# 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
lib/DB.pm
View File

@ -1,947 +0,0 @@
# 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
lib/DB_Init.pm
View File

@ -1,648 +0,0 @@
# 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
lib/DB_Library.pm
View File

@ -1,497 +0,0 @@
# 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
lib/Deb.pm
View File

File diff suppressed because it is too large

456
lib/Deps.pm
View File

@ -1,456 +0,0 @@
# 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
lib/Dir.pm
View File

@ -1,110 +0,0 @@
# 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
lib/F.pm
View File

@ -1,92 +0,0 @@
# 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
lib/File.pm
View File

@ -1,877 +0,0 @@
# 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
lib/Findex.pm
View File

@ -1,358 +0,0 @@
# 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
lib/Format.pm
View File

@ -1,62 +0,0 @@
# 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
lib/Global.pm
View File

@ -1,62 +0,0 @@
# 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
lib/Groups.pm
View File

@ -1,73 +0,0 @@
# 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
lib/Indexer.pm
View File

@ -1,509 +0,0 @@
# 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
lib/Info.pm
View File

@ -1,586 +0,0 @@
# 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
lib/Library.pm
View File

@ -1,144 +0,0 @@
# 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
lib/MD.pm
View File

@ -1,268 +0,0 @@
# 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
lib/NDB.pm
View File

File diff suppressed because it is too large

251
lib/NDB_File.pm
View File

@ -1,251 +0,0 @@
# 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
lib/NDB_Init.pm
View File

File diff suppressed because it is too large

97
lib/Pn_print.pm
View File

@ -1,97 +0,0 @@
# 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
lib/Qftp.pm
View File

@ -1,951 +0,0 @@
# 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
lib/Ramdisk.pm
View File

@ -1,180 +0,0 @@
# 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
lib/Safex.pm
View File

@ -1,470 +0,0 @@
# 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
lib/Search.pm
View File

@ -1,850 +0,0 @@
# 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;
Write Preview
Loading…
Cancel
Save