mirror of https://github.com/fspc/dswim
freesource
23 years ago
28 changed files with 16953 additions and 0 deletions
@ -0,0 +1,263 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Ag; |
|||
use strict; |
|||
use SWIM::Global qw(:Info $file_now); |
|||
use SWIM::DB_Library qw(:Xyz); |
|||
use SWIM::Info; |
|||
use SWIM::Pn_print; |
|||
use SWIM::Deps; |
|||
use vars qw(@ISA @EXPORT); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(description q_description); |
|||
|
|||
|
|||
# stuff to query package names, -a, and groups |
|||
|
|||
# -qi <packages name> Anotherwards that big thing of info...also |
|||
# -c, -l |
|||
sub description { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
|
|||
if (!$commands->{"n"}) { |
|||
dbi(\%commands); |
|||
} |
|||
else { |
|||
ndb(\%commands); |
|||
} |
|||
|
|||
|
|||
if (defined $argument) { |
|||
# We will check for more than two..just in case |
|||
if ($argument !~ /_/) { |
|||
if (defined $db{$argument}) { |
|||
$argument = $db{$argument}; |
|||
} |
|||
} |
|||
if ($db{"$argument"}){ |
|||
my $package = $db{"$argument"}; |
|||
print $package; |
|||
} |
|||
else { |
|||
print "package $argument is not installed\n"; |
|||
exit; |
|||
} |
|||
} |
|||
untie %db; |
|||
|
|||
|
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
|
|||
if ($commands->{"c"} && !($commands->{"l"} || $commands->{"d"})) { |
|||
if (conf(\%commands) ne 0) { |
|||
print conf(\%commands) if !$commands->{"md5sum"}; |
|||
# here for a reason |
|||
# if -i because calls from qindexer. |
|||
if ($commands->{"i"}) { |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
file(\%commands) |
|||
} |
|||
} |
|||
} |
|||
if (($commands->{"c"} && ($commands->{"l"} || $commands->{"d"})) || |
|||
($commands->{"l"} || $commands->{"d"})) { |
|||
if ($commands->{"c"} && conf(\%commands) ne 0) { |
|||
print conf(\%commands) if !$commands->{"md5sum"}; |
|||
} |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
file(\%commands); |
|||
} |
|||
|
|||
if (!($commands->{"z"} || $commands->{"ftp"} || |
|||
$commands->{"remove"} || $commands->{"r"} || |
|||
$commands->{"purge"})) { |
|||
if ($commands->{"x"} || $commands->{"ftp"} || $commands->{"source"} || |
|||
$commands->{"source_only"} || $commands->{"remove"} || |
|||
$commands->{"r"} || $commands->{"purge"}) { |
|||
require SWIM::Safex; |
|||
SWIM::Safex->import(qw(safex)); |
|||
safex(\%commands); |
|||
} |
|||
} |
|||
|
|||
} # end sub description |
|||
|
|||
# Access Descriptions, and other stuff for known <packages>. |
|||
# This includes -ql(d)c, -qc or plain -q (just the package name and |
|||
# version). Anotherwards if -i isn't used this sub is called. And |
|||
# -ql is handled by file. Mostly, this was designed for calling a single |
|||
# package name on the command line without a known package title except |
|||
# when -q is called by itself, but using -T is an exception since this is |
|||
# useful. |
|||
sub q_description { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
|
|||
|
|||
if (!$commands->{"n"}) { |
|||
dbi(\%commands); |
|||
} |
|||
else { |
|||
ndb(\%commands); |
|||
} |
|||
|
|||
|
|||
if (defined $argument) { |
|||
if ($argument !~ /_/) { |
|||
if (defined $db{$argument}) { |
|||
$argument = $db{$argument}; |
|||
} |
|||
if ($commands->{"c"} && $commands->{"d"}) { |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
print "$argument\n" if $commands->{"g"}; |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
if (conf(\%commands) ne 0) { |
|||
print conf(\%commands) if !$commands->{"md5sum"}; |
|||
} |
|||
# it's nice to print out -d with -c, so this was added. |
|||
file(\%commands); |
|||
} |
|||
elsif ($commands->{"c"}) { |
|||
# this produces annoying spaces |
|||
print "$argument\n" if $commands->{"g"} && conf(\%commands) ne 0; |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
if (conf(\%commands) ne 0) { |
|||
print conf(\%commands) if !$commands->{"md5sum"}; |
|||
if ($commands->{"md5sum"}) { |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
file(\%commands); |
|||
} |
|||
} |
|||
} |
|||
elsif ($db{$argument} && !$commands->{"c"}) { |
|||
print "$argument\n" if $commands->{"T"} || |
|||
$commands->{"depends"} || $commands->{"pre_depends"} || |
|||
$commands->{"recommends"} || $commands->{"suggests"} || |
|||
$commands->{"conflicts"} || $commands->{"replaces"} || |
|||
$commands->{"provides"}; |
|||
singular(\%commands); |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
print "\n" if $commands->{"T"} || |
|||
$commands->{"depends"} || $commands->{"pre_depends"} || |
|||
$commands->{"recommends"} || $commands->{"suggests"} || |
|||
$commands->{"conflicts"} || $commands->{"replaces"} || |
|||
$commands->{"provides"}; |
|||
} |
|||
else { print "package $argument is not installed\n"; } |
|||
} |
|||
elsif ($argument =~ /_/) { |
|||
if ($commands->{"c"} && $commands->{"d"}) { |
|||
print "$argument\n" if $commands->{"g"}; |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
print conf(\%commands) if conf(\%commands) ne 0 && !$commands->{"md5sum"}; |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
file(\%commands); |
|||
} |
|||
elsif ($commands->{"c"}) { |
|||
my $check = conf(\%commands); |
|||
print "$argument\n" if $commands->{"g"} && $check ne 0 || |
|||
$commands->{"l"}; |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
if (conf(\%commands) ne 0) { |
|||
print conf(\%commands) if !$commands->{"md5sum"}; |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
file(\%commands); |
|||
} |
|||
elsif (conf(\%commands) == 0) { |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
file(\%commands); |
|||
} |
|||
} |
|||
elsif ($db{$argument} && !$commands->{"c"}) { |
|||
# watch this |
|||
##print "$argument\n" if $commands->{"g"}; |
|||
print "$argument\n" if $commands->{"T"} || |
|||
$commands->{"depends"} || $commands->{"pre_depends"} || |
|||
$commands->{"recommends"} || $commands->{"suggests"} || |
|||
$commands->{"conflicts"} || $commands->{"replaces"} || |
|||
$commands->{"provides"}; |
|||
singular(\%commands); |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
print "\n" if $commands->{"T"} || |
|||
$commands->{"depends"} || $commands->{"pre_depends"} || |
|||
$commands->{"recommends"} || $commands->{"suggests"} || |
|||
$commands->{"conflicts"} || $commands->{"replaces"} || |
|||
$commands->{"provides"}; |
|||
} |
|||
else { print "package $argument is not installed\n"; } |
|||
} |
|||
|
|||
} |
|||
untie %db; |
|||
|
|||
if (!defined $file_now && |
|||
!($commands->{"z"} || $commands->{"ftp"} || |
|||
$commands->{"remove"} || $commands->{"r"} || |
|||
$commands->{"purge"})) { |
|||
if ($commands->{"x"} || $commands->{"ftp"} || $commands->{"source"} || |
|||
$commands->{"source_only"} || $commands->{"remove"} || |
|||
$commands->{"r"} || $commands->{"purge"}) { |
|||
require SWIM::Safex; |
|||
SWIM::Safex->import(qw(safex)); |
|||
safex(\%commands); |
|||
} |
|||
} |
|||
} # end sub q_description |
|||
|
|||
|
|||
|
|||
|
|||
|
|||
1; |
|||
File diff suppressed because it is too large
@ -0,0 +1,358 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Compare; |
|||
use strict; |
|||
use SWIM::Conf qw($dpkg); |
|||
use SWIM::Library; |
|||
use vars qw(@ISA @EXPORT %EXPORT_TAGS); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(comparison compare_versions); |
|||
|
|||
# comparison function and checking function (-v) for not-installed databases |
|||
|
|||
=pod |
|||
|
|||
DEVELOPMENTAL |
|||
|
|||
This uses the comparison method mentioned in the packaging manual. It |
|||
will look for an epoch *: or the absence, and a revision -* or the |
|||
absence. First the epoch is compared, then the upstream-version, than |
|||
the debian-revision. The sub will stop and return a value as soon as |
|||
a difference is found. A look in the dpkg attic helped out (compare_vnumbers) |
|||
here, but lib.pl used separate subs, and doesn't appear to check for |
|||
an epoch separately, ofcourse there may have not been an epoch. This |
|||
uses the special variable $&, but apparently this isn't as big a waste |
|||
of resources in later versions of Perl, but there will be some |
|||
experiments and benchmarks for alternatives in the future for this sub. |
|||
There some rules built into comparison() to deal with patch to non-patch, |
|||
more than one hyphen (-). This involves a little transformation. |
|||
You can verify that this sub is working by doing perl -e '$five =\ |
|||
system "dpkg --compare-versions 10 gt 1.0.17"; print "nop\n" if $five\ |
|||
== 256; print "yes\n" if $five == 0', take a look at the scripts, too. |
|||
Also, use -v (compare_versions()) when using --initndb or --rebuildndb |
|||
for a report. |
|||
|
|||
=cut |
|||
|
|||
sub comparison { |
|||
|
|||
# $pversion = version from Packages.gz |
|||
# $eversion = version from nstatusindex-arch-dist.deb |
|||
|
|||
my($pversion,$eversion) = @_; |
|||
my($epoch, $upstream, $revision); |
|||
my($eepoch, $eupstream, $erevision); |
|||
my($revisiond,$erevisiond); |
|||
my $result; |
|||
|
|||
# If the two versions "eq" one another no reason to go on |
|||
if ($pversion ne $eversion) { |
|||
|
|||
# check epoch first, go on if the same |
|||
######### |
|||
# EPOCH # |
|||
######### |
|||
if ($pversion =~ /:/ || $eversion =~ /:/) { |
|||
if ($pversion =~ /:/) { |
|||
($epoch,$upstream) = split(/:/,$pversion,2); |
|||
} |
|||
else { |
|||
$epoch = 0; $upstream = $pversion; |
|||
} |
|||
if ($eversion =~ /:/) { |
|||
($eepoch,$eupstream) = split(/:/,$eversion,2); |
|||
} |
|||
else { |
|||
$eepoch = 0; $eupstream = $eversion; |
|||
} |
|||
do { |
|||
|
|||
$epoch =~ s/^\d*//; my $epochd = $&; |
|||
$eepoch =~ s/^\d*//; my $eepochd = $&; |
|||
$result = $epochd <=> $eepochd; |
|||
return "<" if $result == -1; |
|||
return ">" if $result == 1; |
|||
|
|||
} while (length ($epoch) && length ($eepoch)); |
|||
#return length ($a) cmp length ($b); |
|||
} # end if epoch |
|||
else { |
|||
$epoch = 0; $upstream = $pversion; |
|||
$eepoch = 0; $eupstream = $eversion; |
|||
} |
|||
|
|||
# Check the upstream-revision next |
|||
##################### |
|||
# UPSTREAM-REVISION # |
|||
##################### |
|||
if ($upstream || $eupstream) { |
|||
# we need to run a little test in case hyphens exists more than once |
|||
if ($upstream =~ /-/) { |
|||
my $hyphen = ($upstream =~ tr/-//); |
|||
if ($hyphen > 1) { |
|||
$upstream =~ m,(^.*)-(.*$),; |
|||
$upstream = $1; |
|||
$revision = $2; |
|||
} |
|||
else { |
|||
($upstream,$revision) = split(/-/,$upstream,2); |
|||
} |
|||
} |
|||
else { |
|||
# because the absence is considered earlier, and the convention |
|||
# is to use -1. |
|||
$revision = 0; |
|||
} |
|||
# we need to run a little test in case hyphens exists more than once |
|||
if ($eupstream =~ /-/) { |
|||
my $hyphen = ($eupstream =~ tr/-//); |
|||
if ($hyphen > 1) { |
|||
$eupstream =~ m,(^.*)-(.*$),; |
|||
$eupstream = $1; |
|||
$erevision = $2; |
|||
} |
|||
else { |
|||
($eupstream,$erevision) = split(/-/,$eupstream,2); |
|||
} |
|||
} |
|||
else { |
|||
# because the absence is considered earlier, and the convention |
|||
# is to use -1. |
|||
$erevision = 0; |
|||
} |
|||
do { |
|||
# letters |
|||
$upstream =~ s/^\D*//; my $upstreamd = $&; |
|||
$eupstream =~ s/^\D*//; my $eupstreamd = $&; |
|||
|
|||
# hopefully this handles nasty beta situations |
|||
if ($upstreamd eq "b" and $eupstreamd eq "." ) { |
|||
return "<"; |
|||
} |
|||
elsif ($upstreamd eq "." and $eupstreamd eq "b" ) { |
|||
return ">"; |
|||
} |
|||
elsif ($upstreamd eq "beta" and $eupstreamd eq "." ) { |
|||
return "<"; |
|||
} |
|||
elsif ($upstreamd eq "." and $eupstreamd eq "beta" ) { |
|||
return ">"; |
|||
} |
|||
elsif ($upstreamd eq "." and $eupstreamd eq "-pre-") { |
|||
return ">"; |
|||
} |
|||
elsif ($eupstreamd eq "." and $upstreamd eq "-pre-") { |
|||
return "<"; |
|||
} |
|||
|
|||
# solves problems when "." is compared to letters, and also a weird |
|||
# case involving a patched version changing to a non-patched version. |
|||
if ($upstreamd =~ /\./) { |
|||
if ($eupstreamd =~ /\w/) { |
|||
if ($eupstreamd =~ /pl/ && $upstreamd !~ /pl/) { |
|||
$eupstreamd = ""; |
|||
} |
|||
elsif ($upstreamd !~ /\.\w{2,10}/) { |
|||
$eupstreamd = "."; |
|||
} |
|||
} |
|||
elsif ($eupstreamd eq "") { |
|||
$eupstreamd = "."; |
|||
} |
|||
} |
|||
# the weird -pre situation |
|||
elsif ($upstreamd =~ /-pre/ || $eupstreamd =~ /-pre/) { |
|||
$upstreamd = ""; $eupstreamd = ""; |
|||
} |
|||
|
|||
if ( $eupstreamd =~ /\./) { |
|||
if ($upstreamd =~ /\w/) { |
|||
if ($upstreamd =~ /pl/ && $eupstreamd !~ /pl/) { |
|||
$upstreamd = ""; |
|||
} |
|||
elsif ($upstreamd !~ /\.\w{2,10}/) { |
|||
$upstreamd = "."; |
|||
} |
|||
} |
|||
elsif ($upstreamd eq "") { |
|||
$upstreamd = "."; |
|||
} |
|||
} |
|||
# the weird -pre situation |
|||
elsif ($upstreamd =~ /-pre/ || $eupstreamd =~ /-pre/) { |
|||
$upstreamd = ""; $eupstreamd = ""; |
|||
} |
|||
|
|||
$result = $upstreamd cmp $eupstreamd; |
|||
return "<" if $result == -1; |
|||
return ">" if $result == 1; |
|||
# it's importantant to realize that . & + are being checked for |
|||
# above. : and - have already been dealt with. cmp seems to deal with |
|||
# these characters with no problems. |
|||
|
|||
|
|||
# numbers |
|||
|
|||
# found a little problem with <=> when number's eq "", |
|||
# but this doesn't effect cmp. |
|||
if ($upstream eq "") { |
|||
if ($eupstream eq ".") { |
|||
$upstream = "."; |
|||
} |
|||
else { |
|||
$upstream = 0; |
|||
} |
|||
} |
|||
if ( $eupstream eq "") { |
|||
if ($upstream eq ".") { |
|||
$eupstream = "."; |
|||
} |
|||
else { |
|||
$eupstream = 0; |
|||
} |
|||
} |
|||
|
|||
$upstream =~ s/^\d*//; $upstreamd = $&; |
|||
$eupstream =~ s/^\d*//; $eupstreamd = $&; |
|||
$result = $upstreamd <=> $eupstreamd; |
|||
return "<" if $result == -1; |
|||
return ">" if $result == 1; |
|||
} while (length ($upstream) || length ($eupstream)) |
|||
} # end if upstream |
|||
else { |
|||
$revision = 0; |
|||
$erevision = 0; |
|||
} |
|||
|
|||
# Finally, check the revision |
|||
############ |
|||
# REVISION # |
|||
############ |
|||
if ($revision || $erevision) { |
|||
do { |
|||
# letters |
|||
$revision =~ s/^\D*//; $revisiond = $&; #$revisiond =~ s/\W/ /g; |
|||
$erevision =~ s/^\D*//; $erevisiond = $&; #$erevisiond =~ s/\W/ /g; |
|||
|
|||
# pre in the revision |
|||
if ($revisiond eq "." and $erevisiond eq "pre") { |
|||
return "r>"; |
|||
} |
|||
elsif ($erevisiond eq "." and $revisiond eq "pre") { |
|||
return "r<"; |
|||
} |
|||
$result = $revisiond cmp $erevisiond; |
|||
return "r<" if $result == -1; |
|||
return "r>" if $result == 1; |
|||
# it's importantant to realize that . & + are being checked for |
|||
# above. : and - have already been dealt with. cmp seems to deal with |
|||
# these characters with no problems. |
|||
|
|||
# numbers |
|||
# found a little problem with <=> when number's eq "", |
|||
# but this doesn't effect cmp. |
|||
if ($revision eq "") { |
|||
if ($erevision eq ".") { |
|||
$revision = "."; |
|||
} |
|||
else { |
|||
$revision = 0; |
|||
} |
|||
} |
|||
if ( $erevision eq "") { |
|||
if ($revision eq ".") { |
|||
$erevision = "."; |
|||
} |
|||
else { |
|||
$erevision = 0; |
|||
} |
|||
} |
|||
|
|||
$revision =~ s/^\d*//; $revisiond = $&; |
|||
$erevision =~ s/^\d*//; $erevisiond = $&; |
|||
$result = $revisiond <=> $erevisiond; |
|||
return "r<" if $result == -1; |
|||
return "r>" if $result == 1; |
|||
} while (length ($revision) && length ($erevision)); |
|||
} # end if revision |
|||
|
|||
# still 0? check the remainder..this is just for letters which may have |
|||
# been mulled over because they looked like words \w. |
|||
if ($result == 0) { |
|||
$result = $epoch cmp $eepoch || $upstream cmp $eupstream || |
|||
$revision cmp $erevision; |
|||
return "<" if $result == -1; |
|||
return ">" if $result == 1; |
|||
} |
|||
} |
|||
|
|||
} # end sub comparison |
|||
|
|||
|
|||
# This produces a report to make sure that comparison() is up to par, and |
|||
# is called with -v. It uses dpkg's --compare-versions. The advantage of |
|||
# not normally running --compare-versions is portability. People using |
|||
# other distribution's don't need dpkg installed, and people using weird |
|||
# Oses who can't use dpkg can still explore a virtual installation. |
|||
sub compare_versions { |
|||
|
|||
# The test result is put in .version_compare |
|||
|
|||
# $result = operand (result from comparison) |
|||
# $virtual = version from Packages.gz |
|||
# $installed = version from nstatusindex-arch-dist.deb |
|||
# $name = packagename |
|||
# $commands = options |
|||
|
|||
my ($result, $virtual, $installed, $name, $commands) = @_; |
|||
my %commands = %$commands; |
|||
my ($cv, $cv_result, $cresult); |
|||
my $place = finddb(\%commands); |
|||
|
|||
# usually it will be greater |
|||
if (defined $dpkg) { |
|||
$cv = system "$dpkg", "--compare-versions", "$virtual", "gt", "$installed"; |
|||
|
|||
$cv_result = "no" if $cv == 256; |
|||
$cv_result = "yes" if $cv == 0; |
|||
#$cresult = "no" if $result =~ m,[r]?<,; |
|||
#$cresult = "yes" if $result =~ m,[r]?>,; |
|||
$cresult = "no" if $result eq "<" || $result eq "r<"; |
|||
$cresult = "yes" if $result eq ">" || $result eq "r>"; |
|||
|
|||
open(CV,">>$place/.version_compare") |
|||
or warn "couldn't create version compare report\n"; |
|||
if ($cresult eq "yes" && $cv_result eq "no") { |
|||
print CV "$name:\ndpkg - $virtual < $installed\nswim - $virtual > $installed\n\n"; |
|||
} |
|||
elsif ($cresult eq "no" && $cv_result eq "yes") { |
|||
print CV "$name:\ndpkg - $virtual > $installed\nswim - $virtual < $installed\n\n"; |
|||
} |
|||
else { |
|||
return; |
|||
} |
|||
close(CV); |
|||
} |
|||
|
|||
} # end sub compare_versions |
|||
|
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,673 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Conf; |
|||
use vars qw(@ISA @EXPORT %EXPORT_TAGS); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
|
|||
@EXPORT = qw($my_number $tmp $architecture $distribution @user_defined_section |
|||
$default_directory $default_root_directory $permission $dpkg |
|||
$dpkg_deb $ar $gcc $apt_get $apt_cache $sources @FTP $spl $cat |
|||
$sort $md5sum $zcat $tar $grep $gzip $fastswim $slowswim $longswim |
|||
$mount $umount $mke2fs $copy $pager $base $pwd $parent $library |
|||
$splt $mv $imswim $swim_conf $debug $port $timeout |
|||
$firewall $passive $apt_sources $HISTORY $alt); |
|||
%EXPORT_TAGS = ( |
|||
Path => [ qw($tmp $parent $base $library) ], |
|||
Deb => [ qw($pwd $dpkg_deb $ar $tar $grep $tmp $md5sum $cat $mv) ], |
|||
Qftp => [ qw($default_root_directory $permission @FTP |
|||
$default_directory $swim_conf) ], |
|||
Info => [ qw($parent $base $zcat) ] |
|||
); |
|||
|
|||
|
|||
|
|||
############################# |
|||
# DEFAULT PROGRAM VARIABLES # |
|||
############################# |
|||
|
|||
# You can change this to how many lines you would like "swim -qf <>" to |
|||
# print out, before asking for -t or --total, it will automatically ask |
|||
# though, if there is more than one package and you used the option -i. |
|||
# Remember -t can be used with --scripts family members to view the |
|||
# title of the script file regardless of this setting, and if -t has to be |
|||
# used, the titles will be displayed, which makes sense. |
|||
$my_number = 23; |
|||
|
|||
# Just like a shell, you can keep a history of whatever length you want. |
|||
$HISTORY = 10; |
|||
|
|||
# For not-installed: |
|||
# This part supplies the default value for --arch. |
|||
# |
|||
# You can determine the default architecture used when -n is |
|||
# called or a not-installed database is made. Architectures are always |
|||
# being added so check with Debian to find a list. There is alpha, arm, |
|||
# hurd (alternative kernel to linux), i386, m68k, powerpc, sparc. Just use |
|||
# the arch found after the hyphen in the Contents-(arch) file. |
|||
$architecture = "i386"; |
|||
|
|||
# For not-installed: |
|||
# This part supplies the default value for --dists. |
|||
# |
|||
# The default distribution can be either stable, unstable, frozen, or |
|||
# experimental (rare). These represent the state of development that the |
|||
# packages are under. The unstable distribution can have lot's of changes |
|||
# within a very short time period, and frozen may or may not be available. |
|||
$distribution = "unstable"; |
|||
|
|||
|
|||
#For not-installed: |
|||
#This part supplies the default value for --main, --contrib, --non-free, |
|||
#and --non-us. |
|||
|
|||
# Distributions are divided into the sections. These sections are called |
|||
# distributions in the version 2.4.1.0 packaging manual, because they were at |
|||
# one time separate distributions, but this has since changed. You can |
|||
# determine which of these sections (main, non-free, contrib or non-US) to |
|||
# pull out of the Contents file if you don't want to use --main, --contrib, |
|||
# --non-free, and --non-us to selectively pick sections. Basically, whatever |
|||
# you pull out should match the Package(s) file(s) you are targetting, this |
|||
# program is friendly if you make a mistake, but it's more effecient to pull |
|||
# out just what you want. If the same package happens to exist in two |
|||
# different sections, main and non-us for example (which is really a |
|||
# situation that shouldn't exist, yet it does), you will still be able to |
|||
# find this package in the non-us group, but its section and locations will be |
|||
# the one which main recognizes assuming that you use the order in the example |
|||
# below. |
|||
|
|||
# Setting it up: |
|||
# Example: You just want to pull out main and contrib every time you run |
|||
# --initndb, --rebuildndb, or --ndb. |
|||
# @user_defined_section = qw(main contrib non-US); |
|||
# remember "non-US" not "non-us". |
|||
|
|||
# untill non-US is fixed the second is better |
|||
#@user_defined_section = qw(main contrib non-free non-US); |
|||
@user_defined_section = qw(main contrib non-free); |
|||
|
|||
# Usually, this is |
|||
$alt = "debian"; |
|||
|
|||
################ |
|||
# DF LOCATION # |
|||
################ |
|||
|
|||
# A little philosophy: |
|||
# swim was developed for maximum versatility, so whether you are just |
|||
# interested in researching, and keeping tabs on the newest packages, |
|||
# or maintaining a Debian virtual distribution on a non-Debian real |
|||
# distribution, or you are a using swim for distribution development, swim |
|||
# provides a way. The default directory (DF - which can also mean |
|||
# directory/file) keeps track of Contents and Packages files downloaded |
|||
# using --ftp, and gives the files names specific to the distribution and |
|||
# architectures they represent. But, you also have the freedom not to use |
|||
# the default directory in this case swim will still do the renaming and |
|||
# keeping track of the mtime, but you will have to remember where you put |
|||
# the files. On the other hand, if you use apt, you won't even have to use |
|||
# the DF directory for Packages files because you can get the ones specific |
|||
# to your own systems architecture from apt, but if you want to look at |
|||
# other architectures you will need to use the DF directory or one of your |
|||
# own choice. |
|||
# Naming Convention: Contents = Contents-dist.gz |
|||
# Packages = Packages-arch-dist-section.gz |
|||
$default_directory = '/root/.swim'; |
|||
|
|||
|
|||
# The default root directory is the key to easy management of packages |
|||
# downloaded through --ftp and --file, and provides an easy way to put together |
|||
# a personalized distribution. Future implementations of swim will provide |
|||
# a distribution called personal..Packages and Contents files specific to |
|||
# this distribution will automatically be made. This directory can be a |
|||
# real ftp site on your computer, or put where ever else you are allowed |
|||
# to have directories. dists/distribution/section/architecture/subject will be |
|||
# placed above this directory. No matter what, debian must be the final |
|||
# directory before dists. Other distributions are placed alongside debian, |
|||
# like debian-non-US or personal. |
|||
# Feel free to change the permissions. This directory is above your default_ |
|||
# directory. |
|||
$default_root_directory = '/pub/debian'; |
|||
|
|||
# Because you may be using a real ftp site, this configuration allows you |
|||
# to determine what permissions swim will set for directories it creates |
|||
# above the default root directory. |
|||
$permission = '0755'; |
|||
|
|||
|
|||
############### |
|||
# AR or DPKG? # |
|||
############### |
|||
|
|||
# NOTE: users set these next two with the $package_tool variable. |
|||
|
|||
# packaging friends dpkg and dpkg-deb come from the essential and |
|||
# required dpkg package. ar from the package binutils can also be used (below). |
|||
# This is the archival program used for deb packages, but binutils is just |
|||
# a standard non-essential package, and the ar capabilities are built into |
|||
# dpkg-deb, and it's better not to assume that the standard packages are |
|||
# even established, yet. |
|||
$dpkg = (); |
|||
$dpkg_deb = (); |
|||
|
|||
|
|||
# If you don't have the dpkg package on your system then you can use ar |
|||
# from the package binutils. This would be a standard, but not an essential |
|||
# package in Debian, but this package is also fairly standard amongst all |
|||
# distributions, and can even be found in the free djgpp for M$ Oses. |
|||
# Since people who have both dpkg and ar may want to try the ar method, |
|||
# rather than creating an automatic check, just assign a value to either |
|||
# ($dpkg & $dpkg_deb) or just $ar. |
|||
#my $ar = '/usr/bin/ar'; # same for RH |
|||
$ar = '/usr/bin/ar'; |
|||
|
|||
|
|||
####### |
|||
# APT # |
|||
####### |
|||
|
|||
# NOTE: users set apt-get and apt-cache with the $apt variable |
|||
|
|||
# If you have apt you are in luck. |
|||
$apt_get = (); |
|||
$apt_cache = (); |
|||
$sources = '/etc/apt/sources.list'; |
|||
$apt_sources = '/var/state/apt/lists'; |
|||
|
|||
######### |
|||
# PAGER # |
|||
######### |
|||
|
|||
# less is a nice pager, unless you like more! There is an option |
|||
# --nopager or -n. Pager is used for --help and swim called without any |
|||
# options. more comes from the required package util-linux, whereas |
|||
# less comes from a standard package called less. In the future there is |
|||
# a possiblity that a large percentage of swim may use an internal pager. |
|||
# less, more, or most or... |
|||
#$ENV{PAGER} = "/usr/bin/less"; # same RH |
|||
$ENV{PAGER} = "less"; |
|||
$pager = $ENV{PAGER}; |
|||
|
|||
|
|||
|
|||
################# |
|||
# SWIM PROGRAMS # |
|||
################# |
|||
|
|||
# This is replaced by the Makefile. |
|||
$pre="/usr"; |
|||
|
|||
# This is the hash making program fastswim. |
|||
$fastswim = "$pre/lib/SWIM/fastswim"; |
|||
|
|||
# imswim in an alternative to fastswim for --lowmem |
|||
$imswim = "$pre/lib/SWIM/imswim"; |
|||
|
|||
# This is the low memory program slowswim. |
|||
$slowswim = "$pre/lib/SWIM/slowswim"; |
|||
|
|||
# This is the dir/file making program longswim. |
|||
$longswim = "$pre/lib/SWIM/longswim"; |
|||
|
|||
############ |
|||
# TEMP DIR # |
|||
############ |
|||
|
|||
# If you want to set an alternative directory for the temporary files |
|||
# created when the databases are made, change here. You may want to make |
|||
# $tmp a RAM disk. See package loadlin for initrd documentation and an |
|||
# explanation for making such a disk. There is also |
|||
# /usr/src/kernel-source.version/Documentation. Whether this will speed |
|||
# things up is a subject of experimentation. |
|||
$tmp = '/tmp'; |
|||
|
|||
################## |
|||
# MAIN CONFFILES # |
|||
################## |
|||
|
|||
# if configuration files are not kept in /etc change this |
|||
# and set up the directories by hand. |
|||
|
|||
$swim_conf = '/etc/swim'; |
|||
|
|||
|
|||
############# |
|||
# UTILITIES # |
|||
############# |
|||
|
|||
|
|||
# This probably never will have to be changed. |
|||
$pwd = `pwd`; |
|||
chomp $pwd; |
|||
|
|||
# If the command split is somewhere else besides /usr/bin change this. |
|||
# The required package textutils provides this. |
|||
#my $splt = '/usr/bin/split'; # same RH |
|||
$splt = 'split'; |
|||
|
|||
# cat comes from the essential and required package textutils. |
|||
#my $cat = '/bin/cat'; # same RH |
|||
$cat = 'cat'; |
|||
|
|||
# This command also omes from the required and essential package textutils. |
|||
#my $sort = '/usr/bin/sort'; # same RH |
|||
$sort = 'sort'; |
|||
|
|||
# This program uses md5sum from the dpkg package, it can also use md5sum |
|||
# from the RH package. |
|||
#my $md5sum = '/usr/bin/md5sum'; # same RH |
|||
$md5sum = 'md5sum'; |
|||
|
|||
# If you want to view compressed files make sure this is correct. |
|||
# The required package gzip provides this. |
|||
#my $zcat = '/bin/zcat'; # same RH |
|||
$zcat = 'zcat'; |
|||
|
|||
# tar comes from the essential and required package tar. |
|||
#my $tar = '/bin/tar'; # same RH |
|||
$tar = 'tar'; |
|||
|
|||
# grep comes from the essential and required package grep. This seems |
|||
# to require a path. |
|||
$grep = '/bin/grep'; # same RH |
|||
|
|||
# gzip comes from the essential and required package gzip. |
|||
#my $gzip = "/bin/gzip"; # same RH |
|||
$gzip = "gzip"; |
|||
|
|||
# mount comes from the essential and required package mount. |
|||
#my $mount = '/bin/mount'; # same RH |
|||
#my $umount = '/bin/umount'; # same RH |
|||
$mount = 'mount'; |
|||
$umount = 'umount'; |
|||
|
|||
# If your file system isn't an ext2 filesystem, you may want to change |
|||
# this. mke2fs comes from the essential and required package e2fsprogs. |
|||
#my $mke2fs = '/sbin/mke2fs'; # same RH |
|||
$mke2fs = 'mke2fs'; |
|||
|
|||
# cp and mv from the essential and required package fileutils |
|||
#my $copy = '/bin/cp'; # same RH |
|||
$copy = 'cp'; |
|||
$mv = 'mv'; |
|||
|
|||
# Your system definitely has gcc if you have ar. gcc is a standard package |
|||
# in debian. |
|||
$gcc = 'gcc'; |
|||
|
|||
|
|||
###### |
|||
# FTP # |
|||
####### |
|||
|
|||
# Major mode --ftp and --file automates the download of Contents and Packages |
|||
# files. Even if you have apt installed, you may still want to download Packages |
|||
# from alternative architectures, and the Contents file for your own architecture |
|||
# or other architectures. If you want virtual and/or -ld capabilities you need |
|||
# the Contents file. You specify a list of ftp or file sites using urls (like |
|||
# apt). For your system's architecture specify the type deb, for other |
|||
# architectures specify deb(hyphen)architecture (ex: deb-alpha). Regardless of |
|||
# whether or not you specify an architecture, deb implies /dist* found under the |
|||
# base directory specified by the ftp url, except in the case of experimental, |
|||
# and to a degree non-us. minor mode --ftp, and --file will use the sites in this |
|||
# configuration as well, on a fifo (first in first out) basis, so choose the |
|||
# order of sites based on which are closest, most current, as well as fast. |
|||
|
|||
# IMPORTANT: It is a BIG MISTAKE to use the distributions name (slink,po,etc) |
|||
# anywhere in the sources list, or in swim's configuration file..in fact swim |
|||
# won't work properly, not to mention the fact that someday your favorite name |
|||
# will suddenly disappear. This is because swim thinks in terms of the real |
|||
# distribution name (stable,unstable,frozen, experimental). The problem goes |
|||
# like this - slink remains slink, but goes from unstable to frozen to stable. |
|||
# At first, using the distributions alias may seem appropriate, but the |
|||
# purpose of swim is to keep tabs on the dists, and not to ignore changes in |
|||
# the states, this also makes managing swim's databases much easier and |
|||
# intuitive...more about this later. |
|||
|
|||
# Fun experiments: Swim uses the naming conventions of apt, but leaves the |
|||
# Package files compressed in the DF directory. So you can always decompress |
|||
# the databases and move them to /var/state/apt/lists. This ofcourse assumes |
|||
# that the appropriate changes to the sources.list reflecting these Packages |
|||
# (need to be the same architecture as your system) existed before you |
|||
# update. (author needs to do this experiment :*) |
|||
|
|||
$ftp1 = "deb ftp://localhost/pub/debian unstable main contrib non-free non-US"; |
|||
$ftp2 = "deb ftp://localhost/pub/debian unstable main contrib non-free"; |
|||
$ftp3 = "deb ftp://localhost/pub/debian project/experimental/"; |
|||
@FTP = ($ftp1,$ftp2,$ftp3); |
|||
|
|||
# These next variables allow some characteristics of the ftp client |
|||
# to be altered. See Net::FTP for ways of altering some of these |
|||
# variables through the environment. |
|||
|
|||
$firewall = 0; |
|||
$port = 0; |
|||
$timeout = 120; |
|||
$debug = 0; |
|||
$passive = 0; |
|||
|
|||
|
|||
######################################## |
|||
# STUFF THAT NEVER NEEDS TO BE CHANGED # |
|||
######################################## |
|||
|
|||
# You will never need to change this unless for some weird reason all the |
|||
# files under dpkg are somewhere else (including /info*) , see --dbpath as |
|||
# an alternative if you decide to access or make the databases somewhere |
|||
# else. I should point out that this program was designed to work with only |
|||
# one user .. root. |
|||
$base = '/var/lib/dpkg'; |
|||
|
|||
# --dbpath takes care of this so don't touch. |
|||
$parent = '/'; |
|||
$library = '/var/lib/dpkg'; |
|||
|
|||
|
|||
############################# |
|||
# LOAD CUSTOM CONFIGURATION # |
|||
############################# |
|||
|
|||
|
|||
# Here we load in the customized configuration which override the defaults |
|||
# Might as well use do, let the world learn Perl ... compare this to apt's |
|||
# configuation file with scopes. Swim's sources.list file (/etc/swim/swimz.list), |
|||
# will be grabbed at SWIM::Apt and SWIM::Qftp if it exists. |
|||
|
|||
do "$swim_conf/swimrc"; |
|||
do "$ENV{HOME}/.swim/swimrc"; |
|||
if ((defined $dpkg && !defined $dpkg_deb) || |
|||
(!defined $dpkg && defined $dpkg_deb)) { |
|||
print "swim: need to give both \$dpkg and \$dpkg_deb a value if you want dpkg\n"; |
|||
exit; |
|||
} |
|||
if (defined $package_tool) { |
|||
if ($package_tool =~ /ar/) { |
|||
$ar = $ar; |
|||
} |
|||
else { |
|||
$dpkg = 'dpkg'; |
|||
$dpkg_deb = 'dpkg-deb'; |
|||
undef $ar; |
|||
} |
|||
} |
|||
if (defined $apt) { |
|||
$apt_get = 'apt-get'; |
|||
$apt_cache = 'apt-cache'; |
|||
} |
|||
|
|||
|
|||
############################### |
|||
# MAKE ANY NEEDED DIRECTORIES # |
|||
############################### |
|||
|
|||
# make sure all the appropriate directories are made |
|||
if (!-d $default_directory) { |
|||
if (-e $default_directory) { |
|||
print "swim: can not create default directory because a file exists\n"; |
|||
exit; |
|||
} |
|||
my @DRD = split(m,/,,$default_directory); |
|||
my $placement = "/"; |
|||
for (1 .. $#DRD) { |
|||
$_ == 1 ? ($placement = "/$DRD[$_]") |
|||
: ($placement = $placement . "/" . $DRD[$_]); |
|||
-d $placement or mkdir("$placement",0755); |
|||
} |
|||
} |
|||
|
|||
if (!-d "$default_directory$default_root_directory") { |
|||
my @DRD = split(m,/,,$default_root_directory); |
|||
print "swim: debian must be the final directory before dists\n" |
|||
if $DRD[$#DRD] ne "debian"; |
|||
exit if $DRD[$#DRD] ne "debian"; |
|||
my $placement = "/"; |
|||
for (1 .. $#DRD) { |
|||
$_ == 1 ? ($placement = "/$DRD[$_]") |
|||
: ($placement = $placement . "/" . $DRD[$_]); |
|||
unless (-d "$default_directory$placement") { |
|||
mkdir("$default_directory$placement",0755) |
|||
or die "swim: could not create root default directory\n"; |
|||
} |
|||
} |
|||
} |
|||
|
|||
# Makefile will make sure these directories exist, unless for some strange |
|||
# reason you have to change them. |
|||
|
|||
if (!-d $library) { |
|||
mkdir($library,0755) or die "Couldn't create default directory\n"; |
|||
} |
|||
|
|||
if (!-d $base) { |
|||
mkdir($base,0755) or die "Couldn't create default directory\n"; |
|||
} |
|||
|
|||
if (!-d $swim_conf) { |
|||
mkdir($swim_conf,0666) or die "Couldn't create configuration file directory, |
|||
please make the directories which are needed.\n"; |
|||
} |
|||
|
|||
1; |
|||
|
|||
__END__ |
|||
|
|||
=head1 NAME |
|||
|
|||
swimrc - swim configuration file |
|||
|
|||
=head1 DESCRIPTION |
|||
|
|||
B<swimrc> is the configuartion file for swim allowing many default values |
|||
to be set so that they do not have to be mentioned on the command line. |
|||
Swimrc interacts directly with Perl allowing a wide variety of variables |
|||
found in B<SWIW::Conf> to be altered. |
|||
|
|||
=cut |
|||
|
|||
=head1 USAGE |
|||
|
|||
Values for variable can be altered for B<swim> by assigning different |
|||
values enclosed in quotes or quoted whitespace (qw()), and ended with a |
|||
semi-colon. |
|||
|
|||
$variable = "value"; |
|||
$variable = "qw(value1 value2 ..)"; |
|||
|
|||
=head1 VARIABLES |
|||
|
|||
This is a list of variables with explanations. The default values for |
|||
B<swim> are shown. |
|||
|
|||
=head2 OUTPUT VARIABLE |
|||
|
|||
$my_number can be changed to how many lines you would like "swim -qf <>" |
|||
to print out, before the program asks for C<-t> or C<--total>. Exception: |
|||
If C<-i> is used in the query and there is more than one package then the |
|||
total will be presented. |
|||
|
|||
Hint: C<-t> can be used with all the various C<--scripts> family members |
|||
to view the title of the script file regardless of this variable setting, |
|||
and if C<-t> has to be used, the titles will be displayed, which makes |
|||
sense. |
|||
|
|||
B<$my_number = 23;> |
|||
|
|||
=head2 HISTORY |
|||
|
|||
This is a shell-like history kept in relation to searches and the most |
|||
recent edit when C<--stdin> is used. |
|||
|
|||
B<$HISTORY = 10;> |
|||
|
|||
=head2 AR or DPKG? |
|||
|
|||
Debian packages are ar archives. If you are using a Debian Distribution |
|||
assign "dpkg" to $package_tool, otherwise assign "ar" to $package_tool. |
|||
|
|||
B<$package_tool = "/usr/bin/ar";> |
|||
|
|||
=head2 APT |
|||
|
|||
B<Swim> does not assign a value for apt. To use C<--apt> and C<-xyz> |
|||
assign $apt the value "yes". |
|||
|
|||
Example: B<$apt = "yes";> |
|||
|
|||
=head2 PAGER |
|||
|
|||
less is a nice pager, unless you like more! Pager is used for C<--help> |
|||
and B<swim> called without any options. There is an option C<--nopager> or |
|||
C<-n>. more comes from the required package util-linux, whereas less |
|||
comes from a standard package called less. Values: "less", "more", or |
|||
"most" or... |
|||
|
|||
B<$ENV{PAGER} = "less";> |
|||
|
|||
=head2 NOT-INSTALLED VARIABLES |
|||
|
|||
Assign values for $architecture and/or $distribution to avoid having to |
|||
use C<--arch> and C<--dists> everytime the not-installed databases are |
|||
accessed with C<-n> or made or altered. |
|||
|
|||
Architectures are always being added so check with Debian to find a list. |
|||
There is I<alpha, arm, hurd-i386 (alternative kernel to linux), i386, |
|||
m68k, powerpc, sparc>. Just use the arch found after the hyphen in the |
|||
Contents-(arch) file. |
|||
|
|||
B<$architecture = "i386";> |
|||
|
|||
The distribution can be either I<stable, unstable, frozen, or experimental |
|||
(rare)>. These represent the state of development that the packages are |
|||
under. The unstable distribution can have lot's of changes within a very |
|||
short time period, and frozen may or may not be available. |
|||
|
|||
B<$distribution = "unstable";> |
|||
|
|||
Distributions are divided into sections. These sections were called |
|||
distributions in the version 2.4.1.0 packaging manual, because they were |
|||
at one time separate distributions, but this has since changed. |
|||
|
|||
You can determine which of the sections I<main, non-free, contrib or |
|||
non-US> to pull out of the Contents file if you don't want to use |
|||
C<--main>, C<--contrib>, C<--non-free>, and C<--non-us> to selectively |
|||
pick the sections. |
|||
|
|||
For efficiency, you should choose the sections which you will be pulling |
|||
out of the Packages file(s) being targetted. |
|||
|
|||
Rule: Use "non-US" not "non-us". |
|||
|
|||
B<@user_defined_section = qw(main contrib non-free non-US);> |
|||
|
|||
=head2 DF LOCATION |
|||
|
|||
A little philosophy: B<swim> was developed for maximum versatility, so |
|||
whether you are just interested in researching, and keeping tabs on the |
|||
newest packages, or maintaining a Debian virtual distribution on a |
|||
non-Debian distribution, or you are a using B<swim> for distribution |
|||
development, B<swim> provides a way. |
|||
|
|||
The next two variables determine the location of the DF (default |
|||
directory/file system) |
|||
|
|||
The default directory keeps track of Contents and/or Packages databases |
|||
retrieved with --ftp. The Contents and Packages databases and Release |
|||
file are give names specific to the distribution and architectures they |
|||
represent using the naming convention found in apt's sources directory. |
|||
You also have the freedom not to use the default directory, in which case |
|||
swim will still do the renaming and keeping track of the mtime, but you |
|||
will have to remember where you put the files. |
|||
|
|||
B<$default_directory = '/root/.swim';> |
|||
|
|||
The default root directory (DRD) is the key to easy management of binary |
|||
packages, source, dsc, and diff files received from --ftp, and provides an |
|||
easy way to put together a personalized distribution. This directory can |
|||
be a real ftp site on your computer, or put wherever else you are |
|||
allowed to have directories. The DRD is always placed below the value |
|||
assigned to $default_directory. According to the previous assignment to |
|||
$default_directory, if the DRD is "/pub/a/debian" then the full path |
|||
would be "/root/.swim/pub/a/debian". |
|||
|
|||
Example: When a package is downloaded it will be placed in |
|||
dists/distribution/section/architecture/subject below the DRD. |
|||
|
|||
Rule: debian must be the final directory before dists, this is because |
|||
other distributions are placed alongside debian, like debian-non-US or |
|||
personal (specialized distribution). |
|||
|
|||
B<$default_root_directory = '/pub/debian';> |
|||
|
|||
Because you may be using a real ftp site, this variable allows you to |
|||
determine what permissions B<swim> will assign for directories it creates |
|||
below the DRD. |
|||
|
|||
B<$permission = '0755';> |
|||
|
|||
=head2 TEMPORARY DIRECTORY |
|||
|
|||
If you want to set an alternative directory for the temporary files |
|||
created when the databases are made, change here. You may want to make |
|||
$tmp a RAM disk. See package loadlin for initrd documentation and an |
|||
explanation for making such a disk. There is also documentation in |
|||
/usr/src/kernel-source.version/Documentation. Whether this will speed |
|||
things up is a subject of experimentation. |
|||
|
|||
B<$tmp = "/tmp";> |
|||
|
|||
=head2 FTP |
|||
|
|||
You can alter the Firewall, Port, Timeout, Debug and Passive |
|||
characteristics of the ftp client as defined in Net::FTP(3pm) by providing |
|||
arguments to these variables. All variables but $timeout are set to untrue |
|||
by default. |
|||
|
|||
$firewall = 0; (FTP firewall machine name) |
|||
$port = 0; (defaults to 23) |
|||
$timeout = 120; (120 seconds) |
|||
$debug = 0; (1 will turn on STDERR) |
|||
$passive = 0; (1 will enable) |
|||
|
|||
=head1 OTHER VARIABLES |
|||
|
|||
see SWIM::Conf |
|||
|
|||
=head1 FILES |
|||
|
|||
/etc/swim/swimrc |
|||
~/.swim/swimrc |
|||
|
|||
=head1 SEE ALSO |
|||
|
|||
swim(8), Net::FTP(3pm) |
|||
|
|||
=head1 BUGS |
|||
|
|||
Send directly to mttrader@access.mountain.net. |
|||
|
|||
=head1 AUTHOR |
|||
|
|||
Jonathan D. Rosenbaum <mttrader@access.mountain.net> |
|||
|
|||
=head1 COPYRIGHT |
|||
|
|||
|
|||
Copyright (c) 1999 Jonathan Rosenbaum. All rights reserved. This program |
|||
is free software; you can redistribute it and/or modify it under the GPL. |
|||
|
|||
=cut |
|||
@ -0,0 +1,947 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::DB; |
|||
use strict; |
|||
use SWIM::DB_Library qw(:Db); |
|||
use SWIM::Format; |
|||
use SWIM::Conf qw(:Path); |
|||
use SWIM::Global; |
|||
use vars qw(@ISA @EXPORT_OK); |
|||
|
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT_OK = qw(db rebuildflatdb); |
|||
|
|||
|
|||
# --db --rebuildflatdb db() rebuildflatdb() |
|||
|
|||
# The goal here is to save some time by just updating the database rather |
|||
# than rebuilding it. Generally, though, swim -i <package> would be the |
|||
# favorable way of doing this, and ultimately may become the primary way of |
|||
# setting up the databases after the required packages for this program are |
|||
# set-up. This is because --db has to check the status file, whereas -i |
|||
# uses statusindex.db, and grabs package information right from the |
|||
# package, there are exceptions to this, certain things like the status |
|||
# will have to be found from the status file or some other method. |
|||
sub db { |
|||
|
|||
# Well, we better check for any changes in the status file, before we |
|||
# attempt anything. This is made easy by the version reference hash created |
|||
# when --initdb or --rebuilddb is run, and then comparing this to the new |
|||
# results when --db is run. Only then will we process, add, and remove |
|||
# packages when we know what is gone, and what is new (whether its a |
|||
# new package name, or a package with a new version or older version). |
|||
# The statusindex.deb could be used for version checking, instead the |
|||
# important status field is compared, so if we have situations like |
|||
# "deinstall ok config-file" this will be recognized as a CHANGE. The |
|||
# update takes place so that the status field remain proper. |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
# description stuff |
|||
my (@description, @ldescription); |
|||
# my @dpackage; # not needed here |
|||
|
|||
# does status exist |
|||
my $the_status; |
|||
|
|||
# Keep track of changes to the status file |
|||
my $rootsky = "/."; |
|||
my @package; |
|||
my @name; |
|||
my $status; |
|||
my @changed_packages; |
|||
my @gone; |
|||
my (@GONE, @CHANGED, @NEW); |
|||
my @before; |
|||
my %compare; |
|||
|
|||
# The mys for NEW |
|||
my $count = 0; |
|||
# a special one to deal with package[1] version change. |
|||
my $packv; |
|||
my (@essential,$priority,$section,$installed_size,$maintainer,$source); |
|||
my (%group, $group); |
|||
|
|||
# Keeps a package->version database |
|||
# to save time over using status |
|||
my @status; |
|||
my ($replaces, $provides, $depends, $pre_depends, $recommends, $suggests, |
|||
$conflicts); |
|||
my (@conffiles,$line_before,@conf,@complete,@form,@formly); |
|||
my $format_deb = "$tmp/format.deb"; |
|||
|
|||
dbi(\%commands); ib(\%commands); sb(\%commands); |
|||
# Check differences now. |
|||
print "checking for new, changed, and removed packages\n"; |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
open(DIFFERENCE,"$parent$library/status"); |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
open(DIFFERENCE,"$parent$base/status"); |
|||
} |
|||
while (<DIFFERENCE>) { |
|||
# Package name |
|||
if (/^Package:/i) { |
|||
@package = split(/: /,$_); |
|||
chomp $package[1]; |
|||
} |
|||
elsif (/^Status:/) { |
|||
chomp; |
|||
$status = substr($_,8); |
|||
# a test |
|||
#if ($status eq "purge ok not-installed") { |
|||
# if (defined $db{$package[1]}) { |
|||
# print "$db{$package[1]}\n"; |
|||
# } |
|||
#} |
|||
} |
|||
# hold ok not-installed - may want to change this just to |
|||
# non-installed. |
|||
########### |
|||
# VERSION # |
|||
########### |
|||
elsif (/^Version:/ && $status !~ /not-installed/) { |
|||
my $version = $_; chomp $version; |
|||
my $ver = m,Version:\s(.*),; my $statusname; |
|||
if (defined $sb{$package[1]}) { |
|||
$statusname = (split(/\s/,$sb{$package[1]}))[3]; |
|||
$statusname =~ s/:/ /g; |
|||
} |
|||
######## |
|||
# GONE # |
|||
######## |
|||
if (defined $db{$package[1]}) { |
|||
push(@gone,"$package[1]_$1"); |
|||
if ("$package[1]_$1" ne $db{$package[1]}) { |
|||
$compare{$package[1]} = "$package[1]_$1"; |
|||
} |
|||
# Version remained the same, but status changed |
|||
# even though $statusname may be undefined..this |
|||
# routine is only done when it does exist. |
|||
###### |
|||
# CR # |
|||
###### |
|||
elsif ("$package[1]_$1" eq $db{$package[1]} && |
|||
$statusname ne $status) { |
|||
push(@changed_packages, "$package[1]"); |
|||
$compare{$package[1]} = "$package[1]_$1"; |
|||
} |
|||
} |
|||
####### |
|||
# NEW # |
|||
####### |
|||
elsif (!defined $db{$package[1]}) { |
|||
push(@NEW,$package[1]); |
|||
$compare{$package[1]} = "$package[1]_$1"; |
|||
push(@gone,"$package[1]_$1"); |
|||
} |
|||
} |
|||
} |
|||
close(DIFFERENCE); |
|||
|
|||
# lets find what existed before, ofcourse mistakes in /. better be |
|||
# taken care of beforehand, because this ignores those here. Some time |
|||
# may have been saved by using a separate database rather than /., but, |
|||
# this keeps things clean. |
|||
if ($ib{$rootsky}){ |
|||
@before = split(/\s/,$ib{$rootsky}); |
|||
my %tracker; |
|||
grep($tracker{$_}++,@gone); |
|||
my @goners = grep(!$tracker{$_},@before); |
|||
foreach (@goners) { |
|||
m,(^.*)_.*$,; |
|||
if (!defined $compare{$1}) { |
|||
push(@GONE,$1); |
|||
} |
|||
else { |
|||
# these will be process like @GONE for original, and @NEW for |
|||
# new |
|||
push(@CHANGED,$1); |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
print "swim: missing important database\n"; exit; |
|||
} |
|||
|
|||
foreach (@GONE) { |
|||
print "GONE $_\n"; |
|||
} |
|||
foreach (@CHANGED) { |
|||
print "CHANGED $_\n"; |
|||
} |
|||
foreach (@changed_packages) { |
|||
push(@CHANGED,$_); |
|||
print "CHANGED STATUS $_\n"; |
|||
} |
|||
foreach (@NEW) { |
|||
print "NEW $_\n"; |
|||
} |
|||
|
|||
my $new=$#NEW + 1; my $cr=$#changed_packages + 1; |
|||
my $ch=($#CHANGED + 1) - $cr; my $gon= $#GONE + 1; |
|||
if ($commands->{"check"}) { |
|||
print "\n TOTAL\n -----\n"; |
|||
print "NEW $new\n"; print "GONE $gon\n"; |
|||
print "CHANGED $ch\n"; print "CHANGED STATUS $cr\n"; exit; |
|||
} |
|||
print "\n TOTAL\n -----\n"; |
|||
print "NEW $new\n"; print "GONE $gon\n"; |
|||
print "CHANGED $ch\n"; print "CHANGED STATUS $cr\n"; |
|||
|
|||
|
|||
@GONE = (@GONE,@CHANGED); |
|||
@NEW = (@NEW,@CHANGED); |
|||
|
|||
undef @before; # can use below. |
|||
untie %db; |
|||
undef %db; |
|||
untie %ib; |
|||
undef %ib; |
|||
|
|||
# Going to be adding some stuff to nsearchindex.deb and ndirindex.deb |
|||
# so better remove any compressed versions if they exist |
|||
if (defined @GONE || defined @NEW) { |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if (-e "$parent$library/searchindex.deb") { |
|||
unlink("$parent$library/searchindex.deb.gz"); |
|||
unlink("$parent$library/dirindex.deb.gz"); |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (-e "$parent$base/searchindex.deb") { |
|||
unlink("$parent$base/searchindex.deb.gz"); |
|||
unlink("$parent$base/dirindex.deb.gz"); |
|||
} |
|||
} |
|||
} |
|||
|
|||
|
|||
# Time for some fun stuff |
|||
# There are three states: GONE - all information about this package |
|||
# needs to be removed from the databases. NEW - all information about |
|||
# this package needs to be put in the databases. CHANGED - a |
|||
# combination of the two previous, information could be cross |
|||
# referenced and checked for changes, but it's probably no saving of |
|||
# time, so first remove information from the same package of a |
|||
# different version, then add the information about the package of the |
|||
# new version (older or newer) |
|||
|
|||
############# |
|||
# # |
|||
# GONE # |
|||
# # |
|||
############# |
|||
# GONE. (reverse applies to NEW) |
|||
# For package.deb - Delete description |
|||
# (packagename_version), packagenameREP, packagenamePRO, |
|||
# packagenameDEP, packagenamePRE, packagenameREC, |
|||
# packagenameSUG, packagenameCON, packagenameCONF. delete package -> |
|||
# version. |
|||
# |
|||
# for fileindex.deb - |
|||
# Find all files and directories associated with the package. Delete |
|||
# these files (keys). Find all directories where the file |
|||
# exists..delete package name from value, delete whole key if it is the |
|||
# only package name. |
|||
# |
|||
# for groupindex - delete package name (value) from Section |
|||
# it belonged to..humm, find section package belongs to in |
|||
# statusuindex.deb, and delete whole Section key if only one. |
|||
# |
|||
# for statusindex.deb - |
|||
# delete package -> version group. |
|||
# |
|||
# for flat files dirindex and searchindex - |
|||
# the removal of files and/or directories can be put on hold, and |
|||
# done with an option at a later time, since fileindex.deb remembers |
|||
# current state, at a later time the old state of the flat files can be |
|||
# compared to the new state of fileindex, and these files can be |
|||
# rewritten. This is all o.k. because these extra files or directories |
|||
# will return undef in search() if the packages don't exist. |
|||
|
|||
ping(\%commands); # uses $ping for package.deb |
|||
zing(\%commands); # uses $zing for fileindex.deb |
|||
ging(\%commands); # uses $ging for groupindex.deb |
|||
sing(\%commands); # uses $sing for statusindex.deb |
|||
|
|||
$| = 1; my $x = 1; |
|||
foreach (@GONE) { |
|||
print "G|C|CS $x $_.list\r"; |
|||
$x++; |
|||
#first delete keys from package.deb |
|||
# If I kept this the name_version would be remembered. |
|||
$ping->del($_); |
|||
my $orig_argument = $_; |
|||
my $packname_version = (split(/\s/,$sb{$orig_argument}))[0]; |
|||
$packname_version =~ s,\+,\\\+,g; |
|||
$argument = "$_"; |
|||
ver(\%commands); |
|||
$ping->del($argument); |
|||
my $conf = $argument . "CONF"; |
|||
$ping->del($conf); |
|||
$conf = $argument . "REP"; |
|||
$ping->del($conf); |
|||
$conf = $argument . "PRO"; |
|||
$ping->del($conf); |
|||
$conf = $argument . "DEP"; |
|||
$ping->del($conf); |
|||
$conf = $argument . "PRE"; |
|||
$ping->del($conf); |
|||
$conf = $argument . "REC"; |
|||
$ping->del($conf); |
|||
$conf = $argument . "SUG"; |
|||
$ping->del($conf); |
|||
$conf = $argument . "CON"; |
|||
$ping->del($conf); |
|||
untie $ping; |
|||
|
|||
# next let's go into fileindex.deb and hunt down all directories and |
|||
# files associated with this package. It would be kind of nice to use |
|||
# package_name.list, but it's probably more realistic not to depend on |
|||
# the existence of these file..unless a backup is made. Now if -i is used |
|||
# this would be a simple matter, but in this case things are different. |
|||
# A database to accomplish this wasn't realistic, so the backup |
|||
# files for *.list are in ./info/backup/*.list.bk. We will also have to |
|||
# deal with those rare cases that forget /. (smail 2.0v). We should remove |
|||
# this file as well as the packagename-conf.md5sums file below. |
|||
my $file = "$parent$base/info/backup/$_.list.bk"; |
|||
my $md5sum_file = "$parent$base/info/$_-conf.md5sums"; |
|||
open(LIST,"$file"); |
|||
while (<LIST>) { |
|||
chomp; |
|||
if (defined $ib{$_}) { |
|||
my $status = ($ib{$_} =~ s,$packname_version ,,); |
|||
if ($status eq "") { |
|||
$status = ($ib{$_} =~ s, $packname_version,,); |
|||
if ($status eq "") { |
|||
$ib{$_} =~ s,$packname_version,,; |
|||
} |
|||
} |
|||
if ($ib{$_} eq "") { |
|||
$zing->del($_); |
|||
} |
|||
} # if defined |
|||
} |
|||
close(LIST); |
|||
unlink("$file"); |
|||
|
|||
####################### |
|||
# deinstall situation # |
|||
####################### |
|||
my $yit = (split(/\s/,$sb{$orig_argument}))[3]; |
|||
if ($yit eq "deinstall:ok:config-files" || |
|||
$yit eq "purge:ok:config-files") { |
|||
if (defined $ib{"/."}) { |
|||
my $status = ($ib{"/."} =~ s,$packname_version ,,); |
|||
if ($status eq "") { |
|||
$status = ($ib{"/."} =~ s, $packname_version,,); |
|||
if ($status eq "") { |
|||
$ib{"/."} =~ s,$packname_version,,; |
|||
} |
|||
} |
|||
if ($ib{"/."} eq "") { |
|||
$zing->del($_); |
|||
} |
|||
} # if defined |
|||
} # deinstall situation |
|||
|
|||
if (-e $md5sum_file) { |
|||
unlink("$md5sum_file"); |
|||
} |
|||
|
|||
# remove from the group, and if only one remove the group. |
|||
# Let's first find out which group this monster belongs to. |
|||
if (defined $sb{$orig_argument}) { |
|||
(my $oa = $orig_argument) =~ s,\+,\\\+,g; |
|||
my($section) = (split(/\s/,$sb{$orig_argument}))[1]; |
|||
if (defined $gb{$section}) { |
|||
my $status = ($gb{$section} =~ s,$oa ,,); |
|||
if ($status eq "") { |
|||
$status = ($gb{$section} =~ s, $oa,,); |
|||
if ($status eq "") { |
|||
$gb{$section} =~ s,$oa,,; |
|||
} |
|||
} |
|||
if ($gb{$section} eq "") { |
|||
$ging->del($section); |
|||
} |
|||
} |
|||
} |
|||
|
|||
# Now ditch the package->version group in statusindex.deb |
|||
$sing->del($orig_argument); |
|||
untie $sing; |
|||
|
|||
} # end foreach OLD |
|||
|
|||
print "\n" if $#GONE != -1 && $#NEW == -1; |
|||
|
|||
############# |
|||
# # |
|||
# NEW # |
|||
# # |
|||
############# |
|||
if (-e "$parent$base/status" && -e "$parent$base/info") { |
|||
$the_status = "$parent$base/status"; |
|||
} |
|||
else { |
|||
print "swim: crucial file(s)/directories are missing in $parent\n"; |
|||
exit; |
|||
} |
|||
my %exacts; |
|||
my $goon; |
|||
print "\n" if $#NEW != -1; $x = 1; |
|||
foreach (@NEW) { |
|||
$exacts{$_} = "yes"; |
|||
} |
|||
# first let's find the fields to put into packages.deb |
|||
# We'll have to go through the status file again, something we |
|||
# wouldn't have had to do with swim -i. As it turns out, a good |
|||
# percentage of the information can be processed into the database |
|||
# while going through status. |
|||
open(PRETTY, ">$format_deb"); |
|||
open(AVAIL, "$the_status"); |
|||
while (<AVAIL>) { |
|||
# here's the difference with database(), we just find the packages |
|||
# which belong to the hash %exacts |
|||
# Package name |
|||
if (/^Package:|^PACKAGE:/) { |
|||
@package = split(/: /,$_); |
|||
chomp $package[1]; |
|||
if (defined $exacts{$package[1]}) { |
|||
print "N|C|CS $x\r"; $x++; |
|||
$goon = "yes"; |
|||
} |
|||
else { |
|||
$goon = "no"; |
|||
undef @package; |
|||
next; |
|||
} |
|||
} |
|||
elsif ($goon eq "no") { |
|||
next; |
|||
} |
|||
elsif (/^Status:/) { |
|||
$status = $_; |
|||
} |
|||
elsif (/^Essential/) { |
|||
@essential = split(/: /,$_); |
|||
} |
|||
# missing priority and section will be dealt with below |
|||
elsif (/^Priority:/) { |
|||
$priority = $_; |
|||
} |
|||
elsif (/^Section:/) { |
|||
$section = $_; |
|||
# make the hash for the groupindex.deb |
|||
$group = substr($section,9); |
|||
chomp $group; |
|||
# we will put not-installed in their own group for reference |
|||
if ($status !~ /not-installed/) { |
|||
if (!defined $gb{$group}) { |
|||
$ging->put($group,$package[1]); |
|||
} |
|||
else { |
|||
my $change_group = "$gb{$group} $package[1]"; |
|||
$ging->del($group); |
|||
$ging->put($group,"$change_group"); |
|||
} |
|||
} |
|||
} |
|||
elsif (/^Installed-Size:/) { |
|||
$installed_size = $_; |
|||
} |
|||
elsif (/^Maintainer:/) { |
|||
$maintainer = $_; |
|||
} |
|||
elsif (/^Source:/) { |
|||
$source = $_; |
|||
} |
|||
# hold ok not-installed - may want to change this just to |
|||
# non-installed. |
|||
elsif (/^Version:/ && $status !~ /not-installed/) { |
|||
my $version = $_; |
|||
chomp $version; |
|||
########### |
|||
# SECTION # |
|||
########### |
|||
if (defined $section) { |
|||
chomp $section; |
|||
} |
|||
else { |
|||
nsb(\%commands); |
|||
if (defined $nsb{$package[1]}) { |
|||
my ($nvname,$ngname,$npriorname) = |
|||
split(/\s/,"$nsb{$package[1]}",3); |
|||
$group = $ngname; |
|||
} |
|||
else { |
|||
$group = "unavailable"; |
|||
} |
|||
} |
|||
$col1 = "Package: $package[1]"; |
|||
$col2 = $status; |
|||
write PRETTY; |
|||
$col1 = $version; |
|||
my $ver = m,Version:\s(.*),; |
|||
# This creates a name -> version index in package.deb, |
|||
# and the statusindex.deb database which will serve to |
|||
# determine if the status has changed when --db or -i is |
|||
# run. |
|||
$packv = "$package[1]_$1"; |
|||
$ping->put($package[1],$packv); |
|||
my ($priory,$statusy); |
|||
############ |
|||
# PRIORITY # |
|||
############ |
|||
if (defined $priority) { |
|||
$priory = substr($priority,10); |
|||
} |
|||
else { |
|||
nsb(\%commands); |
|||
if (defined $nsb{$package[1]}) { |
|||
my ($nvname,$ngname,$npriorname) = |
|||
split(/\s/,"$nsb{$package[1]}",3); |
|||
$priory = $npriorname; |
|||
} |
|||
else { |
|||
$priory = "unavailable"; |
|||
} |
|||
} |
|||
chomp $priory; |
|||
$statusy = substr($status,8); |
|||
chomp $statusy; |
|||
$statusy =~ s/\s/:/g; |
|||
my $thimk = "$packv $group $priory $statusy"; |
|||
$sing->put($package[1],$thimk); |
|||
$package[1] = "$packv"; |
|||
if(defined($essential[1])) { |
|||
$col2 = "Essential: $essential[1]"; |
|||
@essential = (); |
|||
} |
|||
else { |
|||
$col2 = "Essential: no\n"; |
|||
} |
|||
write PRETTY; |
|||
###################### |
|||
# SECTION & PRIORITY # |
|||
###################### |
|||
if (defined $section) { |
|||
$col1 = $section; |
|||
} |
|||
else { |
|||
nsb(\%commands); |
|||
$package[1] =~ m,(.*)_.*,; |
|||
my $packthing = $1; |
|||
if (defined $nsb{$packthing}) { |
|||
my ($nvname,$ngname,$npriorname) = |
|||
split(/\s/,"$nsb{$packthing}",3); |
|||
$col1 = "Section: $ngname"; |
|||
# we can put it in now, no deletion needed |
|||
if (!defined $gb{$group}) { |
|||
$ging->put($group,$packthing); |
|||
} |
|||
else { |
|||
my $change_group = "$gb{$group} $packthing"; |
|||
$ging->del($group); |
|||
$ging->put($group,"$change_group"); |
|||
} |
|||
} |
|||
else { |
|||
$col1 = "Section: unavailable"; |
|||
} |
|||
} |
|||
if (defined $priority) { |
|||
$col2 = $priority; |
|||
} |
|||
else { |
|||
nsb(\%commands); |
|||
$package[1] =~ m,(.*)_.*,; |
|||
my $packthing = $1; |
|||
if (defined $nsb{$packthing}) { |
|||
my ($nvname,$ngname,$npriorname) = |
|||
split(/\s/,"$nsb{$packthing}",3); |
|||
$col2 = "Section: $npriorname"; |
|||
} |
|||
else { |
|||
$col2 = "Priority: unavailable\n"; |
|||
} |
|||
} |
|||
write PRETTY; |
|||
#my $cool = $installed_size . $maintainer; |
|||
#print PRETTY $cool; |
|||
$col1 = $installed_size; |
|||
if (defined $source) { |
|||
$col2 = $source; |
|||
} |
|||
else { |
|||
$col2 = ""; |
|||
} |
|||
write PRETTY; |
|||
undef $source; |
|||
print PRETTY $maintainer |
|||
} |
|||
|
|||
# This stuff will be available with seperate query flags or All |
|||
elsif (/^Replaces:/) { |
|||
$replaces = $_; |
|||
if (defined($replaces)) { |
|||
$ping->put("$package[1]REP",$replaces); |
|||
} |
|||
} |
|||
elsif (/^Provides:/) { |
|||
$provides = $_; |
|||
if (defined($provides)) { |
|||
$ping->put("$package[1]PRO",$provides); |
|||
} |
|||
} |
|||
elsif (/^Depends:/) { |
|||
$depends = $_; |
|||
if (defined($depends)) { |
|||
$ping->put("$package[1]DEP",$depends); |
|||
} |
|||
} |
|||
elsif (/^Pre-Depends:/) { |
|||
$pre_depends = $_; |
|||
if (defined($pre_depends)) { |
|||
$ping->put("$package[1]PRE",$pre_depends); |
|||
} |
|||
} |
|||
elsif (/^Recommends:/) { |
|||
$recommends = $_; |
|||
if (defined($recommends)) { |
|||
$ping->put("$package[1]REC",$recommends); |
|||
} |
|||
} |
|||
elsif (/^Suggests:/) { |
|||
$suggests = $_; |
|||
if (defined($suggests)) { |
|||
$ping->put("$package[1]SUG",$suggests); |
|||
} |
|||
} |
|||
elsif (/^Conflicts:/) { |
|||
$conflicts = $_; |
|||
if (defined($conflicts)) { |
|||
$ping->put("$package[1]CON",$conflicts); |
|||
} |
|||
} |
|||
# Gather the Configuration Files, Description comes after. |
|||
# Available with a single flag. |
|||
elsif (/^Conffiles:/) { |
|||
my $line = <AVAIL>; |
|||
while ($line !~ /^Description:/) { |
|||
push(@conffiles,$line); |
|||
$line = <AVAIL>; |
|||
if ($line =~ /^Description/) { |
|||
$line_before = $line; |
|||
# put conffiles into one variable |
|||
if (defined $package[1]) { |
|||
} |
|||
my ($c, $cool); |
|||
if ($#conffiles != 0) { |
|||
for ($c = $#conffiles; $c >= 0; $c--) { |
|||
if ($c > 0) { |
|||
$cool = $conffiles[$c-1] .= $conffiles[$c]; |
|||
} |
|||
} #end for |
|||
} |
|||
else { |
|||
$cool = $conffiles[0]; |
|||
} |
|||
@conffiles = (); |
|||
$ping->put("$package[1]CONF",$cool); |
|||
} #if ($line =~ /^Desc |
|||
} # while ($line ! /^Desc |
|||
} # elsif (/^Conffiles |
|||
untie %nsb; |
|||
|
|||
# Only interested in available packages..so this is fine. |
|||
# To be combined with first fields. |
|||
if (/Description:|^\s\w*|^\s\.\w*/ || |
|||
defined($line_before) =~ /^Description/){ |
|||
my $many_lines; |
|||
if (defined($line_before)) { |
|||
push(@ldescription, $line_before); |
|||
push(@ldescription, $_); |
|||
$line_before = (); |
|||
} |
|||
else { |
|||
$many_lines = $_; |
|||
} |
|||
if ($_ !~ /^\n$/) { |
|||
$count++; |
|||
if ($count == 1) { |
|||
if (defined $package[1]) { |
|||
#chomp $package[1]; |
|||
#push(@dpackage,$package[1]); |
|||
push(@description,$package[1]); |
|||
} |
|||
} |
|||
if (defined($many_lines)) { |
|||
push(@ldescription,$many_lines); |
|||
} |
|||
} # end if ($_ !~ /^\n$/ |
|||
else { |
|||
$count = 0; |
|||
# let's put each description into one scalar |
|||
my ($c, $cool); |
|||
if ($#ldescription != 0) { |
|||
for ($c = $#ldescription; $c >= 0; $c--) { |
|||
if ($c > 0) { |
|||
$cool = $ldescription[$c-1] .= $ldescription[$c]; |
|||
} |
|||
} #end for |
|||
} # end if ($#ld |
|||
else { |
|||
$cool = $ldescription[0]; |
|||
} |
|||
if (defined $cool) { |
|||
push(@description,$cool); |
|||
} |
|||
@ldescription = (); |
|||
} # end else |
|||
$line_before = (); |
|||
} |
|||
untie $ping; |
|||
untie $ging; |
|||
untie $sing; |
|||
} # end while (<AVAIL>) |
|||
close(PRETTY); |
|||
|
|||
|
|||
# Let's put together the description with the rest of its fields. |
|||
open(FIELDS,"$format_deb"); |
|||
while (<FIELDS>) { |
|||
push(@form,$_); |
|||
} |
|||
close(FIELDS); |
|||
|
|||
foreach (@form) { |
|||
push(@formly,$_); |
|||
my ($cool); |
|||
$count++; |
|||
if ($count == 5) { |
|||
my ($c, $cool); |
|||
if ($#formly != 0) { |
|||
for ($c = $#formly; $c >= 0; $c--) { |
|||
if ($c > 0) { |
|||
$cool = $formly[$c-1] .= $formly[$c]; |
|||
} |
|||
} #end for |
|||
} # end if ($#ld |
|||
else { |
|||
$cool = $formly[0]; |
|||
} |
|||
push(@complete,$cool); |
|||
@formly = (); |
|||
$count = 0; |
|||
} |
|||
} |
|||
|
|||
my $name_version; |
|||
foreach (@description) { |
|||
if ($count == 1) { |
|||
# -i |
|||
my $lingo = shift(@complete); |
|||
$lingo = $lingo . $_; |
|||
#push(@Tdescription, $lingo); |
|||
$ping->put($name_version,$lingo); |
|||
$lingo = (); |
|||
$count = 1; |
|||
} |
|||
else { |
|||
# packagename_version |
|||
#push(@Tdescription, $_); |
|||
$name_version = $_; |
|||
$count = 0; |
|||
} |
|||
$count++; |
|||
untie $ping; |
|||
} |
|||
undef $ping; |
|||
|
|||
unlink($format_deb); |
|||
|
|||
# Now time to do some file/dir stuff. A backup of *list needs to be |
|||
# made, might as well use this. There is a possibility this can be |
|||
# used instead of fastswim for initial fileindex.deb. |
|||
my $package_name; |
|||
if (!-d "$parent$base/info/backup") { |
|||
mkdir("$parent$base/info/backup",0666); |
|||
} |
|||
print "\n" if $#NEW != -1; $x = 1; |
|||
|
|||
foreach $package_name (@NEW) { |
|||
open(FILENAME,"$parent$base/info/$package_name.list"); |
|||
open(CP,">$parent$base/info/backup/$package_name.list.bk"); |
|||
while (<FILENAME>) { |
|||
print CP $_; |
|||
} |
|||
close(FILENAME); |
|||
close(CP); |
|||
|
|||
my $file = "$parent$base/info/backup/$package_name.list.bk"; |
|||
print "#$x"; print " N|C $package_name.list \r"; |
|||
$x++; |
|||
open(LIST,"$file"); |
|||
while (<LIST>) { |
|||
chomp; |
|||
|
|||
# Better add the new stuff to the flat files first |
|||
if (!defined $ib{$_}) { |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
open(SEARCHINDEX,">>$parent$library/searchindex.deb"); |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
open(SEARCHINDEX,">>$parent$base/searchindex.deb"); |
|||
} |
|||
if (!-d) { |
|||
print SEARCHINDEX "$_\n"; |
|||
} |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
open(DIRINDEX,">>$parent$library/dirindex.deb"); |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
open(DIRINDEX,">>$parent$base/dirindex.deb"); |
|||
} |
|||
if (-d) { |
|||
print DIRINDEX "$_\n"; |
|||
} |
|||
} # !defined |
|||
|
|||
# If the directory already exists we can just append |
|||
# to the end of the value |
|||
if (defined $ib{$_}) { |
|||
dbi(\%commands); |
|||
my $cvalue = $ib{$_} . " $db{$package_name}"; |
|||
# put overwrites by default! |
|||
$zing->put($_,$cvalue); |
|||
} # if defined |
|||
else { |
|||
dbi(\%commands); |
|||
$zing->put($_,$db{$package_name}); |
|||
} |
|||
untie %db; |
|||
untie $zing; |
|||
} |
|||
close(LIST); |
|||
close(SEARCHINDEX); |
|||
close(DIRINDEX); |
|||
|
|||
my $zit; my ($nit,$yit) = (split(/\s/,$sb{$package_name}))[0,3]; |
|||
if ($yit eq "deinstall:ok:config-files" || |
|||
$yit eq "purge:ok:config-files") { |
|||
($zit = $nit) =~ s,\+,\\\+,; |
|||
if ($ib{"/."} !~ m,$zit,) { |
|||
$ib{"/."} = $ib{"/."} . " $zit"; |
|||
} |
|||
} |
|||
|
|||
} # end foreach NEW |
|||
print "\n" if $#NEW != -1; |
|||
|
|||
} # end sub db |
|||
|
|||
# Generally, it's unecessary to rebuild the flat databases unless major |
|||
# changes have occurred to a person's installation, and the database has |
|||
# become very repetitive, or a file has changed into a directory. This |
|||
# function has also been tried by tieing the flat file to an array, but |
|||
# there doesn't seem to be that much of a speed advantage unless ib() |
|||
# happens to be in memory, but more experimentation will be tried in the |
|||
# future. |
|||
sub rebuildflatdb { |
|||
|
|||
my($commands) = @_; |
|||
my %commands = %$commands; |
|||
ib(\%commands); |
|||
|
|||
print scalar(localtime), "\n"; |
|||
|
|||
my $file; |
|||
my $dir; |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
!($commands->{"dbpath"} && $commands->{"root"})) { |
|||
if (-e "$parent$library/searchindex.deb") { |
|||
$dir = "$parent$library/dirindex.deb"; |
|||
$file = "$parent$library/searchindex.deb"; |
|||
unlink($file); |
|||
unlink("$file.gz") if -e "$file.gz"; |
|||
unlink($dir); |
|||
unlink("$dir.gz") if -e "$dir.gz"; |
|||
} |
|||
else { |
|||
print "swim: operation only implemented for installed system\n"; |
|||
exit; |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (-e "$parent$base/searchindex.deb") { |
|||
$file = "$parent$base/searchindex.deb"; |
|||
$dir = "$parent$base/dirindex.deb"; |
|||
unlink($file); |
|||
unlink("$file.gz") if -e "$file.gz"; |
|||
unlink($dir); |
|||
unlink("$dir.gz") if -e "$dir.gz"; |
|||
} |
|||
else { |
|||
print "swim: operation only implemented for installed system\n"; |
|||
exit; |
|||
} |
|||
} |
|||
|
|||
|
|||
open(DIR,">$dir"); |
|||
open(FILE,">$file"); |
|||
# We need to reconstruct long.debian & DEBIAN*, but can't take into account |
|||
# weirdisms with the database - NEW packages which aren't NEW. |
|||
foreach (keys %ib) { |
|||
if (defined $ib{$_}) { |
|||
my $filedir = $_; |
|||
my $package = $ib{$_}; |
|||
#$package =~ s/\s/\n/g; |
|||
my @the_amount = split(/\s/, $package); |
|||
if ($#the_amount > 0) { |
|||
print DIR "$filedir\n"; |
|||
} |
|||
elsif ($#the_amount == 0) { |
|||
print FILE "$filedir\n"; |
|||
} |
|||
} |
|||
} |
|||
untie %ib; |
|||
print scalar(localtime), "\n"; |
|||
|
|||
} # end sub rebuildflatdb |
|||
|
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,648 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::DB_Init; |
|||
use strict; |
|||
use SWIM::Conf qw(:Path $fastswim $imswim $slowswim $sort); |
|||
#use SWIM::Global; |
|||
use SWIM::Format; |
|||
use SWIM::MD; |
|||
use DB_File; |
|||
use vars qw(@ISA @EXPORT); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(database); |
|||
|
|||
|
|||
# database() md() --initdb --rebuilddb |
|||
|
|||
# Time to get serious and make a database |
|||
sub database { |
|||
|
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
print scalar(localtime), "\n"; |
|||
|
|||
#my whatever that is |
|||
my @dpackage; # passes name_version to md() |
|||
my @Tdescription; |
|||
my @description; |
|||
my @ldescription; |
|||
my @package; |
|||
my %db; |
|||
my @name; |
|||
my $count = 0; |
|||
|
|||
my $the_status; |
|||
|
|||
my $status; |
|||
my @essential; |
|||
my $priority; |
|||
my $section; |
|||
my $installed_size; |
|||
my $maintainer; |
|||
my $source; |
|||
my $version; |
|||
my $ver; |
|||
|
|||
my %gb; |
|||
my %group; |
|||
my $group; |
|||
|
|||
# Keeps a package->version database |
|||
# to save time over using status |
|||
my %sb; |
|||
my @status; |
|||
|
|||
my ($replaces, @REPLACE, $provides, $depends, $pre_depends, |
|||
$recommends, $suggests, $conflicts); |
|||
|
|||
my @conffiles; |
|||
my $line_before; |
|||
my @conf; |
|||
my @complete; |
|||
my @form; |
|||
my @formly; |
|||
my $format_deb = "$tmp/format.deb"; |
|||
|
|||
# Let's decide whether we should even go on. If it is --initdb, and |
|||
# the databases already exist, nothing should be touched, but if it is |
|||
# --rebuilddb and they exist, then they are removed and remade from |
|||
# scratch. |
|||
|
|||
# But first, better clean up any files in $tmp in case of an aborted |
|||
# database formation |
|||
unlink(<$tmp/DEBIAN*>) if -e "$tmp/DEBIANaa"; |
|||
unlink("$tmp/transfer.deb") if -e "$tmp/transfer.deb"; |
|||
unlink("$tmp/big.debian") if -e "$tmp/big.debian"; |
|||
unlink("$tmp/long.debian") if -e "$tmp/long.debian"; |
|||
|
|||
|
|||
if (-e "$parent$base/status" && -e "$parent$base/info") { |
|||
$the_status = "$parent$base/status"; |
|||
} |
|||
else { |
|||
print "swim: crucial file(s)/directories are missing in $parent\n"; |
|||
exit; |
|||
} |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if ($commands->{"initdb"}) { |
|||
if (-e "$parent$library/packages.deb" && |
|||
-e "$parent$library/fileindex.deb") { |
|||
print "swim: use --rebuilddb\n"; |
|||
exit; |
|||
} |
|||
else { |
|||
# if a database happens to be missing |
|||
if (-e "$parent$library/packages.deb") { |
|||
unlink("$parent$library/packages.deb"); |
|||
} |
|||
if (-e "$parent$library/fileindex.deb") { |
|||
unlink("$parent$library/fileindex.deb"); |
|||
} |
|||
if (-e "$parent$library/groupindex.deb") { |
|||
unlink("$parent$library/groupindex.deb"); |
|||
} |
|||
if (-e "$parent$library/statusindex.deb") { |
|||
unlink("$parent$library/statusindex.deb"); |
|||
} |
|||
if (-e "$parent$library/searchindex.deb") { |
|||
unlink("$parent$library/searchindex.deb"); |
|||
} |
|||
if (-e "$parent$library/searchindex.deb.gz") { |
|||
unlink("$parent$library/searchindex.deb.gz"); |
|||
} |
|||
if (-e "$parent$library/dirindex.deb") { |
|||
unlink("$parent$library/dirindex.deb"); |
|||
} |
|||
if (-e "$parent$library/dirindex.deb.gz") { |
|||
unlink("$parent$library/dirindex.deb.gz"); |
|||
} |
|||
} |
|||
} |
|||
# this only works if all databases exist. |
|||
elsif ($commands->{"rebuilddb"}) { |
|||
if (-e "$parent$library/packages.deb" && |
|||
-e "$parent$library/fileindex.deb") { |
|||
unlink("$parent$library/packages.deb"); |
|||
unlink("$parent$library/fileindex.deb"); |
|||
unlink("$parent$library/groupindex.deb"); |
|||
unlink("$parent$library/statusindex.deb"); |
|||
unlink("$parent$library/searchindex.deb"); |
|||
unlink("$parent$library/searchindex.deb") |
|||
if -e "$parent$library/searchindex.deb"; |
|||
unlink("$parent$library/dirindex.deb"); |
|||
unlink("$parent$library/dirindex.deb") |
|||
if -e "$parent$library/dirindex.deb.gz"; |
|||
} |
|||
else { |
|||
print "swim: use --initdb to create databases\n"; |
|||
exit; |
|||
} |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if ($commands->{"initdb"}) { |
|||
if (-e "$parent$base/packages.deb" && |
|||
-e "$parent$base/fileindex.deb") { |
|||
print "swim: use --rebuilddb\n"; |
|||
exit; |
|||
} |
|||
else { |
|||
# if a database happens to be missing |
|||
if (-e "$parent$base/packages.deb") { |
|||
unlink("$parent$base/packages.deb"); |
|||
} |
|||
if (-e "$parent$base/fileindex.deb") { |
|||
unlink("$parent$base/fileindex.deb"); |
|||
} |
|||
if (-e "$parent$base/groupindex.deb") { |
|||
unlink("$parent$base/groupindex.deb"); |
|||
} |
|||
if (-e "$parent$library/statusindex.deb") { |
|||
unlink("$parent$library/statusindex.deb"); |
|||
} |
|||
if (-e "$parent$library/searchindex.deb") { |
|||
unlink("$parent$library/searchindex.deb"); |
|||
} |
|||
if (-e "$parent$library/searchindex.deb.gz") { |
|||
unlink("$parent$library/searchindex.deb.gz"); |
|||
} |
|||
if (-e "$parent$library/dirindex.deb") { |
|||
unlink("$parent$library/dirindex.deb"); |
|||
} |
|||
if (-e "$parent$library/dirindex.deb.gz") { |
|||
unlink("$parent$library/dirindex.deb.gz"); |
|||
} |
|||
} |
|||
} |
|||
# this only works if all databases exist. |
|||
elsif ($commands->{"rebuilddb"}) { |
|||
if (-e "$parent$base/packages.deb" && |
|||
-e "$parent$base/fileindex.deb") { |
|||
unlink("$parent$base/packages.deb"); |
|||
unlink("$parent$base/fileindex.deb"); |
|||
unlink("$parent$base/groupindex.deb"); |
|||
unlink("$parent$base/statusindex.deb"); |
|||
unlink("$parent$library/searchindex.deb"); |
|||
unlink("$parent$library/searchindex.deb") |
|||
if -e "$parent$library/searchindex.deb"; |
|||
unlink("$parent$library/dirindex.deb"); |
|||
unlink("$parent$library/dirindex.deb") |
|||
if -e "$parent$library/dirindex.deb.gz"; |
|||
} |
|||
else { |
|||
print "swim: use --initdb to create databases\n"; |
|||
exit; |
|||
} |
|||
} |
|||
} |
|||
|
|||
# This makes a backup of all the *.list files in ./backup. When |
|||
# --initdb/--rebuilddb runs these files should be built or rebuilt, |
|||
# but if changes have occured and --db(-i wasn't used) wasn't run |
|||
# this won't cause problems because everything is rebuilt, there may |
|||
# just be some lingering small files in backup. |
|||
|
|||
# Seems like both approaches are about the same speed. |
|||
#use File::Copy; |
|||
print "Making backups of *.list\n"; |
|||
if (!-d "$parent$base/info/backup") { |
|||
mkdir("$parent$base/info/backup",0666); |
|||
} |
|||
opendir(COPY,"$parent$base/info"); |
|||
foreach (sort grep(/\.list$/, readdir(COPY))) { |
|||
#copy ("$parent$base/info/$_","$parent$base/info/backup/$_.bk"); |
|||
open(FILENAME,"$parent$base/info/$_"); |
|||
open(CP,">$parent$base/info/backup/$_.bk"); |
|||
while (<FILENAME>) { |
|||
print CP $_; |
|||
} |
|||
} |
|||
closedir(COPY); |
|||
|
|||
print "Description Database is being made\n"; |
|||
|
|||
$| = 1; my $x = 0; |
|||
open(PRETTY, ">$format_deb"); |
|||
open(AVAIL, "$the_status"); |
|||
while (<AVAIL>) { |
|||
# Package name |
|||
if (/^Package:|^PACKAGE:/) { |
|||
@package = split(/: /,$_); |
|||
chomp $package[1]; |
|||
$x = 1 if $x == 6; |
|||
print "|\r" if $x == 1 || $x == 4; print "/\r" if $x == 2; |
|||
print "-\r" if $x == 3 || $x == 6; print "\\\r" if $x == 5; |
|||
$x++; |
|||
} |
|||
# Some other pertinent fields |
|||
# All this stuff can be placed together..since it is generally nice |
|||
# to know these things at one glance, in this order. |
|||
# Package: Status: |
|||
# Version: Essential: (yes or no) |
|||
# Section: Priority: |
|||
# Installed-Size: |
|||
# Maintainer: |
|||
# Description: |
|||
|
|||
elsif (/^Status:/) { |
|||
$status = $_; |
|||
} |
|||
elsif (/^Essential/) { |
|||
@essential = split(/: /,$_); |
|||
} |
|||
elsif (/^Priority:/) { |
|||
$priority = $_; |
|||
} |
|||
elsif (/^Section:/) { |
|||
$section = $_; |
|||
# make the hash for the groupindex.deb |
|||
$group = substr($section,9); |
|||
chomp $group; |
|||
# we will put not-installed in their own group for reference |
|||
if ($status !~ /not-installed/) { |
|||
if (!defined $group{$group}) { |
|||
$group{$group} = $package[1]; |
|||
} |
|||
else { |
|||
$group{$group} = "$group{$group} $package[1]"; |
|||
} |
|||
} |
|||
} |
|||
elsif (/^Installed-Size:/) { |
|||
$installed_size = $_; |
|||
} |
|||
elsif (/^Maintainer:/) { |
|||
$maintainer = $_; |
|||
} |
|||
elsif (/^Source:/) { |
|||
$source = $_; |
|||
} |
|||
# hold ok not-installed - may want to change this just to |
|||
# non-installed. |
|||
elsif (/^Version:/ && $status !~ /not-installed/) { |
|||
$version = $_; |
|||
chomp($version, $section); |
|||
$col1 = "Package: $package[1]"; |
|||
$col2 = $status; |
|||
write PRETTY; |
|||
$col1 = $version; |
|||
$ver = m,Version:\s(.*),; |
|||
# This creates a name -> version index in package.deb, |
|||
# and the statusindex.deb database which will serve to |
|||
# determine if the status has changed when --db or -i is |
|||
# ran. |
|||
push(@name, $package[1]); |
|||
push(@status, $package[1]); |
|||
$package[1] = "$package[1]_$1"; |
|||
push(@name, $package[1]); |
|||
my $priory = substr($priority,10); |
|||
chomp $priory; |
|||
my $statusy = substr($status,8); |
|||
chomp $statusy; |
|||
$statusy =~ s/\s/:/g; |
|||
my $thimk = "$package[1] $group $priory $statusy"; |
|||
push(@status, $thimk); |
|||
if(defined($essential[1])) { |
|||
$col2 = "Essential: $essential[1]"; |
|||
@essential = (); |
|||
} |
|||
else { |
|||
$col2 = "Essential: no\n"; |
|||
} |
|||
write PRETTY; |
|||
if (defined $section) { |
|||
$col1 = $section; |
|||
} |
|||
else { |
|||
$col1 = "Section: unavailable"; |
|||
} |
|||
if (defined $priority) { |
|||
$col2 = $priority; |
|||
} |
|||
else { |
|||
$col2 = "Priority: unavailable\n"; |
|||
} |
|||
write PRETTY; |
|||
#my $cool = $installed_size . $maintainer; |
|||
$col1 = $installed_size; |
|||
if (defined $source) { |
|||
$col2 = $source; |
|||
} |
|||
else { |
|||
$col2 = ""; |
|||
} |
|||
write PRETTY; |
|||
undef $source; |
|||
print PRETTY $maintainer |
|||
} |
|||
|
|||
# This stuff will be available with seperate query flags or All |
|||
elsif (/^Replaces:/) { |
|||
$replaces = $_; |
|||
if (defined($replaces)) { |
|||
push(@REPLACE, "$package[1]REP"); |
|||
push(@REPLACE, $replaces); |
|||
} |
|||
} |
|||
elsif (/^Provides:/) { |
|||
$provides = $_; |
|||
if (defined($provides)) { |
|||
push(@REPLACE, "$package[1]PRO"); |
|||
push(@REPLACE, $provides); |
|||
} |
|||
} |
|||
elsif (/^Depends:/) { |
|||
$depends = $_; |
|||
if (defined($depends)) { |
|||
push(@REPLACE, "$package[1]DEP"); |
|||
push(@REPLACE, $depends); |
|||
} |
|||
} |
|||
elsif (/^Pre-Depends:/) { |
|||
$pre_depends = $_; |
|||
if (defined($pre_depends)) { |
|||
push(@REPLACE, "$package[1]PRE"); |
|||
push(@REPLACE, $pre_depends); |
|||
} |
|||
} |
|||
elsif (/^Recommends:/) { |
|||
$recommends = $_; |
|||
if (defined($recommends)) { |
|||
push(@REPLACE, "$package[1]REC"); |
|||
push(@REPLACE, $recommends); |
|||
} |
|||
} |
|||
elsif (/^Suggests:/) { |
|||
$suggests = $_; |
|||
if (defined($suggests)) { |
|||
push(@REPLACE, "$package[1]SUG"); |
|||
push(@REPLACE, $suggests); |
|||
} |
|||
} |
|||
elsif (/^Conflicts:/) { |
|||
$conflicts = $_; |
|||
if (defined($conflicts)) { |
|||
push(@REPLACE, "$package[1]CON"); |
|||
push(@REPLACE, $conflicts); |
|||
} |
|||
} |
|||
# Gather the Configuration Files, Description comes after. |
|||
# Available with a single flag. |
|||
elsif (/^Conffiles:/) { |
|||
my $line = <AVAIL>; |
|||
while ($line !~ /^Description:/) { |
|||
push(@conffiles,$line); |
|||
$line = <AVAIL>; |
|||
if ($line =~ /^Description/) { |
|||
$line_before = $line; |
|||
# put conffiles into one variable |
|||
if (defined $package[1]) { |
|||
#chomp $package[1]; |
|||
push(@conf,"$package[1]CONF"); |
|||
} |
|||
my ($c, $cool); |
|||
if ($#conffiles != 0) { |
|||
for ($c = $#conffiles; $c >= 0; $c--) { |
|||
if ($c > 0) { |
|||
$cool = $conffiles[$c-1] .= $conffiles[$c]; |
|||
} |
|||
} #end for |
|||
} |
|||
else { |
|||
$cool = $conffiles[0]; |
|||
} |
|||
@conffiles = (); |
|||
push(@conf,$cool); |
|||
} #if ($line =~ /^Desc |
|||
} # while ($line ! /^Desc |
|||
} # elsif (/^Conffiles |
|||
|
|||
# Only interested in available packages..so this is fine. |
|||
# To be combined with first fields. |
|||
if (/Description:|^\s\w*|^\s\.\w*/ || |
|||
defined($line_before) =~ /^Description/){ |
|||
my $many_lines; |
|||
if (defined($line_before)) { |
|||
push(@ldescription, $line_before); |
|||
push(@ldescription, $_); |
|||
$line_before = (); |
|||
} |
|||
else { |
|||
$many_lines = $_; |
|||
} |
|||
if ($_ !~ /^\n$/) { |
|||
$count++; |
|||
if ($count == 1) { |
|||
if (defined $package[1]) { |
|||
#chomp $package[1]; |
|||
push(@dpackage,$package[1]); |
|||
push(@description,$package[1]); |
|||
} |
|||
} |
|||
if (defined($many_lines)) { |
|||
push(@ldescription,$many_lines); |
|||
} |
|||
} # end if ($_ !~ /^\n$/ |
|||
else { |
|||
$count = 0; |
|||
# let's put each description into one scalar |
|||
my ($c, $cool); |
|||
if ($#ldescription != 0) { |
|||
for ($c = $#ldescription; $c >= 0; $c--) { |
|||
if ($c > 0) { |
|||
$cool = $ldescription[$c-1] .= $ldescription[$c]; |
|||
} |
|||
} #end for |
|||
} # end if ($#ld |
|||
else { |
|||
$cool = $ldescription[0]; |
|||
} |
|||
if (defined $cool) { |
|||
push(@description,$cool); |
|||
} |
|||
@ldescription = (); |
|||
} # end else |
|||
$line_before = (); |
|||
} |
|||
} # end while (<AVAIL>) |
|||
close(PRETTY); |
|||
|
|||
# Let's put together the description with the rest of its fields. |
|||
open(FIELDS,"$format_deb"); |
|||
while (<FIELDS>) { |
|||
push(@form,$_); |
|||
} |
|||
close(FIELDS); |
|||
|
|||
foreach (@form) { |
|||
push(@formly,$_); |
|||
my ($cool); |
|||
$count++; |
|||
if ($count == 5) { |
|||
my ($c, $cool); |
|||
if ($#formly != 0) { |
|||
for ($c = $#formly; $c >= 0; $c--) { |
|||
if ($c > 0) { |
|||
$cool = $formly[$c-1] .= $formly[$c]; |
|||
} |
|||
} #end for |
|||
} # end if ($#ld |
|||
else { |
|||
$cool = $formly[0]; |
|||
} |
|||
push(@complete,$cool); |
|||
@formly = (); |
|||
$count = 0; |
|||
} |
|||
} |
|||
|
|||
foreach (@description) { |
|||
if ($count == 1) { |
|||
my $lingo = shift(@complete); |
|||
$lingo = $lingo . $_; |
|||
push(@Tdescription, $lingo); |
|||
$lingo = (); |
|||
$count = 1; |
|||
} |
|||
else { |
|||
push(@Tdescription, $_); |
|||
$count = 0; |
|||
} |
|||
$count++; |
|||
|
|||
} |
|||
unlink($format_deb); |
|||
|
|||
# We'll keep databases local so that md() doesn't get confused with |
|||
# database(). |
|||
|
|||
# Put the groups into the groupindex.deb database. |
|||
print "Group Database is being made\n"; |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
tie %gb, 'DB_File', "$parent$library/groupindex.deb" or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
tie %gb, 'DB_File', "$parent$base/groupindex.deb" or die "DB_File: $!"; |
|||
} |
|||
|
|||
%gb = %group; |
|||
|
|||
untie %gb; |
|||
undef %gb; |
|||
undef %group; |
|||
|
|||
# Create the important status database. |
|||
print "Status Database is being made\n"; |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
tie %sb, 'DB_File', "$parent$library/statusindex.deb" or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
tie %sb, 'DB_File', "$parent$base/statusindex.deb" or die "DB_File: $!"; |
|||
} |
|||
|
|||
%sb = @status; |
|||
|
|||
untie %sb; |
|||
undef %sb; |
|||
undef @status; |
|||
|
|||
# Put everything into the package.deb database. |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
tie %db, 'DB_File', "$parent$library/packages.deb" or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
tie %db, 'DB_File', "$parent$base/packages.deb" or die "DB_File: $!"; |
|||
} |
|||
|
|||
%db = (@name,@Tdescription,@conf,@REPLACE); |
|||
untie %db; |
|||
undef @Tdescription; |
|||
undef @conf; |
|||
undef @REPLACE; |
|||
undef %db; |
|||
|
|||
|
|||
# To the total db thing. |
|||
if ($commands->{"initdb"} || $commands->{"rebuilddb"}) { |
|||
md(\@dpackage,\%commands); |
|||
} |
|||
|
|||
|
|||
} # end sub database |
|||
|
|||
|
|||
# Basically, this writes @dpackage to transfer.deb, which is processed by |
|||
# either fastswim into two files big.debian and long.debian for further |
|||
# processing by process_md() or is processed by imswim, then slowswim into |
|||
# the two files big.debian and long.debian then finished by process_md() |
|||
sub md { |
|||
|
|||
my($dpackage,$commands) = @_; # creates transfer.deb |
|||
my %commands = %$commands; |
|||
|
|||
|
|||
unless (-e "$parent$base/info") { |
|||
die 'This program requires the /var/lib/dpkg/info directory set-up by dpkg'; |
|||
} |
|||
|
|||
# Put all file/dir(*.list)->package_name(s) into an massive array. |
|||
# fastswim runs this process separately. |
|||
|
|||
# This enables info files to be used from a different root system |
|||
my $argument2 = "$parent$base/info"; |
|||
|
|||
# This is just for testing purposes, and serves no real purpose. |
|||
if (!defined(@$dpackage)) { |
|||
system("$fastswim"); |
|||
} |
|||
# This is what is used. |
|||
else { |
|||
open(TRANSFER, ">$tmp/transfer.deb"); |
|||
foreach (@$dpackage) { |
|||
print TRANSFER "$_\n"; |
|||
} |
|||
close(TRANSFER); |
|||
if (!$commands->{"lowmem"}) { |
|||
system $fastswim, "--transfer", $argument2, $tmp; |
|||
} |
|||
else { |
|||
print "Gathering the file(s)/dir(s)\n"; |
|||
system $imswim, $argument2, $tmp; |
|||
system $slowswim, $tmp, $sort; |
|||
} |
|||
} |
|||
undef @$dpackage; |
|||
process_md(\%commands); |
|||
|
|||
} # end sub md |
|||
|
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,497 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::DB_Library; |
|||
use strict; |
|||
use SWIM::Conf; |
|||
use SWIM::Global; |
|||
use SWIM::Library; |
|||
use DB_File; |
|||
use vars qw(@ISA @EXPORT %EXPORT_TAGS); |
|||
|
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(ib nib dbi ndb sb exist_sb nsb ping zing nzing ging gb |
|||
ngb sing ram_on version ver nver nping nzing nging nsing); |
|||
%EXPORT_TAGS = ( |
|||
Search => [ qw(ib dbi nib nsb ndb gb ram_on version ngb) ], |
|||
Db => [ qw(sb ib gb nsb ver dbi zing ging ping sing) ], |
|||
Md => [ qw(sb ib nsb nzing) ], |
|||
Deb => [ qw(sb nsb ndb) ], |
|||
NDb => [ qw(ndb nsb ngb nver nping nzing nging nsing |
|||
exist_sb sb) ], |
|||
Groups => [ qw(gb ngb) ], |
|||
Xyz => [ qw(dbi ndb) ] |
|||
); |
|||
|
|||
|
|||
# functions which use DB_File |
|||
|
|||
|
|||
sub ib { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if (-e "$parent$library/fileindex.deb") { |
|||
tie %ib, 'DB_File', "$parent$library/fileindex.deb" or die "DB_File: $!"; |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (-e "$parent$base/fileindex.deb") { |
|||
tie %ib, 'DB_File', "$parent$base/fileindex.deb" or die "DB_File: $!"; |
|||
} |
|||
} |
|||
} # end sub ib |
|||
|
|||
sub dbi { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if (-e "$parent$library/packages.deb" || |
|||
($commands->{"initndb"} || $commands->{"rebuildndb"})) { |
|||
tie %db, 'DB_File', "$parent$library/packages.deb" or die "DB_File: $!"; |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (-e "$parent$base/packages.deb" || |
|||
($commands->{"initndb"} || $commands->{"rebuildndb"})) { |
|||
tie %db, 'DB_File', "$parent$base/packages.deb" or die "DB_File: $!"; |
|||
} |
|||
} |
|||
} # end sub dbi |
|||
|
|||
|
|||
|
|||
sub nib { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my ($arch,$dist) = which_archdist(\%commands); |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if (!-e "$parent$library/nfileindex$arch$dist.deb") { |
|||
return; |
|||
} |
|||
tie %ib, 'DB_File', "$parent$library/nfileindex$arch$dist.deb" or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (!-e "$parent$base/nfileindex$arch$dist.deb") { |
|||
return; |
|||
} |
|||
tie %ib, 'DB_File', "$parent$base/nfileindex$arch$dist.deb" or die "DB_File: $!"; |
|||
} |
|||
} # end sub nib |
|||
|
|||
|
|||
sub ndb { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my ($arch,$dist) = which_archdist(\%commands); |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if (-e "$parent$library/npackages$arch$dist.deb" || |
|||
($commands->{"initndb"} || $commands->{"rebuildndb"} || |
|||
$commands->{"ndb"})) { |
|||
tie %db, 'DB_File', "$parent$library/npackages$arch$dist.deb" |
|||
or die "swim: use pre-existing databases for this option"; |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (-e "$parent$base/npackages$arch$dist.deb" || |
|||
($commands->{"initndb"} || $commands->{"rebuildndb"} || |
|||
$commands->{"ndb"})) { |
|||
tie %db, 'DB_File', "$parent$base/npackages$arch$dist.deb" |
|||
or die "swim: use pre-existing databases for this option"; |
|||
} |
|||
} |
|||
} # end sub ndb |
|||
|
|||
|
|||
sub sb { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if (-e "$parent$library/statusindex.deb") { |
|||
tie %sb, 'DB_File', "$parent$library/statusindex.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
else { |
|||
return; |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (-e "$parent$base/statusindex.deb") { |
|||
tie %sb, 'DB_File', "$parent$base/statusindex.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
else { |
|||
return; |
|||
} |
|||
} |
|||
} # end sub sb |
|||
|
|||
# exist_sb & sb seem to be used primarily in NDB_Init |
|||
|
|||
# This first looks in the immediate directory for statusindex.deb, if it |
|||
# isn't found here, it look in the default directory. It then returns |
|||
# undef, or initializes the database based on its findings. |
|||
sub exist_sb { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my $yep; |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if (-e "$parent$library/statusindex.deb") { |
|||
$yep = "yes"; |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (-e "$parent$base/statusindex.deb") { |
|||
$yep = "yes"; |
|||
} |
|||
} |
|||
|
|||
if (!defined $yep) { |
|||
if (-e "$parent$base/statusindex.deb") { |
|||
tie %sb, 'DB_File', "$parent$base/statusindex.deb" |
|||
or die "DB_File: $!"; |
|||
return "yes"; |
|||
} |
|||
else { |
|||
return; |
|||
} |
|||
} |
|||
elsif (defined $yep) { |
|||
sb(\%commands); |
|||
return "yes"; |
|||
} |
|||
|
|||
} # end sub exist_sb |
|||
|
|||
sub nsb { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my($arch,$dist) = which_archdist(\%commands); |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if (-e "$parent$library/nstatusindex$arch$dist.deb" || |
|||
($commands->{"initndb"} || $commands->{"rebuildndb"} || |
|||
$commands->{"ndb"})) { |
|||
tie %nsb, 'DB_File', "$parent$library/nstatusindex$arch$dist.deb" |
|||
or die "swim: use pre-existing databases for this option"; |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (-e "$parent$base/nstatusindex$arch$dist.deb" || |
|||
($commands->{"initndb"} || $commands->{"rebuildndb"} || |
|||
$commands->{"ndb"})) { |
|||
tie %nsb, 'DB_File', "$parent$base/nstatusindex$arch$dist.deb" or die |
|||
or die "swim: use pre-existing databases for this option"; |
|||
} |
|||
} |
|||
} # end sub nsb |
|||
|
|||
sub ping { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$ping = tie %db, 'DB_File', "$parent$library/packages.deb" or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$ping = tie %db, 'DB_File', "$parent$base/packages.deb" or die "DB_File: $!"; |
|||
} |
|||
} |
|||
|
|||
sub nping { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my ($arch,$dist) = which_archdist(\%commands); |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$ping = tie %db, 'DB_File', "$parent$library/npackages$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$ping = tie %db, 'DB_File', "$parent$base/npackages$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
} # end sub nping |
|||
|
|||
|
|||
sub zing { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$zing = tie %ib, 'DB_File', "$parent$library/fileindex.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$zing = tie %ib, 'DB_File', "$parent$base/fileindex.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
} # end sub zing |
|||
|
|||
sub nzing { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my ($arch,$dist) = which_archdist(\%commands); |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$zing = tie %ib, 'DB_File', "$parent$library/nfileindex$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$zing = tie %ib, 'DB_File', "$parent$base/nfileindex$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
} # end sub nzing |
|||
|
|||
|
|||
sub ging { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$ging = tie %gb, 'DB_File', "$parent$library/groupindex.deb" or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$ging = tie %gb, 'DB_File', "$parent$base/groupindex.deb" or die "DB_File: $!"; |
|||
} |
|||
} #end sub ging |
|||
|
|||
|
|||
sub nging { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my ($arch,$dist) = which_archdist(\%commands); |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$ging = tie %gb, 'DB_File',"$parent$library/ngroupindex$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$ging = tie %gb, 'DB_File', "$parent$base/ngroupindex$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
} # end sub nging |
|||
|
|||
|
|||
sub gb { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if (-e "$parent$library/groupindex.deb" || |
|||
($commands->{"initndb"} || $commands->{"rebuildndb"})) { |
|||
tie %gb, 'DB_File', "$parent$library/groupindex.deb" or die "DB_File: $!"; |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (-e "$parent$base/groupindex.deb" || |
|||
($commands->{"initndb"} || $commands->{"rebuildndb"})) { |
|||
tie %gb, 'DB_File', "$parent$base/groupindex.deb" or die "DB_File: $!"; |
|||
} |
|||
} |
|||
} |
|||
|
|||
sub ngb { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my ($arch,$dist) = which_archdist(\%commands); |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
if (-e "$parent$library/ngroupindex$arch$dist.deb" || |
|||
($commands->{"initndb"} || $commands->{"rebuildndb"})) { |
|||
tie %gb, 'DB_File', "$parent$library/ngroupindex$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
if (-e "$parent$base/ngroupindex$arch$dist.deb" || |
|||
($commands->{"initndb"} || $commands->{"rebuildndb"})) { |
|||
tie %gb, 'DB_File', "$parent$base/ngroupindex$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
} |
|||
} |
|||
|
|||
sub sing { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$sing = tie %sb, 'DB_File', "$parent$library/statusindex.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$sing = tie %sb, 'DB_File', "$parent$base/statusindex.deb" or die "DB_File: $!"; |
|||
} |
|||
} # sub sing |
|||
|
|||
sub nsing { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my ($arch,$dist) = which_archdist(\%commands); |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$sing = tie %nsb, 'DB_File', "$parent$library/nstatusindex$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$sing = tie %nsb, 'DB_File', "$parent$base/nstatusindex$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
} # end sub nsing |
|||
|
|||
|
|||
# This doesn't depend on DB so it can be placed somewhere else if it is used by more |
|||
# than SWIM::Search. |
|||
|
|||
# checks to see if ramdisk is on, searchdf() & nfile()-process_nfile() |
|||
# (used by file()) uses this |
|||
sub ram_on { |
|||
|
|||
my $ramdisk; |
|||
|
|||
# this monster runs for every argument |
|||
my $rambo = "$cat /proc/mounts|"; |
|||
open(RAM, "$rambo"); |
|||
while (<RAM>) { |
|||
if (/ram/) { |
|||
my($device,$mount) = split(/\s/,$_,2); |
|||
if ($mount =~ /dramdisk/) { |
|||
$ramdisk = "yes"; |
|||
return $ramdisk; |
|||
} |
|||
} |
|||
} |
|||
close(RAM); |
|||
} # end sub ram_on |
|||
|
|||
|
|||
|
|||
# finds package name and version |
|||
sub version { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
if (!$commands{"n"}) { |
|||
dbi(\%commands); |
|||
} |
|||
else { |
|||
ndb(\%commands); |
|||
} |
|||
|
|||
if (defined $argument) { |
|||
# We will check for more than two..just in case |
|||
if ($argument !~ /_/) { |
|||
if (defined $db{$argument}) { |
|||
$argument = $db{$argument}; |
|||
} |
|||
} |
|||
} |
|||
|
|||
} # end sub version |
|||
# returns version but and then is untied |
|||
sub ver { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
dbi(\%commands); |
|||
|
|||
if (defined $argument) { |
|||
# We will check for more than two..just in case |
|||
if ($argument !~ /_/) { |
|||
if (defined $db{$argument}) { |
|||
$argument = $db{$argument}; |
|||
} |
|||
} |
|||
} |
|||
|
|||
untie %db; |
|||
|
|||
} # end sub ver |
|||
|
|||
sub nver { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
ndb(\%commands); |
|||
|
|||
if (defined $argument) { |
|||
# We will check for more than two..just in case |
|||
if ($argument !~ /_/) { |
|||
if (defined $db{$argument}) { |
|||
$argument = $db{$argument}; |
|||
} |
|||
} |
|||
} |
|||
|
|||
untie %db; |
|||
|
|||
} # end sub nver |
|||
|
|||
File diff suppressed because it is too large
@ -0,0 +1,456 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Deps; |
|||
use strict; |
|||
use SWIM::Global qw(:Info); |
|||
use SWIM::DB_Library qw(:Xyz); |
|||
use vars qw(@ISA @EXPORT); |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(character s_character which_character the_character); |
|||
|
|||
# the -T and siblings |
|||
|
|||
# process the database for replaces |
|||
sub replaces { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "REP"; |
|||
if (defined $db{$conf}) { |
|||
return $db{$conf}; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub replaces |
|||
|
|||
# process the database for provides |
|||
sub provides { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "PRO"; |
|||
if (defined $db{$conf}) { |
|||
return $db{$conf}; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub provides |
|||
|
|||
# process the database for depends |
|||
sub depends { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "DEP"; |
|||
if (defined $db{$conf}) { |
|||
return $db{$conf}; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub depends |
|||
|
|||
# process the database for replaces |
|||
sub pre_depends { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "PRE"; |
|||
if (defined $db{$conf}) { |
|||
return $db{$conf}; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub pre_depends |
|||
|
|||
# process the database for replaces |
|||
sub recommends { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "REC"; |
|||
if (defined $db{$conf}) { |
|||
return $db{$conf}; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub recommends |
|||
|
|||
# process the database for replaces |
|||
sub suggests { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "SUG"; |
|||
if (defined $db{$conf}) { |
|||
return $db{$conf}; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub suggests |
|||
|
|||
# process the database for replaces |
|||
sub conflicts { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "CON"; |
|||
if (defined $db{$conf}) { |
|||
return $db{$conf}; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub conflicts |
|||
|
|||
#These subroutines are for cases where only packages related to the |
|||
# characteristics are printed out. |
|||
# process the database for replaces |
|||
sub s_replaces { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "REP"; |
|||
if (defined $db{$conf}) { |
|||
return "$argument\n$db{$conf}"; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub s_replaces |
|||
|
|||
# process the database for provides |
|||
sub s_provides { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "PRO"; |
|||
if (defined $db{$conf}) { |
|||
return "$argument\n$db{$conf}"; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub s_provides |
|||
|
|||
# process the database for depends |
|||
sub s_depends { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "DEP"; |
|||
if (defined $db{$conf}) { |
|||
return "$argument\n$db{$conf}"; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub s_depends |
|||
|
|||
# process the database for replaces |
|||
sub s_pre_depends { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "PRE"; |
|||
if (defined $db{$conf}) { |
|||
return "$argument\n$db{$conf}"; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub s_pre_depends |
|||
|
|||
# process the database for replaces |
|||
sub s_recommends { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "REC"; |
|||
if (defined $db{$conf}) { |
|||
return "$argument\n$db{$conf}"; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub s_recommends |
|||
|
|||
# process the database for replaces |
|||
sub s_suggests { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "SUG"; |
|||
if (defined $db{$conf}) { |
|||
return "$argument\n$db{$conf}"; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub s_suggests |
|||
|
|||
# process the database for replaces |
|||
sub s_conflicts { |
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
!$commands->{"n"} ? dbi(\%commands) : ndb(\%commands); |
|||
if (defined $argument) { |
|||
my $conf = $argument . "CON"; |
|||
if (defined $db{$conf}) { |
|||
return "$argument\n$db{$conf}"; |
|||
} |
|||
else { return ""; } |
|||
} |
|||
untie %db; |
|||
} # end sub s_conflicts |
|||
|
|||
|
|||
# This figures out which characteristics (Replaces, Provides, etc) the |
|||
# options are pointing to. Isn't choosey, prints all packages |
|||
sub character { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
# for singular cases |
|||
if ($commands->{"g"} && ($commands->{"T"} || $commands->{"pre_depends"} || |
|||
$commands->{"depends"} || $commands->{"recommends"} || |
|||
$commands->{"suggests"} || $commands->{"provides"} || |
|||
$commands->{"replaces"} || $commands->{"conflicts"}) && |
|||
!($commands->{"c"} || $commands->{"d"} || $commands->{"l"} || |
|||
$commands->{"i"})) { |
|||
print "$argument\n"; |
|||
} |
|||
|
|||
# all the characteristics |
|||
if (defined $commands->{"T"}) { |
|||
print pre_depends(\%commands); |
|||
print depends(\%commands); |
|||
print recommends(\%commands); |
|||
print suggests(\%commands); |
|||
print provides(\%commands); |
|||
print replaces(\%commands); |
|||
print conflicts(\%commands); |
|||
} |
|||
else { |
|||
|
|||
if (defined $commands->{"pre_depends"}) { |
|||
print pre_depends(\%commands); |
|||
delete $commands{"pre_depends"} if !($commands->{"S"} || $commands->{"g"}); |
|||
} |
|||
|
|||
if (defined $commands->{"depends"}) { |
|||
print depends(\%commands); |
|||
delete $commands{"depends"} if !($commands->{"S"} || $commands->{"g"}); |
|||
} |
|||
|
|||
if (defined $commands->{"recommends"}) { |
|||
print recommends(\%commands); |
|||
delete $commands{"recommends"} if !($commands->{"S"} || $commands->{"g"}); |
|||
} |
|||
|
|||
if (defined $commands->{"suggests"}) { |
|||
print suggests(\%commands); |
|||
delete $commands{"suggests"} if !($commands->{"S"} || $commands->{"g"}); |
|||
} |
|||
|
|||
if (defined $commands->{"replaces"}) { |
|||
print replaces(\%commands); |
|||
delete $commands{"replaces"} if !($commands->{"S"} || $commands->{"g"}); |
|||
} |
|||
|
|||
if (defined $commands->{"provides"}) { |
|||
print provides(\%commands); |
|||
delete $commands{"provides"} if !($commands->{"S"} || $commands->{"g"}); |
|||
} |
|||
|
|||
if (defined $commands->{"conflicts"}) { |
|||
print conflicts(\%commands); |
|||
delete $commands{"conflicts"} if !($commands->{"S"} || $commands->{"g"}); |
|||
} |
|||
} |
|||
|
|||
} # end sub character |
|||
|
|||
# Prints out the characteristics only for the packages which have them. |
|||
sub s_character { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
if ($commands->{"pre_depends"}) { |
|||
print s_pre_depends(\%commands); |
|||
delete $commands{"pre_depends"}; |
|||
if (s_pre_depends(\%commands) ne "") { |
|||
character(\%commands); |
|||
} |
|||
# else { s_character(\%commands) } |
|||
} |
|||
elsif ($commands->{"depends"}) { |
|||
print s_depends(\%commands); |
|||
delete $commands{"depends"}; |
|||
if (s_depends(\%commands) ne "") { |
|||
character(\%commands); |
|||
} |
|||
# else { s_character(\%commands) } |
|||
} |
|||
elsif ($commands->{"recommends"}) { |
|||
print s_recommends(\%commands); |
|||
delete $commands{"recommends"}; |
|||
if (s_recommends(\%commands) ne "") { |
|||
character(\%commands); |
|||
} |
|||
# else { s_character(\%commands) } |
|||
} |
|||
elsif ($commands->{"suggests"}) { |
|||
print s_suggests(\%commands); |
|||
delete $commands{"suggests"}; |
|||
if (s_suggests(\%commands) ne "") { |
|||
character(\%commands); |
|||
} |
|||
# else { s_character(\%commands) } |
|||
} |
|||
elsif ($commands->{"replaces"}) { |
|||
print s_replaces(\%commands); |
|||
delete $commands{"replaces"}; |
|||
if (s_replaces(\%commands) ne "") { |
|||
character(\%commands); |
|||
} |
|||
# else { s_character(\%commands) } |
|||
} |
|||
elsif ($commands->{"provides"}) { |
|||
print s_provides(\%commands); |
|||
delete $commands{"provides"}; |
|||
if (s_provides(\%commands) ne "") { |
|||
character(\%commands); |
|||
} |
|||
# else { s_character(\%commands) } |
|||
} |
|||
elsif ($commands->{"conflicts"}) { |
|||
print s_conflicts(\%commands); |
|||
delete $commands{"conflicts"}; |
|||
if (s_conflicts(\%commands) ne "") { |
|||
character(\%commands); |
|||
} |
|||
# else { s_character(\%commands) } |
|||
} |
|||
|
|||
# all the characteristics |
|||
if ($commands->{"T"}) { |
|||
print s_pre_depends(\%commands); |
|||
print s_depends(\%commands); |
|||
print s_recommends(\%commands); |
|||
print s_suggests(\%commands); |
|||
print s_provides(\%commands); |
|||
print s_replaces(\%commands); |
|||
print s_conflicts(\%commands); |
|||
} |
|||
|
|||
|
|||
} # end sub s_character |
|||
|
|||
|
|||
# helps to determine if character(\%commands) should be used |
|||
sub which_character { |
|||
my ($commands) = @_; |
|||
if ($commands->{"pre_depends"} || $commands->{"depends"} || |
|||
$commands->{"recommends"} || $commands->{"suggests"} || |
|||
$commands->{"replaces"} || $commands->{"provides"} || |
|||
$commands->{"conflicts"}) { |
|||
return 1; |
|||
} |
|||
} # end sub which_character |
|||
|
|||
# This runs a test to see whether or not the characters being asked for |
|||
# apply to this package. |
|||
sub the_character { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
if (defined $commands->{"pre_depends"}) { |
|||
if (pre_depends(\%commands) eq "") { |
|||
print ""; |
|||
} |
|||
else { return "ok"; } |
|||
} |
|||
|
|||
if (defined $commands->{"depends"}) { |
|||
if (depends(\%commands) eq "") { |
|||
print ""; |
|||
} |
|||
else { return "ok"; } |
|||
} |
|||
|
|||
if (defined $commands->{"recommends"}) { |
|||
if (recommends(\%commands) eq "") { |
|||
print ""; |
|||
} |
|||
else { return "ok"; } |
|||
} |
|||
|
|||
if (defined $commands->{"suggests"}) { |
|||
if (suggests(\%commands) eq "") { |
|||
print ""; |
|||
} |
|||
else { return "ok"; } |
|||
} |
|||
|
|||
if (defined $commands->{"replaces"}) { |
|||
if (replaces(\%commands) eq "") { |
|||
print ""; |
|||
} |
|||
else { return "ok"; } |
|||
} |
|||
|
|||
if (defined $commands->{"provides"}) { |
|||
if (provides(\%commands) eq "") { |
|||
print ""; |
|||
} |
|||
else { return "ok"; } |
|||
} |
|||
|
|||
if (defined $commands->{"conflicts"}) { |
|||
if (conflicts(\%commands) eq "") { |
|||
print ""; |
|||
} |
|||
else { return "ok"; } |
|||
} |
|||
|
|||
} # end sub the_character |
|||
|
|||
1; |
|||
@ -0,0 +1,110 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Dir; |
|||
use strict; |
|||
use SWIM::Global qw($argument); |
|||
use SWIM::Conf qw($pwd); |
|||
use vars qw(@ISA @EXPORT @EXPORT_OK); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(dir fir); |
|||
|
|||
# dir() fir() |
|||
|
|||
# When --dir is used checks argument (when -f is called) and determines dir |
|||
# stuff..is it real or not. |
|||
sub dir { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
if ($commands->{"dir"}) { |
|||
if (! -d $argument) { |
|||
if (! -e $argument) { |
|||
print "$argument is not a directory or file\n"; |
|||
} |
|||
else { |
|||
print "$argument is not a directory\n"; |
|||
} |
|||
exit; |
|||
} |
|||
elsif ($argument =~ m,\/$,) { |
|||
if ($argument !~ m,^\/,) { |
|||
if ($pwd =~ m,^\/$,) { |
|||
$argument =~ m,(.*)\/$,; |
|||
$argument = "$pwd$1"; |
|||
} |
|||
else { |
|||
$argument =~ m,(.*)\/$,; |
|||
$argument = "$pwd/$1"; |
|||
} |
|||
} |
|||
else { |
|||
$argument =~ m,(.*)\/$,; |
|||
$argument = $1; |
|||
} |
|||
} |
|||
elsif ($argument !~ m,\/$|^\/, && $argument =~ m,\/,) { |
|||
if ($pwd =~ m,^\/$,) { |
|||
$argument = "/$argument"; |
|||
} |
|||
else { |
|||
$argument = "$pwd/$argument"; |
|||
} |
|||
} |
|||
} |
|||
} # end sub dir |
|||
|
|||
# when --dir isn't called...does the same thing as dir. |
|||
sub fir { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
if ($argument =~ m,\/$,) { |
|||
# Let's test to see whether it really is a file or directory. |
|||
if (! -d $argument) { |
|||
print "$argument is not a file\n"; |
|||
exit; |
|||
} |
|||
if ($argument !~ m,^\/,) { |
|||
if ($pwd =~ m,^\/$,) { |
|||
$argument =~ m,(.*)\/$,; |
|||
$argument = "$pwd$1"; |
|||
} |
|||
else { |
|||
$argument =~ m,(.*)\/$,; |
|||
$argument = "$pwd/$1"; |
|||
} |
|||
} |
|||
else { |
|||
$argument =~ m,(.*)\/$,; |
|||
$argument = $1; |
|||
} |
|||
} |
|||
elsif ($argument !~ m,\/$|^\/, && $argument =~ m,\/,) { |
|||
if ($pwd =~ m,^\/$,) { |
|||
$argument = "/$argument"; |
|||
} |
|||
else { |
|||
$argument = "$pwd/$argument"; |
|||
} |
|||
} |
|||
} # end sub fir |
|||
|
|||
1; |
|||
|
|||
@ -0,0 +1,92 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::F; |
|||
use Carp; |
|||
use strict; |
|||
use vars qw(@ISA @EXPORT); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(get); |
|||
|
|||
|
|||
# This is Net::FTP::get with minor modifications. Not all the features |
|||
# are used, but are kept, just in case they will be. |
|||
|
|||
sub get |
|||
{ |
|||
my($ftp,$remote,$local,$where) = @_; |
|||
|
|||
my($loc,$len,$buf,$resp,$localfd,$data); |
|||
local *FD; |
|||
$| = 1; |
|||
$localfd = ref($local) ? fileno($local) |
|||
: undef; |
|||
|
|||
($local = $remote) =~ s#^.*/## |
|||
unless(defined $local); |
|||
|
|||
${*$ftp}{'net_ftp_rest'} = $where |
|||
if ($where); |
|||
|
|||
delete ${*$ftp}{'net_ftp_port'}; |
|||
delete ${*$ftp}{'net_ftp_pasv'}; |
|||
|
|||
$data = $ftp->retr($remote) or |
|||
return undef; |
|||
|
|||
if(defined $localfd) |
|||
{ |
|||
$loc = $local; |
|||
} |
|||
else |
|||
{ |
|||
$loc = \*FD; |
|||
|
|||
unless(($where) ? open($loc,">>$local") : open($loc,">$local")) |
|||
{ |
|||
carp "Cannot open Local file $local: $!\n"; |
|||
$data->abort; |
|||
return undef; |
|||
} |
|||
} |
|||
|
|||
if($ftp->type eq 'I' && !binmode($loc)) |
|||
{ |
|||
carp "Cannot binmode Local file $local: $!\n"; |
|||
$data->abort; |
|||
return undef; |
|||
} |
|||
|
|||
$buf = ''; my $amt = 0; |
|||
#print "\n"; |
|||
do |
|||
{ |
|||
$len = $data->read($buf,1024); |
|||
$amt = $len + $amt; |
|||
print "[$amt]\r"; |
|||
} |
|||
while($len > 0 && syswrite($loc,$buf,$len) == $len); |
|||
|
|||
close($loc) |
|||
unless defined $localfd; |
|||
|
|||
$data->close(); # implied $ftp->response |
|||
|
|||
return $local; |
|||
} |
|||
@ -0,0 +1,877 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::File; |
|||
use strict; |
|||
use SWIM::Global; |
|||
use SWIM::DB_Library qw(:Xyz ram_on nsb); |
|||
use SWIM::Library; |
|||
use SWIM::Conf qw(:Path $md5sum); |
|||
use vars qw(@ISA @EXPORT); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(file); |
|||
|
|||
|
|||
#=pod |
|||
# |
|||
#This provides the list of files belonging to a package. Although a |
|||
#database could be used..it's probably faster, and cheaper on space |
|||
#accessing from the /var/lib/dpkg/info* files. And if --md5sum is |
|||
#called, the md5sums are shown for the -d ,-l, or -c files they exist for. |
|||
#md5sums are checked for, and reported back as OK or FAILED. -l or |
|||
#-d(overrides l). -qd(l) md5sum from RH has a slightly different |
|||
#output.. filepath/filename: file OK before swim's output..this can be |
|||
#altered |
|||
# |
|||
#=end |
|||
|
|||
sub file { |
|||
|
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my $file; |
|||
my $md5; |
|||
my @md5; |
|||
my $path; |
|||
my @path; |
|||
my $md5sums; |
|||
my $md5sums_conf; |
|||
my %md5sums = (); |
|||
my $orig_argument; |
|||
my $count = 0; |
|||
|
|||
|
|||
if (!$commands->{"n"}) { |
|||
dbi(\%commands); |
|||
} |
|||
# files/dirs will be found from contents.deb (compressed) |
|||
else { |
|||
ndb(\%commands); |
|||
} |
|||
|
|||
if (defined $argument) { |
|||
if ($argument =~ /_/) { |
|||
my $check; |
|||
if (defined $db{"$argument"}) { |
|||
$check = $db{"$argument"}; |
|||
} |
|||
$argument =~ m,(^.*)_(.*$),; |
|||
if (defined $check) { |
|||
$argument = $1; |
|||
} |
|||
else {} |
|||
} |
|||
} |
|||
|
|||
|
|||
|
|||
if (defined $argument) { |
|||
if (!$commands->{"n"}) { |
|||
$file = "$parent$base/info/$argument.list"; |
|||
if (-e "$parent$base/info/$argument.md5sums") { |
|||
$md5sums = "$parent$base/info/$argument.md5sums"; |
|||
} |
|||
if (-e "$parent$base/info/$argument-conf.md5sums" && $commands->{"c"}) { |
|||
$md5sums_conf = "$parent$base/info/$argument-conf.md5sums"; |
|||
} |
|||
|
|||
|
|||
################## |
|||
# MD5SUMS FOR -C # |
|||
################## |
|||
if ($commands->{"md5sum"} && $commands->{"c"} && !($commands->{"d"} || |
|||
$commands->{"l"})) { |
|||
if (!defined $md5sums_conf && $commands->{"c"}) { |
|||
$md5sums_conf = make_conf(\%commands); |
|||
} |
|||
# now we can process $md5sums and $md5sums_conf assuming one or |
|||
# both actually exist |
|||
if (defined $md5sums_conf) { |
|||
chdir("/"); |
|||
my %path; |
|||
open (MD5SUM, "$md5sums_conf"); |
|||
open (MD5SUMCHECK, "|$md5sum -c 2>$tmp/md5sumcheck"); |
|||
while (<MD5SUM>) { |
|||
if ($_ =~ /newconffile/) { |
|||
$path = substr($_, 13); |
|||
push(@path,$path); |
|||
$md5 = substr($_, 0, 11); |
|||
push(@md5,$md5); |
|||
chomp $path; |
|||
chomp $md5; |
|||
$path{"$path"} = $md5; |
|||
print MD5SUMCHECK $_; |
|||
next; |
|||
} |
|||
$path = substr($_, 34); |
|||
push(@path,$path); |
|||
$md5 = substr($_, 0, 32); |
|||
push(@md5,$md5); |
|||
chomp $path; |
|||
chomp $md5; |
|||
$path{"$path"} = $md5; |
|||
print MD5SUMCHECK $_; |
|||
} |
|||
close(MD5SUMCHECK); |
|||
close(MD5SUM); |
|||
#now check with md5sum from the dpkg package |
|||
my $check_md5sum; |
|||
# won't bother going into this while unless there is a reason |
|||
if (defined "$tmp/md5sumcheck" && $md5 ne "newconffile") { |
|||
open(MD5SUMFILE, "$tmp/md5sumcheck"); |
|||
while (<MD5SUMFILE>) { |
|||
if ($_ !~ /no files checked/) { |
|||
if (/failed/) { |
|||
# Humm may be two situations watch or due to coding change |
|||
#$check_md5sum = substr($_,39); |
|||
$check_md5sum = substr($_,30); |
|||
$check_md5sum =~ s/'//; |
|||
chomp $check_md5sum; |
|||
$md5sums{"$check_md5sum"} = "FAILED"; |
|||
} |
|||
elsif (/can't open/) { |
|||
# Humm may be two situations watch or due to coding change |
|||
#$check_md5sum = substr($_,28); |
|||
$check_md5sum = substr($_,19); |
|||
chomp $check_md5sum; |
|||
$md5sums{"$check_md5sum"} = "MISSING"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
close(MD5SUMCHECK); |
|||
unlink("$tmp/md5sumcheck"); |
|||
# This finishes everything |
|||
open (LIST,"$md5sums_conf"); |
|||
while (<LIST>) { |
|||
if ($_ =~ /newconffile/) { |
|||
$_ = substr($_, 13); |
|||
chomp; |
|||
} |
|||
else { |
|||
$_ = substr($_, 34); |
|||
chomp; |
|||
} |
|||
if (defined $path{$_}) { |
|||
# humm file_now() not necessary here |
|||
if (defined $md5sums{$_}) { |
|||
print " /$_ $path{$_} $md5sums{$_}\n"; |
|||
} |
|||
elsif ($path{$_} ne "newconffile") { |
|||
print " /$_ $path{$_} OK"; |
|||
print "\n"; |
|||
} |
|||
else { |
|||
print " /$_ $path{$_}\n"; |
|||
} |
|||
} |
|||
} # last while |
|||
close(LIST); |
|||
%md5sums = (); |
|||
%path = (); |
|||
@path = (); |
|||
@md5 = (); |
|||
} # do the md5sum files even exist? |
|||
} |
|||
|
|||
######################## |
|||
# MD5SUMS FOR -C &| -L # |
|||
######################## |
|||
# checking for -e $md5sums is a questionable practice because it |
|||
# may not exist, but the conf files do. |
|||
if ($commands->{"md5sum"} && !$commands->{"d"} && |
|||
(($commands->{"l"} && $commands->{"c"}) || $commands->{"l"})) { |
|||
# I decided on three while loops, because it was the most practical |
|||
# way to handle STDERR from md5sum, and all types of |
|||
# experimentation didn't yield a better way of doing it, but there |
|||
# is probably a better way. |
|||
# first do things normally, and no chomping |
|||
# but, first grab conf info. |
|||
if (!defined $md5sums_conf && $commands->{"c"}) { |
|||
$md5sums_conf = make_conf(\%commands); |
|||
} |
|||
# now we can process $md5sums and $md5sums_conf assuming one or |
|||
# both actually exist |
|||
if (defined $md5sums || defined $md5sums_conf) { |
|||
#if ($md5sums_conf ne 1) { |
|||
chdir("/"); |
|||
my %path; |
|||
if ($commands->{"c"} && $md5sums_conf) { |
|||
open (MD5SUM,"$md5sums_conf"); |
|||
} |
|||
else { |
|||
open (MD5SUM,"$md5sums"); |
|||
$count = 1; |
|||
} |
|||
while ($count <= 1) { |
|||
if (($count == 1 && defined $md5sums) || $count == 0) { |
|||
open (MD5SUMCHECK, "|$md5sum -c 2>$tmp/md5sumcheck"); |
|||
while (<MD5SUM>) { |
|||
if ($_ =~ /newconffile/) { |
|||
$path = substr($_, 13); |
|||
push(@path,$path); |
|||
$md5 = substr($_, 0, 11); |
|||
push(@md5,$md5); |
|||
chomp $path; |
|||
chomp $md5; |
|||
$path{"/$path"} = $md5; |
|||
print MD5SUMCHECK $_; |
|||
next; |
|||
} |
|||
$path = substr($_, 34); |
|||
push(@path,$path); |
|||
$md5 = substr($_, 0, 32); |
|||
push(@md5,$md5); |
|||
chomp $path; |
|||
chomp $md5; |
|||
$path{"/$path"} = $md5; |
|||
print MD5SUMCHECK $_; |
|||
} |
|||
close(MD5SUMCHECK); |
|||
close(MD5SUM); |
|||
#now check with md5sum from the dpkg package |
|||
my $check_md5sum; |
|||
#my $count = 0; |
|||
# won't bother going into this while unless there is a reason |
|||
if (defined "$tmp/md5sumcheck" && $md5 ne "newconffile") { |
|||
open(MD5SUMFILE, "$tmp/md5sumcheck"); |
|||
while (<MD5SUMFILE>) { |
|||
if ($_ !~ /no files checked/) { |
|||
if (/failed/) { |
|||
$check_md5sum = substr($_,30); |
|||
$check_md5sum =~ s/'//; |
|||
chomp $check_md5sum; |
|||
$md5sums{"/$check_md5sum"} = "FAILED"; |
|||
} |
|||
elsif (/can't open/) { |
|||
$check_md5sum = substr($_,19); |
|||
#$check_md5sum =~ s/'//; |
|||
chomp $check_md5sum; |
|||
$md5sums{"/$check_md5sum"} = "MISSING"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
close(MD5SUMCHECK); |
|||
unlink("$tmp/md5sumcheck"); |
|||
} |
|||
# This finishes everything |
|||
# This prunes stuff out and assumes that *.list and *.md5sums |
|||
# overlap. |
|||
open (LIST,"$file"); |
|||
###### |
|||
# -L # |
|||
###### |
|||
if ($commands->{"l"} && !$commands->{"df"}) { |
|||
while (<LIST>) { |
|||
chomp; |
|||
if (!-d $_ && $argument ne "base-files") { |
|||
my $line = $_; |
|||
file_now(\%commands); |
|||
md5_print(\%path,\%md5sums,$line,$count); |
|||
} |
|||
############## |
|||
# BASE-FILES # |
|||
############## |
|||
elsif ($argument eq "base-files") { |
|||
my $line = $_; |
|||
md5_print(\%path,\%md5sums,$line,$count); |
|||
} |
|||
} # last while |
|||
} |
|||
############# |
|||
# -L & --DF # |
|||
############# |
|||
elsif ($commands->{"l"} && $commands->{"df"}) { |
|||
while (<LIST>) { |
|||
chomp; |
|||
my $line = $_; |
|||
file_now(\%commands); |
|||
md5_print(\%path,\%md5sums,$line,$count); |
|||
} # last while |
|||
} |
|||
close(LIST); |
|||
%md5sums = (); |
|||
%path = (); |
|||
@path = (); |
|||
@md5 = (); |
|||
$count++; |
|||
if ($count == 1) { |
|||
open (MD5SUM,"$md5sums") if $md5sums; |
|||
} |
|||
} # loop through -c or not |
|||
} # do the md5sum files even exist? |
|||
#} |
|||
} |
|||
#@@ got to watch this for -l's called directly, will allow -l to |
|||
# be seen whether or not --md5sum is used, changed elsif to if. |
|||
# if already found above don't use below here. |
|||
# && ||'s tricky here |
|||
if (-e $file && !$commands->{"d"} && (!defined $md5sums && |
|||
!defined $md5sums_conf) || -e $file && |
|||
(!$commands->{"md5sum"} && !$commands->{"d"})) { |
|||
file_now(\%commands) if !$commands->{"f"}; |
|||
open (LIST,"$file"); |
|||
while (<LIST>) { |
|||
chomp; |
|||
if ($commands->{"l"} && !$commands->{"df"}) { |
|||
if (!-d $_ && $argument ne "base-files") { |
|||
print "$_\n"; |
|||
} |
|||
elsif ($argument eq "base-files") { |
|||
print "$_\n"; |
|||
} |
|||
} |
|||
elsif ($commands->{"l"} && $commands->{"df"}) { |
|||
if ($argument ne "base-files") { |
|||
print "$_\n"; |
|||
} |
|||
elsif ($argument eq "base-files") { |
|||
print "$_\n"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
|
|||
######################## |
|||
# MD5SUMS FOR -C &| -D # |
|||
######################## |
|||
# for Documentation. |
|||
elsif ($commands->{"md5sum"} && ($commands->{"d"} || ($commands->{"d"} && |
|||
$commands->{"c"}))) { |
|||
if (!defined $md5sums_conf && $commands->{"c"}) { |
|||
$md5sums_conf = make_conf(\%commands); |
|||
} |
|||
# now we can process $md5sums and $md5sums_conf assuming one or |
|||
# both actually exist |
|||
if (defined $md5sums || defined $md5sums_conf) { |
|||
chdir("/"); |
|||
my %path; |
|||
if ($commands->{"c"} && $md5sums_conf) { |
|||
open (MD5SUM,"$md5sums_conf"); |
|||
} |
|||
else { |
|||
open (MD5SUM,"$md5sums"); |
|||
$count = 1; |
|||
} |
|||
while ($count <= 1) { |
|||
if (($count == 1 && defined $md5sums) || $count == 0) { |
|||
open (MD5SUMCHECK, "|$md5sum -c 2>$tmp/md5sumcheck"); |
|||
while (<MD5SUM>) { |
|||
if ($_ =~ /newconffile/) { |
|||
$path = substr($_, 13); |
|||
push(@path,$path); |
|||
$md5 = substr($_, 0, 11); |
|||
push(@md5,$md5); |
|||
chomp $path; |
|||
chomp $md5; |
|||
$path{"/$path"} = $md5; |
|||
print MD5SUMCHECK $_; |
|||
next; |
|||
} |
|||
$path = substr($_, 34); |
|||
push(@path,$path); |
|||
$md5 = substr($_, 0, 32); |
|||
push(@md5,$md5); |
|||
chomp $path; |
|||
chomp $md5; |
|||
$path{"/$path"} = $md5; |
|||
print MD5SUMCHECK $_; |
|||
} |
|||
close(MD5SUMCHECK); |
|||
close(MD5SUM); |
|||
#now check with md5sum from the dpkg package |
|||
my $check_md5sum; |
|||
# won't bother going into this while unless there is a reason |
|||
if (defined "$tmp/md5sumcheck") { |
|||
open(MD5SUMFILE, "$tmp/md5sumcheck"); |
|||
while (<MD5SUMFILE>) { |
|||
if ($_ !~ /no files checked/) { |
|||
if (/failed/) { |
|||
$check_md5sum = substr($_,30); |
|||
$check_md5sum =~ s/'//; |
|||
chomp $check_md5sum; |
|||
$md5sums{"/$check_md5sum"} = "FAILED"; |
|||
} |
|||
elsif (/can't open/) { |
|||
$check_md5sum = substr($_,19); |
|||
chomp $check_md5sum; |
|||
$md5sums{"/$check_md5sum"} = "MISSING"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
close(MD5SUMCHECK); |
|||
unlink("$tmp/md5sumcheck"); |
|||
} |
|||
# This finishes everything |
|||
open (LIST,"$file"); |
|||
while (<LIST>) { |
|||
chomp; |
|||
# humm, checking for existence? |
|||
#if (-e $_ && $argument ne "base-files") { |
|||
if ($argument ne "base-files") { |
|||
#@@ |
|||
###### |
|||
# -D # |
|||
###### |
|||
if (defined $path{$_}) { |
|||
if (defined $md5sums{$_}) { |
|||
if ($count == 0) { |
|||
print " $_ $path{$_} $md5sums{$_}" if $count == 0; |
|||
print "$_ $path{$_} $md5sums{$_}" if $count == 1; |
|||
print "\n"; |
|||
} |
|||
elsif (m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, && |
|||
$count == 1) { |
|||
print " $_ $path{$_} $md5sums{$_}" if $count == 0; |
|||
print "$_ $path{$_} $md5sums{$_}" if $count == 1; |
|||
print "\n"; |
|||
} |
|||
} |
|||
elsif ($path{$_} ne "newconffile") { |
|||
if ($count == 0) { |
|||
print " $_ $path{$_} OK" if $count == 0; |
|||
print "$_ $path{$_} OK" if $count == 1; |
|||
print "\n"; |
|||
} |
|||
elsif (m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, && |
|||
$count == 1) { |
|||
print " $_ $path{$_} OK" if $count == 0; |
|||
print "$_ $path{$_} OK" if $count == 1; |
|||
print "\n"; |
|||
} |
|||
} |
|||
else { |
|||
if ($count == 0) { |
|||
print " $_ $path{$_}\n" if $count == 0; |
|||
print "$_ $path{$_}\n" if $count == 1; |
|||
print "\n"; |
|||
} |
|||
elsif (m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, && |
|||
$count == 1) { |
|||
print " $_ $path{$_} OK" if $count == 0; |
|||
print "$_ $path{$_} OK" if $count == 1; |
|||
print "\n"; |
|||
} |
|||
} |
|||
} |
|||
elsif ($count == 1) { |
|||
if (m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, && !-d) { |
|||
file_now(\%commands); |
|||
print "$_\n"; |
|||
} |
|||
} |
|||
} |
|||
# humm? treated specially, hopefully. |
|||
###################### |
|||
# BASE-FILES PACKAGE # |
|||
###################### |
|||
elsif ($argument eq "base-files") { |
|||
my $line = $_; |
|||
if ($line =~ m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, || |
|||
defined $path{$line}) { |
|||
md5_print(\%path,\%md5sums,$line,$count); |
|||
} |
|||
} |
|||
} # another while |
|||
close(LIST); |
|||
%md5sums = (); |
|||
%path = (); |
|||
@path = (); |
|||
@md5 = (); |
|||
$count++; |
|||
if ($count == 1) { |
|||
open (MD5SUM,"$md5sums") if $md5sums; |
|||
} |
|||
} # loop through -c or not |
|||
} # do the md5sum files even exist? |
|||
} |
|||
#@@ another important change, print --md5sum and -l together |
|||
if (-e $file && $commands->{"d"} && (!defined $md5sums && |
|||
!defined $md5sums_conf) || -e $file && |
|||
(!$commands->{"md5sum"} && $commands->{"d"})) { |
|||
file_now(\%commands) if !$commands->{"f"}; |
|||
#if (-e $file && $commands->{"d"}) { |
|||
open (LIST,"$file"); |
|||
while (<LIST>) { |
|||
chomp; |
|||
if (m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/, && !-d) { |
|||
print "$_\n"; |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
#if (!defined $md5sums || !defined $md5sums_conf) { |
|||
if (!-e $file) { |
|||
print "package $argument is not installed\n"; |
|||
} |
|||
} |
|||
} # if !--n |
|||
else { |
|||
# Let's check first if this package actually exists, files are checked |
|||
# earlier. |
|||
if (defined $argument) { |
|||
if (!defined $db{"$argument"}) { |
|||
print "package $argument is not installed\n"; |
|||
exit; |
|||
} |
|||
} |
|||
nfile(\%commands); |
|||
} |
|||
} # if defined $argument |
|||
|
|||
untie %db; |
|||
|
|||
|
|||
if (defined $file_now && !($commands->{"z"} || |
|||
$commands->{"ftp"} || |
|||
$commands->{"remove"} || $commands->{"r"} || |
|||
$commands->{"purge"})) { |
|||
if ($commands{"x"} || $commands{"ftp"} || $commands{"source"} || |
|||
$commands{"source_only"} || $commands{"remove"} || |
|||
$commands{"r"} || $commands{"purge"}) { |
|||
require SWIM::Safex; |
|||
SWIM::Safex->import(qw(safex)); |
|||
safex(\%commands); |
|||
} |
|||
} |
|||
|
|||
|
|||
} # end sub file |
|||
|
|||
# this manages situation involving -qlcx & -qglx |
|||
sub file_now { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
#if (!$commands->{"g"} && !defined $file_now) { |
|||
if (!$commands->{"g"}) { |
|||
if ($arg_count < $#ARGV) { |
|||
push(@arg_holder,$argument); |
|||
# humm |
|||
#@PACKAGES = "DEFINEDONE"; |
|||
#@PACKAGES = "$ARGV[$#ARGV]"; |
|||
$arg_count++; |
|||
} |
|||
else { |
|||
@PACKAGES = @arg_holder; |
|||
push(@PACKAGES,$argument); |
|||
} |
|||
} |
|||
else { |
|||
if ($arg_count < $#stuff) { |
|||
push(@arg_holder,$argument); |
|||
#$arg_count++; |
|||
} |
|||
else { |
|||
@PACKAGES = @arg_holder; |
|||
push(@PACKAGES,$argument); |
|||
} |
|||
} |
|||
|
|||
} # end file_now |
|||
|
|||
# In order to run a md5sum test on configuration files directly recognized |
|||
# by dpkg, a file with package_name-conf.md5sums is created, in addition to |
|||
# any existing package_name.md5sums file. |
|||
sub make_conf { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my $md5sums_conf; |
|||
if (!$commands->{"n"}) { |
|||
dbi(\%commands); |
|||
} |
|||
# humm, just a trap |
|||
else { |
|||
ndb(\%commands); |
|||
} |
|||
|
|||
if ($argument !~ /_/ ) { |
|||
# I guess we can stop here here is there are no configuration |
|||
# files |
|||
if (defined $db{$argument}) { |
|||
require SWIM::Info; |
|||
SWIM::Info->import(qw(conf)); |
|||
my $orig_argument = $argument; |
|||
$argument = $db{$argument}; |
|||
my ($conf, @conf, %conf); |
|||
my ($m5, $dir, $thing); |
|||
if (conf(\%commands) ne 0) { |
|||
$conf = conf(\%commands); |
|||
@conf = split(/\n/, $conf); |
|||
open(PACKCONF,">$parent$base/info/$orig_argument-conf.md5sums"); |
|||
foreach (@conf) { |
|||
$_ =~ m,( \/)(.*$),; |
|||
($dir, $m5) = split(/ /, $2, 2); |
|||
$thing = "$m5 $dir\n"; |
|||
print PACKCONF $thing; |
|||
} |
|||
close(PACKCONF); |
|||
$md5sums_conf = |
|||
"$parent$base/info/$orig_argument-conf.md5sums"; |
|||
return $md5sums_conf; |
|||
} |
|||
else { |
|||
return; |
|||
} |
|||
} |
|||
} |
|||
untie %db; |
|||
|
|||
} # end sub make_conf |
|||
|
|||
|
|||
# prints out the results from the md5sum test for -l & -l --df |
|||
sub md5_print { |
|||
|
|||
my ($path, $md5sums, $line, $count) = @_; |
|||
|
|||
if (defined $path->{$line}) { |
|||
if (defined $md5sums->{$line}) { |
|||
print " $line $path->{$line} $md5sums->{$line}" if $count == 0; |
|||
print "$line $path->{$line} $md5sums->{$line}" if $count == 1; |
|||
print "\n"; |
|||
} |
|||
elsif ($path->{$line} ne "newconffile") { |
|||
print " $line $path->{$line} OK" if $count == 0; |
|||
print "$line $path->{$line} OK" if $count == 1; |
|||
print "\n"; |
|||
} |
|||
else { |
|||
print " $line $path->{$line}\n" if $count == 0; |
|||
print "$line $path->{$line}\n" if $count == 1; |
|||
} |
|||
} |
|||
elsif ($count == 1) { |
|||
print "$line\n"; |
|||
} |
|||
|
|||
} # end md5_print |
|||
|
|||
|
|||
# -n The list of files/dirs belonging to a package. No md5sum here. |
|||
sub nfile { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
my $ramdisk = ram_on(\%commands); |
|||
|
|||
# Here's a case where gnu grep is faster than using open. |
|||
if ($ramdisk eq "yes") { |
|||
my $what = "yes"; |
|||
process_nfile($what,\%commands); |
|||
} # if ramdisk |
|||
|
|||
elsif ($ramdisk eq 1) { |
|||
my $what = "no"; |
|||
process_nfile($what,\%commands); |
|||
} |
|||
|
|||
} # end sub nfile |
|||
|
|||
# -n figure out --df, -d & -l using the contents db |
|||
sub process_nfile { |
|||
|
|||
my ($what,$commands) = @_; |
|||
my %commands = %$commands; |
|||
my $contentsdb = finddb(\%commands); |
|||
my ($arch,$dist) = which_archdist(\%commands); |
|||
my ($Contents,$subject); |
|||
|
|||
|
|||
# the + solution |
|||
nsb(\%commands); |
|||
$subject = (split(/\s/,$nsb{$argument}))[1]; |
|||
$argument =~ s,\+,\\\\+,g if $argument =~ m,\+,; |
|||
untie %nsb; |
|||
|
|||
if ($what eq "no") { |
|||
if (-e "$contentsdb/ncontentsindex$arch$dist.deb.gz") { |
|||
$Contents = "zgrep -E $argument\ $contentsdb/ncontentsindex$arch$dist.deb.gz|"; |
|||
} |
|||
else { |
|||
print "swim: stopping, cannot perform this operation without contents\n"; |
|||
exit; |
|||
} |
|||
} |
|||
elsif ($what eq "yes") { |
|||
if (-e "$contentsdb/dramdisk/ncontentsindex$arch$dist.deb.gz") { |
|||
$Contents = "zgrep -E $argument\ $contentsdb/dramdisk/ncontentsindex$arch$dist.deb.gz|"; |
|||
} |
|||
else { |
|||
print "swim: stopping, cannot perform this operation without contents\n"; |
|||
exit; |
|||
} |
|||
} |
|||
|
|||
|
|||
my($dirfile,$package,@dirfile,@comma,%all,%again); |
|||
open(CONTENTSDB, "$Contents"); |
|||
while (<CONTENTSDB>) { |
|||
# changed for >= 0.2.9 - will have to watch for these |
|||
# guys net/sendfile, x11/xscreensaver, x11/xscreensaver, |
|||
# graphics/ucbmpeg, admin/cfengine .. there is a space before them |
|||
#if (/^FILE\s*LOCATION$/) { |
|||
#while (<CONTENTSDB>) { |
|||
if (!$commands->{"df"}) { |
|||
# this isn't acurate for groups of packages ,,, so will use the |
|||
# subject section instead of \b and $ |
|||
$argument =~ s,\\\\+,\\\+,g if $argument =~ m,\+,; |
|||
if (m,$subject/$argument,) { |
|||
###################### |
|||
# DOESN'T END WITH / # |
|||
###################### |
|||
if ($_ !~ m,.*/\s+\w*,) { |
|||
($dirfile,$package) = split(/\s+/,$_,2); |
|||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) { |
|||
my @more_things = split(/\s+/,$package); |
|||
$package = $more_things[$#more_things]; |
|||
(my $backpackage = $package) =~ s,\+,\\+,g; |
|||
my @dirfile = split(/\s+$backpackage/,$_); |
|||
$dirfile = $dirfile[0]; |
|||
} |
|||
$dirfile = "/$dirfile"; |
|||
###### |
|||
# -L # |
|||
###### |
|||
if (!$commands->{"d"} && $commands->{"l"}) { |
|||
print "$dirfile\n"; |
|||
} |
|||
###### |
|||
# -D # |
|||
###### |
|||
elsif ($commands->{"d"}) { |
|||
if ($dirfile =~ m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/,) { |
|||
print "$dirfile\n"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
######## |
|||
# --DF # |
|||
######## |
|||
elsif ($commands->{"df"} && $commands->{"l"} && !$commands->{"d"}) { |
|||
$argument =~ s,\\\\+,\\\+,g if $argument =~ m,\+,; |
|||
if (m,$subject/$argument,) { |
|||
#if (m,\b$argument\b,) { |
|||
|
|||
###################### |
|||
# ENDS WITH / # |
|||
###################### |
|||
if (m,.*/\s+\w*,) { |
|||
($dirfile,$package) = split(/\s+/,$_,2); |
|||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) { |
|||
my @more_things = split(/\s+/,$package); |
|||
$package = $more_things[$#more_things]; |
|||
(my $backpackage = $package) =~ s,\+,\\+,g; |
|||
my @dirfile = split(/\s+$backpackage/,$_); |
|||
$dirfile = $dirfile[0]; |
|||
} |
|||
@dirfile = split(/\//,$dirfile); $dirfile =~ s,/$,,; |
|||
} |
|||
###################### |
|||
# DOESN'T END WITH / # |
|||
###################### |
|||
else { |
|||
($dirfile,$package) = split(/\s+/,$_,2); |
|||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) { |
|||
my @more_things = split(/\s+/,$package); |
|||
$package = $more_things[$#more_things]; |
|||
(my $backpackage = $package) =~ s,\+,\\+,g; |
|||
my @dirfile = split(/\s+$backpackage/,$_); |
|||
$dirfile = $dirfile[0]; |
|||
} |
|||
@dirfile = split(/\//,$dirfile); |
|||
} |
|||
########################### |
|||
# PROCESS INTO FILES/DIRS # |
|||
########################### |
|||
my ($count,$holder); |
|||
for ($count = 0; $count <= $#dirfile; $count++) { |
|||
if ($count == 0) { |
|||
$holder = "/$dirfile[$count]"; |
|||
my $again = "$dirfile[$count]"; |
|||
my $all = "/."; |
|||
$again{$again}++; |
|||
$all{$all}++; |
|||
if ($all{$all} == 1) { |
|||
print "/.\n"; |
|||
} |
|||
if ($again{$again} == 1) { |
|||
print "/$dirfile[$count]\n"; |
|||
} |
|||
} |
|||
else { |
|||
$holder = $holder . "/$dirfile[$count]"; |
|||
my $again = "$holder"; |
|||
$again{$again}++; |
|||
if ($again{$again} == 1) { |
|||
print "$holder\n"; |
|||
} |
|||
} |
|||
} # end for |
|||
} |
|||
} |
|||
################### |
|||
# -D & --DF &| -L # |
|||
################### |
|||
elsif (($commands->{"d"} && $commands->{"df"}) || |
|||
$commands->{"d"} && $commands->{"df"} && $commands->{"l"}) { |
|||
$argument =~ s,\\\\+,\\\+,g if $argument =~ m,\+,; |
|||
if (m,$subject/$argument,) { |
|||
#if (m,\b$argument$,) { |
|||
|
|||
###################### |
|||
# DOESN'T END WITH / # |
|||
###################### |
|||
if ($_ !~ m,.*/\s+\w*,) { |
|||
($dirfile,$package) = split(/\s+/,$_,2); |
|||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) { |
|||
my @more_things = split(/\s+/,$package); |
|||
$package = $more_things[$#more_things]; |
|||
(my $backpackage = $package) =~ s,\+,\\+,g; |
|||
my @dirfile = split(/\s+$backpackage/,$_); |
|||
$dirfile = $dirfile[0]; |
|||
} |
|||
$dirfile = "/$dirfile"; |
|||
###### |
|||
# -D # |
|||
###### |
|||
if ($dirfile =~ m,/usr/doc/|/usr/share/doc/|/man[\d]/|/usr/info/|/usr/share/info/,) { |
|||
print "$dirfile\n"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
#} |
|||
#} |
|||
} # while |
|||
close(CONTENTSDB); |
|||
|
|||
} |
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,358 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Findex; |
|||
use strict; |
|||
use SWIM::Global; |
|||
use SWIM::Conf qw($my_number); |
|||
use SWIM::DB_Library qw(:Xyz ib nib nsb); |
|||
use SWIM::Info; |
|||
use SWIM::Deps; |
|||
use SWIM::Dir; |
|||
use vars qw(@ISA @EXPORT_OK); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT_OK = qw(findexer qindexer); |
|||
|
|||
|
|||
# findexer(\%commands) and qindexer used for -a -n -f |
|||
|
|||
# query filelist for file name.. -qfl -qal, but not -qfl(d)c ... actually |
|||
# yes... -qlfd under certain conditions, but not with -c. And -T and |
|||
# singular capabilities. |
|||
sub findexer { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
my @alot; |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
|
|||
|
|||
if (!$commands->{"n"}) { |
|||
ib(\%commands); |
|||
} |
|||
else { |
|||
my $return = nib(\%commands); |
|||
if (!defined $return && $commands->{"a"}) { |
|||
untie %ib; |
|||
nsb(\%commands); |
|||
$ib{"/."} = $nsb{"/."}; |
|||
} |
|||
} |
|||
|
|||
if (defined $argument) { |
|||
if ($commands->{"dir"}) { |
|||
dir(\%commands); |
|||
} |
|||
elsif ($commands->{"f"}) { |
|||
fir(\%commands); |
|||
} |
|||
if ($ib{"$argument"}){ |
|||
my $package = $ib{"$argument"}; |
|||
@alot = split(/\s/, $package); |
|||
@PACKAGES = @alot; |
|||
if ($commands->{"z"} || $commands->{"ftp"} || |
|||
$commands->{"remove"} || $commands->{"r"} || |
|||
$commands->{"purge"}) { |
|||
require SWIM::Safex; |
|||
SWIM::Safex->import(qw(safex)); |
|||
safex(\%commands); |
|||
} |
|||
@alot = @PACKAGES; |
|||
if ($commands->{"total"} || $commands->{"t"}) { |
|||
if ($commands->{"T"}) { |
|||
foreach (@alot) { |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
# nice to print package names before file listings |
|||
if (!$commands->{"i"} || !$commands->{"d"} || !$commands->{"c"}) { |
|||
print "$argument\n"; |
|||
} |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
file(\%commands); |
|||
print "\n"; |
|||
} |
|||
} # if -T |
|||
elsif (which_character(\%commands)) { |
|||
foreach (@alot) { |
|||
my %store_commands = %commands; |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
if (the_character(\%commands) ne "ok") { |
|||
print "$argument\n"; |
|||
} |
|||
if (defined s_character(\%commands)) {} |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
file(\%commands); |
|||
print "\n"; |
|||
%commands = %store_commands; |
|||
undef %store_commands; |
|||
} |
|||
} |
|||
# no -Ts. |
|||
foreach (@alot) { |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
if (defined $argument) { |
|||
print "\n" if $commands->{"l"}; |
|||
print "$argument\n"; |
|||
} |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
file(\%commands); |
|||
if ($commands->{"d"} && !$commands->{"T"} && !which_character(\%commands)) { |
|||
print "\n" if !$commands->{"l"}; |
|||
} |
|||
} # end not's |
|||
} # if -t |
|||
|
|||
|
|||
elsif ($#ARGV > $my_number) { |
|||
my $total = $#ARGV + 1; |
|||
print "use --total or -t to see all $total packages\n"; |
|||
exit; |
|||
} |
|||
elsif ($#alot > $my_number) { |
|||
my $total = $#alot + 1; |
|||
print "use --total or -t to see all $total packages\n"; |
|||
} |
|||
|
|||
else { |
|||
if ($commands->{"T"}) { |
|||
foreach (@alot) { |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
print "$argument\n"; |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
file(\%commands); |
|||
print "\n"; |
|||
} |
|||
} # end -T |
|||
elsif (which_character(\%commands)) { |
|||
foreach (@alot) { |
|||
my %store_commands = %commands; |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
if (the_character($argument) ne "ok") { |
|||
print "$argument\n"; |
|||
} |
|||
if (defined s_character(\%commands)) {} |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
file(\%commands); |
|||
print "\n"; |
|||
%commands = %store_commands; |
|||
undef %store_commands; |
|||
} |
|||
} # which_character |
|||
foreach (@alot) { |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
if (defined $argument) { |
|||
print "$argument\n"; |
|||
} |
|||
file(\%commands); |
|||
if ($commands->{"d"} && !$commands->{"T"} && !which_character(\%commands)) { |
|||
print "\n"; |
|||
} |
|||
} # end not's |
|||
} # else |
|||
} |
|||
else { |
|||
$argument =~ m,.*\/(.*$),; |
|||
if (defined $1) { |
|||
my $file = $1; |
|||
if (!$commands->{"n"} && -e "/usr/sbin/update-alternatives") { |
|||
my $it = "update-alternatives --display $1|"; |
|||
open (IT,"$it") or exit; |
|||
if (<IT> =~ /No alternatives/) { |
|||
print "file $file is not owned by any package\n"; |
|||
} |
|||
else { |
|||
my @LINES = <IT>; |
|||
print "For $argument ->\n"; |
|||
$LINES[0] =~ m,(/.*$),; $argument = $1; |
|||
print "@LINES\n"; findexer(\%commands); |
|||
} |
|||
} |
|||
else { |
|||
print "file $file is not owned by any package\n"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
untie %ib; |
|||
|
|||
if (!($commands->{"z"} || $commands->{"ftp"} || |
|||
$commands->{"remove"} || $commands->{"r"} || |
|||
$commands->{"purge"})) { |
|||
if ($commands->{"x"} || $commands->{"ftp"} || $commands->{"source"} || |
|||
$commands->{"source_only"} || $commands->{"remove"} || |
|||
$commands->{"r"} || $commands->{"purge"}) { |
|||
require SWIM::Safex; |
|||
SWIM::Safex->import(qw(safex)); |
|||
safex(\%commands); |
|||
} |
|||
} |
|||
|
|||
} # end sub findexer |
|||
|
|||
|
|||
# query description of file name..-i (-qfi) |
|||
sub qindexer { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
require SWIM::Ag; |
|||
SWIM::Ag->import(qw(description)); |
|||
|
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
|
|||
my @alot; |
|||
|
|||
if (!$commands->{"n"}) { |
|||
ib(\%commands); |
|||
} |
|||
else { |
|||
my $return = nib(\%commands); |
|||
if (!defined $return && $commands->{"a"}) { |
|||
untie %ib; |
|||
nsb(\%commands); |
|||
$ib{"/."} = $nsb{"/."}; |
|||
} |
|||
} |
|||
|
|||
if (defined $argument) { |
|||
dir(\%commands); |
|||
fir(\%commands); |
|||
|
|||
# this will be moved above for safex(\%commands) |
|||
if ($ib{"$argument"}){ |
|||
my $package = $ib{"$argument"}; |
|||
@alot = split(/\s/, $package); |
|||
@PACKAGES = @alot; |
|||
if ($commands->{"z"} || $commands->{"ftp"} || |
|||
$commands->{"remove"} || $commands->{"r"} || |
|||
$commands->{"purge"}) { |
|||
require SWIM::Safex; |
|||
SWIM::Safex->import(qw(safex)); |
|||
safex(\%commands); |
|||
} |
|||
@alot = @PACKAGES; |
|||
if ($commands->{"total"} || $commands->{"t"}) { |
|||
foreach (@alot) { |
|||
$argument = $_; |
|||
description(\%commands); |
|||
print "\n"; |
|||
} |
|||
} |
|||
elsif ($#ARGV > 0) { |
|||
my $total = $#ARGV + 1; |
|||
print "use --total or -t to see all $total packages\n"; |
|||
exit; |
|||
} |
|||
elsif ($#alot > 0) { |
|||
my $total = $#alot + 1; |
|||
print "use --total or -t to see all $total packages\n"; |
|||
} |
|||
else { |
|||
$argument = $package; |
|||
description(\%commands); |
|||
} |
|||
} |
|||
else { |
|||
$argument =~ m,.*\/(.*$),; |
|||
if (defined $1) { |
|||
my $file = $1; |
|||
if (!$commands->{"n"} && -e "/usr/sbin/update-alternatives") { |
|||
my $it = "update-alternatives --display $1|"; |
|||
open (IT,"$it") or exit; |
|||
if (<IT> =~ /No alternatives/) { |
|||
print "file $file is not owned by any package\n"; |
|||
} |
|||
else { |
|||
my @LINES = <IT>; |
|||
print "For $argument ->\n"; |
|||
$LINES[0] =~ m,(/.*$),; $argument = $1; |
|||
print "@LINES\n"; qindexer(\%commands); |
|||
} |
|||
} |
|||
else { |
|||
print "file $file is not owned by any package\n"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
untie %ib; |
|||
|
|||
|
|||
|
|||
} # end sub qindexer |
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,62 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Format; |
|||
use vars qw(@ISA @EXPORT); |
|||
|
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(*PRETTY *ALLGROUPS *SUBJECT *CENTER *SDS $col1 $col2 $ag1 |
|||
$ag2 $ag3 $number $subsite $subdate $subsize $subrelease |
|||
$center $number $sdsite $sdsdate $sdsize $sdsrelease); |
|||
|
|||
|
|||
# A nice format to make things look prettier, hopefully. |
|||
format PRETTY = |
|||
@<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< |
|||
$col1, $col2 |
|||
. |
|||
|
|||
# A format for --allgroups, shouldn't run out of room. |
|||
format ALLGROUPS = |
|||
@<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<< @<<<<<<<<<<<<<<<<<<<<<<<< |
|||
$ag1, $ag2, $ag3 |
|||
. |
|||
|
|||
# center for DF|APT call |
|||
format SUBJECT = |
|||
@|| @||| @||| @||||||||||| @|||||| |
|||
$number, $subsite, $subdate, $subsize, $subrelease |
|||
|
|||
. |
|||
|
|||
|
|||
format CENTER = |
|||
@||||||||||||||||||||||| |
|||
$center |
|||
. |
|||
|
|||
|
|||
format SDS = |
|||
@>> @||||||||||||||||||||| @||||||||||||||||||||||||||| @|||||||| @||||| |
|||
$number, $sdsite, $sdsdate, $sdsize, $sdsrelease |
|||
. |
|||
|
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,62 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Global; |
|||
#use strict; |
|||
use vars qw(@ISA @EXPORT %EXPORT_TAGS); |
|||
|
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(%db $ping %ndb %ib $zing %gb $ging %sb $sing %nsb %commands |
|||
$argument $save @stuff @PACKAGES @arg_holder $file_now |
|||
$arg_count $aptor_count $aptor_group $swim_version); |
|||
%EXPORT_TAGS = ( |
|||
Info => [ qw($argument %db) ] |
|||
); |
|||
|
|||
=pod |
|||
|
|||
Globals used by all program, which are not related to SWIM::Conf globals. |
|||
Most will probably be placed in SWIM::DB_Library. |
|||
|
|||
=cut |
|||
# Nothing to be done here. |
|||
# these could be put into SWIM::DB_Library |
|||
my (%db,$ping); # package.deb |
|||
my %ndb; # npackage.deb |
|||
my (%ib, $zing, %it); # fileindex.deb |
|||
my (%gb, $ging); # groupindex.deb |
|||
my (%sb, $sing); # statusindex.deb |
|||
my %nsb; # nstatusindex.deb |
|||
my %commands; # standard for Getopt::Long, but should usually |
|||
# be passed from ::*, although it can be global to a module |
|||
my $argument; # standard for package name |
|||
my $save; #for pager |
|||
|
|||
# Globals related to -xyz |
|||
my @stuff; # for -g & x |
|||
my @PACKAGES; # a replacement for @ARGV |
|||
my @arg_holder; # helps in tricky situations -> -qxl|d |
|||
my $file_now; # defined flag for -qlcx & -qglx for file() |
|||
$arg_count = 0; # helps in tricky situations |
|||
my $aptor_group; # helps when -z is called for groups |
|||
|
|||
# Swim's version |
|||
$swim_version = "0.3.6"; |
|||
|
|||
1; |
|||
@ -0,0 +1,73 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Groups; |
|||
use strict; |
|||
use SWIM::DB_Library qw(:Groups); |
|||
use SWIM::Format; |
|||
use SWIM::Global qw(%gb); |
|||
use vars qw(@ISA @EXPORT); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(allgroups); |
|||
|
|||
|
|||
# show all the groups present on this system and exit |
|||
sub allgroups { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
if (!($commands->{"q"} || $commands->{"query"}) && $commands->{"allgroups"}) { |
|||
print "swim: --allgroups may only be used during queries\n"; |
|||
exit; |
|||
} |
|||
if ($commands->{"q"} && $commands->{"allgroups"}) { |
|||
$~ = "ALLGROUPS"; |
|||
|
|||
if (!$commands->{"n"}) { |
|||
gb(\%commands); |
|||
} |
|||
else { |
|||
ngb(\%commands); |
|||
} |
|||
|
|||
my @complete = sort keys %gb; |
|||
my $three = 0; |
|||
while ($three <= $#complete) { |
|||
if (defined $complete[$three]) { |
|||
$ag1 = $complete[$three]; |
|||
} |
|||
if (defined $complete[$three + 1]) { |
|||
$ag2 = $complete[$three + 1]; |
|||
} |
|||
if (defined $complete[$three + 2]) { |
|||
$ag3 = $complete[$three + 2]; |
|||
} |
|||
write STDOUT; |
|||
$ag1 = ""; |
|||
$ag2 = ""; |
|||
$ag3 = ""; |
|||
$three = $three + 3; |
|||
} |
|||
exit; |
|||
} |
|||
} |
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,509 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Indexer; |
|||
use strict; |
|||
use SWIM::Global; |
|||
use SWIM::Conf qw($my_number); |
|||
use SWIM::DB_Library qw(:Xyz ib nib nsb); |
|||
use SWIM::Info; |
|||
use SWIM::Pn_print; |
|||
use SWIM::Deps; |
|||
use SWIM::Dir; |
|||
use vars qw(@ISA @EXPORT_OK); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT_OK = qw(indexer); |
|||
|
|||
|
|||
# The next few subs are provided to shorten indexer |
|||
# for -d or -l, but not -c when -T |
|||
sub T_indexer { |
|||
|
|||
my ($alot,$commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
foreach (@$alot) { |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
# looks o.k. |
|||
print "$argument\n"; |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
if ($commands->{"d"} && !$commands->{"c"}) { |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
file(\%commands); |
|||
} |
|||
print "\n"; |
|||
} |
|||
} # end sub T_indexer |
|||
|
|||
|
|||
sub which_character_indexer { |
|||
|
|||
my ($alot,$commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
foreach (@$alot) { |
|||
my %store_commands = %commands; |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
if (the_character(\%commands) ne "ok") { |
|||
print "$argument\n"; |
|||
} |
|||
if (defined s_character(\%commands)) {} |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
if ($commands->{"d"} && !$commands->{"c"}) { |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
file(\%commands); |
|||
} |
|||
print "\n"; |
|||
%commands = %store_commands; |
|||
undef %store_commands; |
|||
} |
|||
|
|||
} # end sub which_character_indexer |
|||
|
|||
sub noT_indexer { |
|||
|
|||
|
|||
my ($alot,$commands) = @_; |
|||
my %commands = %$commands; |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
|
|||
foreach (@$alot) { |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
if (defined $argument) { |
|||
# should be o.k., almost everything has documentation |
|||
print "$argument\n"; |
|||
} |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
file(\%commands); |
|||
if ($commands->{"d"} && !$commands->{"T"} && !which_character(\%commands)) { |
|||
print "\n"; |
|||
} |
|||
} |
|||
|
|||
} # end sub noT_indexer |
|||
|
|||
# different enough from noT_indexer, used when -c,-d,-l aren't called. |
|||
sub nonoT_indexer { |
|||
|
|||
my ($alot,$commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
foreach (@$alot) { |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
# package name will print out even if there is no script |
|||
# definitely useful here |
|||
singular(\%commands); |
|||
if ($commands->{"scripts"}) { |
|||
print "\n"; |
|||
} |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
} |
|||
|
|||
|
|||
} # end sub nonoT_indexer |
|||
|
|||
|
|||
# when -c is called with or without -l or -d. This sub got rather huge. |
|||
sub c_indexer { |
|||
|
|||
my ($alot,$commands) = @_; |
|||
my %commands = %$commands; |
|||
my $arg_save; |
|||
require SWIM::File; |
|||
SWIM::File->import(qw(file)); |
|||
|
|||
foreach (@$alot) { |
|||
$argument = $_; |
|||
if (conf(\%commands) ne 0) { |
|||
if ($commands->{"T"}) { |
|||
# covers first argument, but not the rest. |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
print "$argument\n"; |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
print conf(\%commands) if !$commands->{"md5sum"}; |
|||
file(\%commands); |
|||
#file(\%commands) if $commands->{"md5sum"}; |
|||
if (($commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"}))) { |
|||
print "\n"; |
|||
} |
|||
$arg_save = $argument; |
|||
} # end "T" |
|||
|
|||
elsif (which_character(\%commands)) { |
|||
my %store_commands = %commands; |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
if (the_character(\%commands) ne "ok") { |
|||
print "$argument\n"; |
|||
} |
|||
if (defined s_character(\%commands)) {} |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
print conf(\%commands) if !$commands->{"md5sum"}; |
|||
file(\%commands); |
|||
#file(\%commands) if $commands->{"md5sum"}; |
|||
if (($commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"}))) { |
|||
print "\n"; |
|||
} |
|||
%commands = %store_commands; |
|||
undef %store_commands; |
|||
$arg_save = $argument; |
|||
} |
|||
|
|||
# no Ts. |
|||
else { |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
print "$argument\n"; |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
print conf(\%commands) if !$commands->{"md5sum"}; |
|||
file(\%commands); |
|||
print "\n"; |
|||
} |
|||
$arg_save = $argument; |
|||
} # end if (conf(\%commands) |
|||
|
|||
# this spot here can determine whether or not -c overrides l&d |
|||
# in packages which don't have conf files. it's nicer to view |
|||
# everything. watch this..these are packages which don't have |
|||
# conf files |
|||
if ($commands->{"d"} || $commands->{"l"}) { |
|||
if (defined $arg_save) { |
|||
if ($argument ne $arg_save) { |
|||
#if (!defined $arg_save) { |
|||
if (conf(\%commands) ne 0) { |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
file(\%commands); |
|||
print "\n"; |
|||
} |
|||
|
|||
# no conf files |
|||
elsif (conf(\%commands) eq 0) { |
|||
if ($commands->{"T"}) { |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
print "$argument\n"; |
|||
character(\%commands); |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
file(\%commands) if $commands->{"md5sum"}; |
|||
print "\n"; |
|||
} # end "T" |
|||
|
|||
elsif (which_character(\%commands)) { |
|||
my %store_commands = %commands; |
|||
$argument = $_; |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
if (the_character(\%commands) ne "ok") { |
|||
print "$argument\n"; |
|||
} |
|||
if (defined s_character(\%commands)) {} |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
%commands = %store_commands; |
|||
undef %store_commands; |
|||
file(\%commands); |
|||
print "\n"; |
|||
} |
|||
|
|||
# no Ts. |
|||
else { |
|||
if ($commands->{"scripts"} || $commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"}) { |
|||
scripts(\%commands); |
|||
} |
|||
menu(\%commands) if $commands->{"menu"} || $commands->{"m"}; |
|||
copyright(\%commands) if $commands->{"copyright"}; |
|||
changelog(\%commands) if $commands->{"changelog"}; |
|||
singular(\%commands); |
|||
if ($commands->{"scripts"}) { |
|||
print "\n"; |
|||
} |
|||
shlibs(\%commands) if $commands->{"shlibs"}; |
|||
file(\%commands); |
|||
print "\n"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} # end if ($commands->{"d"} || |
|||
} # end foreach |
|||
|
|||
} # end sub c_indexer |
|||
|
|||
|
|||
# handles -qf by itself or with -l(-d)&-c or -d by itself, and -qa by itself |
|||
# or with -c with -d and/or -l ...essentially not -i. <file> is the |
|||
# argument And ofcourse -T or singular capabilities. |
|||
sub indexer { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
my @alot; |
|||
|
|||
|
|||
if (!$commands->{"n"}) { |
|||
ib(\%commands); |
|||
} |
|||
else { |
|||
my $return = nib(\%commands); |
|||
if (!defined $return && $commands->{"a"}) { |
|||
untie %ib; |
|||
nsb(\%commands); |
|||
$ib{"/."} = $nsb{"/."}; |
|||
} |
|||
} |
|||
|
|||
if (defined $argument) { |
|||
dir(\%commands); |
|||
fir(\%commands); |
|||
if ($ib{"$argument"}){ |
|||
my $package = $ib{"$argument"}; |
|||
$package =~ s/\s/\n/g; |
|||
@alot = split(/\s/, $package); |
|||
if (defined @alot) { |
|||
@PACKAGES = @alot; |
|||
} |
|||
if ($commands->{"z"} || $commands->{"ftp"}|| |
|||
$commands->{"remove"} || $commands->{"r"} || |
|||
$commands->{"purge"}) { |
|||
require SWIM::Safex; |
|||
SWIM::Safex->import(qw(safex)); |
|||
safex(\%commands); |
|||
} |
|||
|
|||
|
|||
@alot = @PACKAGES; |
|||
if ($commands->{"total"} || $commands->{"t"}) { |
|||
# The whole reason for the complicated if/elsif/else routines |
|||
# below is to allow simultaneous printing of -c & -d|-l. Other |
|||
# options can just be included within. |
|||
|
|||
########### |
|||
# -D & -t # |
|||
########### |
|||
if ($commands->{"d"} && !$commands->{"c"}) { |
|||
if ($commands->{"T"}) { |
|||
T_indexer(\@alot,\%commands); |
|||
} |
|||
elsif (which_character(\%commands)) { |
|||
which_character_indexer(\@alot,\%commands); |
|||
} |
|||
# no -Ts. |
|||
noT_indexer(\@alot,\%commands); |
|||
} |
|||
|
|||
####################### |
|||
# -t BUT NOT -C,-D,-L # |
|||
####################### |
|||
elsif (!$commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"})) { |
|||
if ($commands->{"T"}) { |
|||
T_indexer(\@alot,\%commands); |
|||
} |
|||
elsif (which_character(\%commands)) { |
|||
which_character_indexer(\@alot,\%commands); |
|||
} |
|||
# humm smail is missing mysteriously, like it never became part |
|||
# of /.., basically, fastswim isn't placing it in long.debian. |
|||
# no -Ts. |
|||
else { |
|||
nonoT_indexer(\@alot,\%commands); |
|||
} |
|||
} |
|||
|
|||
##################### |
|||
# -t -C &| -D || -L # |
|||
##################### |
|||
# conf stuf. Will only show stuff related to -a or -f with conf. |
|||
elsif (($commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"})) || |
|||
($commands->{"c"} && ($commands->{"d"} || $commands->{"l"}))) { |
|||
c_indexer(\@alot,\%commands); |
|||
} # end elsif |
|||
} |
|||
|
|||
######################### |
|||
# > NUMBER FOR -t # |
|||
########################## |
|||
elsif ($#ARGV > $my_number) { |
|||
my $total = $#ARGV + 1; |
|||
print "use --total or -t to see all $total packages\n"; |
|||
exit; |
|||
} |
|||
elsif ($#alot > $my_number) { |
|||
my $total = $#alot + 1; |
|||
print "use --total or -t to see all $total packages\n"; |
|||
} |
|||
|
|||
# without -t |
|||
else { |
|||
|
|||
###### |
|||
# -D # |
|||
###### |
|||
if ($commands->{"d"} && !$commands->{"c"}) { |
|||
if ($commands->{"T"}) { |
|||
T_indexer(\@alot,\%commands); |
|||
} |
|||
elsif (which_character(\%commands)) { |
|||
which_character_indexer(\@alot,\%commands); |
|||
} |
|||
# the noties |
|||
noT_indexer(\@alot,\%commands); |
|||
} |
|||
|
|||
################ |
|||
# NOT -C,-D,-L # |
|||
################ |
|||
elsif (!$commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"})) { |
|||
if ($commands->{"T"}) { |
|||
T_indexer(\@alot,\%commands); |
|||
} |
|||
elsif (which_character(\%commands)) { |
|||
which_character_indexer(\@alot,\%commands); |
|||
} |
|||
else { |
|||
nonoT_indexer(\@alot,\%commands); |
|||
} |
|||
} |
|||
|
|||
|
|||
################## |
|||
# -C &| -D || -L # |
|||
################## |
|||
# conf stuf. Will only show stuff related to -a or -f with conf. |
|||
elsif (($commands->{"c"} && (!$commands->{"d"} || !$commands->{"l"})) || |
|||
($commands->{"c"} && ($commands->{"d"} || $commands->{"l"}))) { |
|||
c_indexer(\@alot,\%commands); |
|||
} |
|||
|
|||
} # without -t |
|||
} |
|||
else { |
|||
$argument =~ m,.*\/(.*$),; |
|||
if (defined $1) { |
|||
my $file = $1; |
|||
if (!$commands->{"n"} && -e "/usr/sbin/update-alternatives") { |
|||
my $it = "update-alternatives --display $1|"; |
|||
open (IT,"$it") or exit; |
|||
if (<IT> =~ /No alternatives/) { |
|||
print "file $file is not owned by any package\n"; |
|||
} |
|||
else { |
|||
my @LINES = <IT>; |
|||
print "For $argument ->\n"; |
|||
$LINES[0] =~ m,(/.*$),; $argument = $1; |
|||
print "@LINES\n"; indexer(\%commands); |
|||
} |
|||
} |
|||
else { |
|||
print "file $file is not owned by any package\n"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
untie %ib; |
|||
|
|||
if (defined @alot) { |
|||
@PACKAGES = @alot; |
|||
} |
|||
if (!($commands->{"z"} || $commands->{"ftp"} || |
|||
$commands->{"remove"} || $commands->{"r"} || |
|||
$commands->{"purge"})) { |
|||
if ($commands->{"x"} || $commands->{"ftp"} || $commands->{"source"} || |
|||
$commands->{"source_only"} || $commands->{"remove"} || |
|||
$commands->{"r"} || $commands->{"purge"}) { |
|||
require SWIM::Safex; |
|||
SWIM::Safex->import(qw(safex)); |
|||
safex(\%commands); |
|||
} |
|||
} |
|||
|
|||
} # end sub indexer |
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,586 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Info; |
|||
use strict; |
|||
use SWIM::Conf qw(:Info); |
|||
use SWIM::Global qw(:Info); |
|||
use SWIM::DB_Library qw(:Xyz); |
|||
use vars qw(@ISA @EXPORT); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(scripts copyright changelog menu conf shlibs); |
|||
|
|||
# scripts() copyright() changelog() menu() conf() shlibs() |
|||
# the text stuff taken out of info for the installed system, though the |
|||
# not-installed system in checked for, just in case. |
|||
|
|||
# This shows all the scripts identified with a package(s). In certain |
|||
# cases it is valuable to print a script without the name of the package, |
|||
# so if --scripts, -a, or -t isn't called, the pure script will be |
|||
# presented. |
|||
sub scripts { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my ($file, $preinst, $postinst, $prerm, |
|||
$postrm, $orig_argument); |
|||
|
|||
|
|||
if ($commands->{"n"}) { |
|||
print "swim: no scripts for not-installed, consider --diff\n"; exit; |
|||
} |
|||
|
|||
dbi(\%commands); |
|||
|
|||
if ($argument =~ /_/) { |
|||
$orig_argument = $argument; |
|||
my $check = $db{"$argument"}; |
|||
$argument =~ m,(^.*)_(.*$),; |
|||
if (defined $check) { |
|||
$argument = $1; |
|||
} |
|||
else {}; |
|||
} |
|||
untie %db; |
|||
|
|||
|
|||
# here we will print out whatever we find including the file name. |
|||
if ($commands->{"scripts"} && !($commands->{"preinst"} || |
|||
$commands->{"postinst"} || $commands->{"prerm"} || |
|||
$commands->{"postrm"})) { |
|||
if (defined "$parent$base/info/$argument.preinst") { |
|||
$preinst = "$parent$base/info/$argument.preinst"; |
|||
} |
|||
if (defined "$parent$base/info/$argument.postinst") { |
|||
$postinst = "$parent$base/info/$argument.postinst"; |
|||
} |
|||
if (defined "$parent$base/info/$argument.prerm") { |
|||
$prerm = "$parent$base/info/$argument.prerm"; |
|||
} |
|||
if (defined "$parent$base/info/$argument.postrm") { |
|||
$postrm = "$parent$base/info/$argument.postrm"; |
|||
} |
|||
|
|||
if (-e $preinst) { |
|||
print "#####$argument.preinst#####\n\n"; |
|||
open (LIST,"$preinst"); |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
if (-e $postinst) { |
|||
print "#####$argument.postinst#####\n\n"; |
|||
open (LIST,"$postinst"); |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
if (-e $prerm) { |
|||
open (LIST,"$prerm"); |
|||
print "#####$argument.prerm#####\n\n"; |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
if (-e $postrm) { |
|||
open (LIST,"$postrm"); |
|||
print "#####$argument.postrm#####\n\n"; |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
} # if scripts |
|||
|
|||
|
|||
# from here on we just print out the particular script(s) called |
|||
# literally with no filename, unless -a or -t is called. This is one |
|||
# situation in which -t has a use apart from the global default. A |
|||
|
|||
# title is printed out for singular scripts in this case. |
|||
|
|||
if ($commands->{"preinst"}) { |
|||
if (defined "$parent$base/info/$argument.preinst") { |
|||
$preinst = "$parent$base/info/$argument.preinst"; |
|||
} |
|||
if (-e $preinst) { |
|||
if ($commands->{"a"} || $commands->{"t"}) { |
|||
print "#####$argument.preinst#####\n\n"; |
|||
open (LIST,"$preinst"); |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
else { |
|||
open (LIST,"$preinst"); |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
|
|||
if ($commands->{"postinst"}) { |
|||
if (defined "$parent$base/info/$argument.postinst") { |
|||
$postinst = "$parent$base/info/$argument.postinst"; |
|||
} |
|||
if (-e $postinst) { |
|||
if ($commands->{"a"} || $commands->{"t"}) { |
|||
print "#####$argument.postinst#####\n\n"; |
|||
open (LIST,"$postinst"); |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
else { |
|||
open (LIST,"$postinst"); |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
|
|||
if ($commands->{"prerm"}) { |
|||
if (defined "$parent$base/info/$argument.prerm") { |
|||
$prerm = "$parent$base/info/$argument.prerm"; |
|||
} |
|||
if (-e $prerm) { |
|||
if ($commands->{"a"} || $commands->{"t"}) { |
|||
print "#####$argument.prerm#####\n\n"; |
|||
open (LIST,"$prerm"); |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
else { |
|||
open (LIST,"$prerm"); |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
|
|||
if ($commands->{"postrm"}) { |
|||
if (defined "$parent$base/info/$argument.postrm") { |
|||
$postrm = "$parent$base/info/$argument.postrm"; |
|||
} |
|||
if (-e $postrm) { |
|||
if ($commands->{"a"} || $commands->{"t"}) { |
|||
print "#####$argument.postrm#####\n\n"; |
|||
open (LIST,"$postrm"); |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
else { |
|||
open (LIST,"$postrm"); |
|||
while (<LIST>) { |
|||
print $_; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
|
|||
if (!$commands->{"i"}) { |
|||
if (defined $orig_argument) { |
|||
$argument = $orig_argument; |
|||
} |
|||
} |
|||
|
|||
} # end sub scripts |
|||
|
|||
# show the scripts for /usr/lib/menu |
|||
sub menu { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my $filelist; |
|||
my $orig_argument = $argument; |
|||
my %parent; |
|||
|
|||
if ($commands->{"n"}) { |
|||
print "swim: no menu for not-installed, consider --diff\n"; exit; |
|||
} |
|||
|
|||
dbi(\%commands); |
|||
|
|||
|
|||
if ($argument =~ /_/) { |
|||
$orig_argument = $argument; |
|||
my $check = $db{"$argument"}; |
|||
$argument =~ m,(^.*)_(.*$),; |
|||
if (defined $check) { |
|||
$argument = $1; |
|||
} |
|||
else {}; |
|||
} |
|||
untie %db; |
|||
|
|||
if (defined $argument) { |
|||
if (-e "$parent$base/info/$argument.list") { |
|||
$filelist = "$parent$base/info/$argument.list"; |
|||
} |
|||
if (defined $filelist) { |
|||
# basically, re-find file/package passed to previous sub |
|||
open(FINDMENU,"$filelist"); |
|||
while (<FINDMENU>) { |
|||
chomp; |
|||
if (m,^\/usr\/lib\/menu\/(.*(\w-\+\.)),) { |
|||
if (!-d) { |
|||
print "#####menu for $orig_argument($1)#####\n"; |
|||
open(MENU,"$_"); |
|||
while (<MENU>) { |
|||
print; |
|||
} |
|||
print "\n"; |
|||
} |
|||
} |
|||
} |
|||
close(FINDMENU); |
|||
close(MENU); |
|||
} |
|||
} # defined |
|||
|
|||
if (!$commands->{"i"}) { |
|||
$argument = $orig_argument; |
|||
} |
|||
|
|||
} # end sub menu |
|||
|
|||
|
|||
# Show changelog, default zcat. This will show all the changelogs in |
|||
# the directory /usr/doc/package_name/, there are cases where there is |
|||
# a debian.changelog and one provided by the individual(s) working on the |
|||
# software, as well as a variety of other cases. |
|||
sub changelog { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my $file; |
|||
my $orig_argument = $argument; |
|||
|
|||
if ($commands->{"n"}) { |
|||
print "swim: no changelog for not-installed, consider --diff\n"; exit; |
|||
} |
|||
|
|||
dbi(\%commands); |
|||
|
|||
if ($argument =~ /_/) { |
|||
$orig_argument = $argument; |
|||
my $check = $db{"$argument"}; |
|||
$argument =~ m,(^.*)_(.*$),; |
|||
if (defined $check) { |
|||
$argument = $1; |
|||
} |
|||
else {}; |
|||
} |
|||
untie %db; |
|||
|
|||
|
|||
# Using swim -qadt | grep -i change it looks like all the files which |
|||
# have change in their name are changelogs when in /usr/doc/$argument, |
|||
# sometimes there are more above, but these are the most significant. |
|||
my @fsstnd; |
|||
if (-e "$parent/usr/doc/$argument" && |
|||
-d "$parent/usr/doc/$argument") { |
|||
my $directory = "$parent/usr/doc/$argument"; |
|||
opendir(CHANGE, "$directory") || die "I thought it existed"; |
|||
my @change = sort grep(/change/i, readdir(CHANGE)); |
|||
closedir(CHANGE); |
|||
foreach (@change) { |
|||
if (m,\.gz$,i) { |
|||
push(@fsstnd,$_); |
|||
print "#####$_ for $argument#####\n\n"; |
|||
open(ZCAT,"|$zcat") || die "swim: this option requires zcat"; |
|||
open(CHANGELOG, "$directory/$_"); |
|||
while (<CHANGELOG>) { |
|||
print ZCAT $_; |
|||
} |
|||
close(ZCAT); |
|||
close(CHANGELOG); |
|||
print "\n"; |
|||
} |
|||
elsif ($_ !~ m,html$|htm$|ps$|dvi$|sgml$|gs$,) { |
|||
push(@fsstnd,$_); |
|||
print "#####$_ for $argument#####\n\n"; |
|||
open(CHANGELOG, "$directory/$_"); |
|||
while (<CHANGELOG>) { |
|||
print "$_"; |
|||
} |
|||
close(CHANGELOG); |
|||
print "\n"; |
|||
} |
|||
} |
|||
} |
|||
|
|||
if (-e "$parent/usr/share/doc/$argument" && |
|||
-d "$parent/usr/share/doc/$argument") { |
|||
my $directory = "$parent/usr/share/doc/$argument"; |
|||
opendir(CHANGE, "$directory") || die "I thought it existed"; |
|||
my @change = sort grep(/change/i, readdir(CHANGE)); |
|||
closedir(CHANGE); |
|||
foreach (@change) { |
|||
if (m,\.gz$,i) { |
|||
my $cf = grep(m,^$_$,,@fsstnd); |
|||
if ($cf == 0 ) { |
|||
print "#####$_ for $argument#####\n\n"; |
|||
open(ZCAT,"|$zcat") || die "swim: this option requires zcat"; |
|||
open(CHANGELOG, "$directory/$_"); |
|||
while (<CHANGELOG>) { |
|||
print ZCAT $_; |
|||
} |
|||
close(ZCAT); |
|||
close(CHANGELOG); |
|||
print "\n"; |
|||
} |
|||
} |
|||
elsif ($_ !~ m,html$|htm$|ps$|dvi$|sgml$|gs$,) { |
|||
my $cf = grep(m,^$_$,,@fsstnd); |
|||
if ($cf == 0 ) { |
|||
print "#####$_ for $argument#####\n\n"; |
|||
open(CHANGELOG, "$directory/$_"); |
|||
while (<CHANGELOG>) { |
|||
print "$_"; |
|||
} |
|||
close(CHANGELOG); |
|||
print "\n"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
|
|||
|
|||
if (!$commands->{"i"}) { |
|||
$argument = $orig_argument; |
|||
} |
|||
|
|||
} # end sub changelog |
|||
|
|||
# Show copyright, default zcat. This will show all the copyrights in |
|||
# the directory /usr/doc/package_name/. Rather than passing the |
|||
# greped argument to changelog(), this subroutine was created instead which |
|||
# keeps things sensible. |
|||
sub copyright { |
|||
|
|||
my $file; |
|||
my $orig_argument = $argument; |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
|
|||
if ($commands->{"n"}) { |
|||
print "swim: no copyright for not-installed, consider --diff\n"; exit; |
|||
} |
|||
|
|||
dbi(\%commands); |
|||
|
|||
|
|||
if ($argument =~ /_/) { |
|||
$orig_argument = $argument; |
|||
my $check = $db{"$argument"}; |
|||
$argument =~ m,(^.*)_(.*$),; |
|||
if (defined $check) { |
|||
$argument = $1; |
|||
} |
|||
else {}; |
|||
} |
|||
untie %db; |
|||
|
|||
|
|||
# Using swim -qadt | grep -i copy it looks like all the files which |
|||
# have copy in their name are generally copyrights when in |
|||
# /usr/doc/$argument, sometimes there are more above, but these are |
|||
# the most significant. |
|||
my @fsstnd; |
|||
if (-e "$parent/usr/doc/$argument" && |
|||
-d "$parent/usr/doc/$argument") { |
|||
my $directory = "$parent/usr/doc/$argument"; |
|||
opendir(CHANGE, "$directory") || die "I thought it existed"; |
|||
my @change = sort grep(/copy|license/i, readdir(CHANGE)); |
|||
closedir(CHANGE); |
|||
foreach (@change) { |
|||
if (defined $_) { |
|||
if (m,\.gz$,i) { |
|||
push(@fsstnd,$_); |
|||
print "#####$_ for $orig_argument#####\n\n"; |
|||
open(ZCAT,"|$zcat") || die "swim: this option requires zcat"; |
|||
open(COPYRIGHT, "$directory/$_"); |
|||
while (<COPYRIGHT>) { |
|||
print ZCAT $_; |
|||
} |
|||
# Sometimes these next two mysteriously open, and don't close |
|||
# even when no previous gz file was found, causing error output, |
|||
# but doesn't effect what's trying to be accomplished. Doesn't |
|||
# happen with changelog(). |
|||
close(ZCAT); |
|||
close(COPYRIGHT); |
|||
print "\n"; |
|||
} |
|||
elsif ($_ !~ m,html$|htm$|ps$|dvi$|sgml$|gs$,) { |
|||
push(@fsstnd,$_); |
|||
print "#####$_ for $orig_argument#####\n\n"; |
|||
open(COPYRIGHT, "$directory/$_"); |
|||
while (<COPYRIGHT>) { |
|||
print "$_"; |
|||
} |
|||
close(COPYRIGHT); |
|||
print "\n"; |
|||
} |
|||
} # if defined |
|||
} |
|||
} |
|||
|
|||
if (-e "$parent/usr/share/doc/$argument" && |
|||
-d "$parent/usr/share/doc/$argument") { |
|||
my $directory = "$parent/usr/share/doc/$argument"; |
|||
opendir(CHANGE, "$directory") || die "I thought it existed"; |
|||
my @change = sort grep(/copy|license/i, readdir(CHANGE)); |
|||
closedir(CHANGE); |
|||
foreach (@change) { |
|||
if (defined $_) { |
|||
if (m,\.gz$,i) { |
|||
my $cf = grep(m,^$_$,,@fsstnd); |
|||
if ($cf == 0 ) { |
|||
print "#####$_ for $orig_argument#####\n\n"; |
|||
open(ZCAT,"|$zcat") || die "swim: this option requires zcat"; |
|||
open(COPYRIGHT, "$directory/$_"); |
|||
while (<COPYRIGHT>) { |
|||
print ZCAT $_; |
|||
} |
|||
# Sometimes these next two mysteriously open, and don't close |
|||
# even when no previous gz file was found, causing error output, |
|||
# but doesn't effect what's trying to be accomplished. Doesn't |
|||
# happen with changelog(). |
|||
close(ZCAT); |
|||
close(COPYRIGHT); |
|||
print "\n"; |
|||
} |
|||
} |
|||
elsif ($_ !~ m,html$|htm$|ps$|dvi$|sgml$|gs$,) { |
|||
my $cf = grep(m,^$_$,,@fsstnd); |
|||
if ($cf == 0 ) { |
|||
print "#####$_ for $orig_argument#####\n\n"; |
|||
open(COPYRIGHT, "$directory/$_"); |
|||
while (<COPYRIGHT>) { |
|||
print "$_"; |
|||
} |
|||
close(COPYRIGHT); |
|||
print "\n"; |
|||
} |
|||
} |
|||
} # if defined |
|||
} |
|||
} |
|||
|
|||
if (!$commands->{"i"}) { |
|||
$argument = $orig_argument; |
|||
} |
|||
|
|||
} # end copyright |
|||
|
|||
# process the database for the configuration files |
|||
sub conf { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
# added for -xyz, but not necessary |
|||
if (defined $argument) { |
|||
if ($argument !~ /_/) { |
|||
if (defined $db{$argument}) { |
|||
$argument = $db{$argument}; |
|||
} |
|||
} |
|||
} |
|||
if (!$commands->{"n"}) { |
|||
dbi(\%commands); |
|||
} |
|||
else {} |
|||
if (defined $argument) { |
|||
my $conf = $argument . "CONF"; |
|||
if (defined $db{$conf}) { |
|||
return $db{$conf}; |
|||
} |
|||
else { return 0; } |
|||
} |
|||
untie %db; |
|||
} # end sub conf |
|||
|
|||
# shared libraries provided by the package |
|||
sub shlibs { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my $shlibs; |
|||
my $orig_argument; |
|||
|
|||
if ($commands->{"n"}) { |
|||
print "catswim: no shlibs for not-installed, consider --diff\n"; exit; |
|||
} |
|||
|
|||
|
|||
dbi(\%commands); |
|||
|
|||
if (defined $argument) { |
|||
if ($argument =~ /_/) { |
|||
$orig_argument = $argument; |
|||
my $check; |
|||
if (defined $db{"$argument"}) { |
|||
$check = $db{"$argument"}; |
|||
} |
|||
$argument =~ m,(^.*)_(.*$),; |
|||
if (defined $check) { |
|||
$argument = $1; |
|||
} |
|||
else {} |
|||
} |
|||
else { |
|||
$orig_argument = $argument; |
|||
} |
|||
} |
|||
untie %db; |
|||
|
|||
if (defined $argument) { |
|||
if (-e "$parent$base/info/$argument.shlibs") { |
|||
$shlibs = "$parent$base/info/$argument.shlibs"; |
|||
} |
|||
} |
|||
|
|||
if (defined $shlibs) { |
|||
print "Shlibs:\n"; |
|||
open(SHLIBS,"$shlibs"); |
|||
while (<SHLIBS>) { |
|||
if ($_ !~ m,^\n$,) { |
|||
print; |
|||
} |
|||
} |
|||
} |
|||
|
|||
$argument = $orig_argument; |
|||
|
|||
} # end sub shlibs |
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,144 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Library; |
|||
use strict; |
|||
use SWIM::Conf; |
|||
use SWIM::Global; |
|||
use vars qw(@ISA @EXPORT); |
|||
|
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(which_archdist finddb root compress_contents); |
|||
|
|||
|
|||
# functions which do not use DB_File which_archdist() finddb() root() |
|||
|
|||
# which archictecture and distribution does this database involve |
|||
sub which_archdist { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
my ($arch,$dist); |
|||
#if ($commands->{"initndb"} || $commands->{"rebuildndb"}) { |
|||
if ($commands->{"arch"}) { |
|||
$arch = "-" . $commands->{"arch"}; |
|||
} |
|||
else { |
|||
$arch = "-$architecture"; |
|||
} |
|||
|
|||
if ($commands->{"dists"}) { |
|||
$dist = "-" . $commands->{"dists"}; |
|||
} |
|||
else { |
|||
$dist = "-$distribution"; |
|||
} |
|||
return ($arch,$dist); |
|||
# } |
|||
|
|||
} # end sub which_archdist |
|||
|
|||
|
|||
# finding any database |
|||
sub finddb { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
my $fileplace; |
|||
|
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$fileplace = "$parent$library"; |
|||
return $fileplace; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$fileplace = "$parent$base"; |
|||
return $fileplace; |
|||
} |
|||
|
|||
} # end sub finddb |
|||
|
|||
# This gives the option to be able to used -d & -l, but not -f, by only |
|||
# copying Contents over to contentsindex*.deb.gz. This the fast way. |
|||
sub compress_contents { |
|||
|
|||
my ($Contents,$commands) = @_; |
|||
my %commands = %$commands; |
|||
my $contentsdb = finddb(\%commands); |
|||
my($arch,$dist) = which_archdist(\%commands); |
|||
my $contentsindex = "$contentsdb/ncontentsindex$arch$dist.deb"; |
|||
my ($contentsindexgz, $mtime); |
|||
if (-e "$contentsdb/ncontentsindex$arch$dist.deb.gz") { |
|||
$contentsindexgz = "$contentsdb/ncontentsindex$arch$dist.deb.gz"; |
|||
$mtime = (stat("$contentsindexgz"))[9]; |
|||
} |
|||
else { |
|||
$contentsindexgz = "$contentsdb/ncontentsindex$arch$dist.deb.gz"; |
|||
} |
|||
|
|||
my $ex; |
|||
my $Contents_mtime = (stat("$Contents"))[9]; |
|||
my $BContents = $Contents; |
|||
$Contents = -B $Contents || $Contents =~ m,\.(gz|Z)$, ? |
|||
"$gzip -dc $Contents|" : "cat $Contents|"; |
|||
if (defined $mtime) { |
|||
if ($mtime == $Contents_mtime) { |
|||
print "Same Contents files, won't compress\n"; |
|||
exit if !$commands->{"ndb"}; |
|||
$ex = "stop"; |
|||
} |
|||
else { |
|||
unlink($contentsindexgz); |
|||
} |
|||
} |
|||
if (!defined $ex) { |
|||
print "Copying new Contents\n"; |
|||
#system $copy, $BContents, $contentsindexgz; |
|||
|
|||
# changed for >= 0.2.9 |
|||
# changed again >= 0.3.4 |
|||
open(CONTENTS, "$Contents") or die "where is it?\n"; |
|||
open(CONTENTSDB,">$contentsindex"); |
|||
while (<CONTENTS>) { |
|||
##if (/^FILE\s*LOCATION$/) { |
|||
##while (<CONTENTS>) { |
|||
s,^(\./)+,,; # filter for Debians altered dir structure |
|||
print CONTENTSDB $_; |
|||
##} |
|||
##} |
|||
} |
|||
print "Compressing Contents\n"; |
|||
# added -f just in case |
|||
system "$gzip", "-f", "-9", "$contentsindex"; |
|||
utime(time,$Contents_mtime,$contentsindexgz); |
|||
} |
|||
|
|||
} # end sub compress_contents |
|||
|
|||
# for / files |
|||
sub root { |
|||
|
|||
if ($argument eq "/") { |
|||
$argument = "/."; |
|||
} |
|||
} # end sub root |
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,268 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::MD; |
|||
use strict; |
|||
use SWIM::Conf qw(:Path $splt); |
|||
use SWIM::DB_Library qw(:Md); |
|||
use SWIM::Library; |
|||
use SWIM::Global; |
|||
use vars qw(@ISA @EXPORT %EXPORT_TAGS); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(process_md); |
|||
|
|||
# process_md used by both SWIM::DB_Init and SWIM::NDB_Init |
|||
|
|||
=pod |
|||
|
|||
Because many files and directories exist more than once, and it would be |
|||
kind of cool to go up to a directory /usr/bin or /usr/bin/ and do a |
|||
swim -qf and see all the packages that populate that directory... |
|||
multi-dimensional is the way to go. |
|||
|
|||
=cut |
|||
|
|||
sub process_md { |
|||
|
|||
print "File Database is being made\n"; |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
my @ppackage; |
|||
my %md; |
|||
my @md; |
|||
my @mi; |
|||
my $thingy; |
|||
my @name; |
|||
my $count = 0; |
|||
my $count1 = 1; |
|||
|
|||
my($place) = finddb(\%commands); |
|||
|
|||
# Let's determine what architecture and distribution this person is |
|||
# interested in. |
|||
my ($arch, $dist, $not); |
|||
if ($commands->{"initndb"} || $commands->{"rebuildndb"}) { |
|||
($arch,$dist) = which_archdist(\%commands); |
|||
$not = "n"; |
|||
} |
|||
else { |
|||
$arch = ""; |
|||
$dist = ""; |
|||
$not = ""; |
|||
} |
|||
my $fileindex = $not . "fileindex"; |
|||
|
|||
|
|||
# Now we process the files made from the massive array, and create |
|||
# fileindex.deb or nfileindex.deb |
|||
# Let's just use split, and will allow for customized line adj. |
|||
# 25000 is the default |
|||
if ($commands->{"split_data"}) { |
|||
my $split = $commands->{"split_data"}; |
|||
system("$splt -l $split $tmp/big.debian $tmp/DEBIAN"); |
|||
} |
|||
else { |
|||
# Seems like a good default |
|||
system("$splt -l 25000 $tmp/big.debian $tmp/DEBIAN"); |
|||
} |
|||
@ppackage = <$tmp/DEBIAN*>; |
|||
# It's unlikely this file will ever get too massive. |
|||
push(@ppackage, "$tmp/long.debian"); |
|||
print " Create the database\n"; |
|||
foreach $thingy (@ppackage) { |
|||
open(PARTS, "$thingy"); |
|||
while (<PARTS>) { |
|||
my @c; |
|||
@md = split(/ -> /,$_); |
|||
if (defined($md[1])) { |
|||
chomp $md[0]; |
|||
chomp $md[1]; |
|||
@c = split(/\s/, $md[1]); |
|||
} |
|||
push(@mi,$md[0]); |
|||
push(@mi,$md[1]); |
|||
} # while |
|||
print " $thingy\n"; |
|||
print " wait a few seconds\n"; |
|||
my $zing; |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$zing = tie %md, 'DB_File',"$parent$library/$fileindex$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$zing = tie %md, 'DB_File',"$parent$base/$fileindex$arch$dist.deb" |
|||
or die "DB_File: $!"; |
|||
} |
|||
while ($count <= $#mi) { |
|||
$zing->put($mi[$count], $mi[$count1]); |
|||
$count = $count + 2; |
|||
$count1 = $count1 + 2; |
|||
} |
|||
undef $zing; |
|||
untie %md; |
|||
undef %md; |
|||
@mi = (); |
|||
@md = (); |
|||
$count = 0; |
|||
$count1 = 1; |
|||
close(PARTS); |
|||
} # end foreach |
|||
|
|||
# now we get to take into account deinstall:ok:config-files |
|||
# situations for an installed system. |
|||
if ($commands->{"initdb"} || $commands->{"rebuilddb"}) { |
|||
sb(\%$commands); ib(\%commands); my $yich; |
|||
foreach (values %sb) { |
|||
my $zit; my ($nit,$yit) = (split(/\s/,$_))[0,3]; |
|||
if ($yit eq "deinstall:ok:config-files" || |
|||
$yit eq "purge:ok:config-files") { |
|||
($zit = $nit) =~ s,\+,\\\+,; |
|||
if ($ib{"/."} !~ m,$zit,) { |
|||
if (!defined $yich) { |
|||
$yich = $nit; |
|||
} |
|||
else { |
|||
$yich = $yich . " $nit"; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
$ib{"/."} = $ib{"/."} . " $yich"; |
|||
} |
|||
|
|||
# after much experimentation it turns out that a flat text file |
|||
# is much faster for this particular application. This also |
|||
# creates the hash database reference for -db or -i. |
|||
my $searchindex = $not . "searchindex"; |
|||
open(FLATFILE, ">$place/$searchindex$arch$dist.deb"); |
|||
print "Create the powersearch flat database\n"; |
|||
foreach $thingy (@ppackage) { |
|||
if ($thingy ne "$tmp/long.debian") { |
|||
open(PARTS, "$thingy"); |
|||
while (<PARTS>) { |
|||
@md = split(/ -> /,$_); |
|||
if (defined($md[1])) { |
|||
chomp $md[0]; |
|||
} |
|||
push(@mi,$md[0]); |
|||
} # while |
|||
} |
|||
print " $thingy\n"; |
|||
print " wait a few seconds\n"; |
|||
while ($count <= $#mi) { |
|||
print FLATFILE "$mi[$count]\n"; |
|||
$count++; |
|||
} |
|||
$count = 0; |
|||
@mi = (); |
|||
@md = (); |
|||
close(PARTS); |
|||
} # end foreach |
|||
close(FLATFILE); |
|||
|
|||
# This creates the flatfile with the directories for --powersearch |
|||
# --dir, which is probably a rare match in most cases. This doesn't |
|||
# create a hash reference database for --db and -i because the only |
|||
# package which could benifit from this is base-files, but it has |
|||
# configuaration files, on the other hand RedHat has at least one |
|||
# package without directories or files, but this is Debian. |
|||
my $dirindex = $not . "dirindex"; |
|||
open(FLATFILE, ">$place/$dirindex$arch$dist.deb"); |
|||
print "Create the powersearch flat directory database\n"; |
|||
open(PARTS, "$ppackage[$#ppackage]"); |
|||
while (<PARTS>) { |
|||
@md = split(/ -> /,$_); |
|||
if (defined($md[1])) { |
|||
chomp $md[0]; |
|||
} |
|||
push(@mi,$md[0]); |
|||
} # while |
|||
print " $ppackage[$#ppackage]\n"; |
|||
while ($count <= $#mi) { |
|||
print FLATFILE "$mi[$count]\n"; |
|||
$count++; |
|||
} |
|||
$count = 0; |
|||
@mi = (); |
|||
@md = (); |
|||
close(PARTS); |
|||
close(FLATFILE); |
|||
|
|||
# compare nstatusindex*.deb to /. from nfileindex*.deb to find out if |
|||
# any of the packages in Packages weren't represented in the Contents |
|||
# file. This is different than the earlier report which shows packages |
|||
# which weren't in Packages but were in Contents. This list is kept, |
|||
# and used again in a future --ndb run to make the matches, if they |
|||
# exist. |
|||
if ($commands->{"initndb"} || $commands->{"rebuildndb"}) { |
|||
nsb(\%$commands); |
|||
nzing(\%commands); |
|||
my @fileindex = split(/\s/,$ib{"/."}); |
|||
my @statusindex = split(/\s/,$nsb{"/."}); |
|||
if ($#fileindex < $#statusindex) { |
|||
my $place = finddb(\%commands); |
|||
open(DIFF, ">$place/.packagesdiff$arch$dist.deb") |
|||
or warn "couldn't create diff file\n"; |
|||
my %uniques; |
|||
@uniques{@fileindex} = (); |
|||
foreach (@statusindex) { |
|||
# no sense putting non-US or experimental in here unless this |
|||
# is what is wanted. Only need to check for group non-us/* |
|||
if (!$commands->{"nue"}) { |
|||
my $name = (split(/_/,$_))[0]; |
|||
if (defined $nsb{$name}) { |
|||
next if (split(/\s/,$nsb{$name}))[1] =~ m,non-us,; |
|||
} |
|||
if ($dist eq "experimental") { |
|||
next; |
|||
} |
|||
} |
|||
elsif ($dist eq "experimental") { |
|||
if (!$commands->{"nue"}) { |
|||
my $name = (split(/_/,$_))[0]; |
|||
if (defined $nsb{$name}) { |
|||
next if (split(/\s/,$nsb{$name}))[1] =~ m,non-us,; |
|||
} |
|||
} |
|||
} |
|||
print DIFF "$_\n" unless exists $uniques{$_}; |
|||
} |
|||
$zing->del("/."); |
|||
$zing->put("/.",$nsb{"/."}); |
|||
} |
|||
} # end if |
|||
|
|||
# Will unlink transfer.deb, big.debian, long.debian. |
|||
unlink(<$tmp/DEBIAN*>); |
|||
unlink("$tmp/transfer.deb"); |
|||
unlink("$tmp/big.debian"); |
|||
unlink("$tmp/long.debian"); |
|||
|
|||
|
|||
#!!! |
|||
print " over and out\n"; |
|||
print scalar(localtime), "\n"; |
|||
|
|||
} # end sub process_md |
|||
|
|||
|
|||
1; |
|||
File diff suppressed because it is too large
@ -0,0 +1,251 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
package SWIM::NDB_File; |
|||
use strict; |
|||
use SWIM::DB_Library qw(ram_on); # nzing nsb |
|||
use SWIM::Library; |
|||
use SWIM::Global qw($argument); # %ib $zing %nsb |
|||
use SWIM::Conf qw($pwd $tmp); |
|||
use SWIM::Dir; |
|||
use SWIM::Ramdisk; |
|||
use vars qw(@ISA @EXPORT); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(noram ncontents_exist find_contents remove_add_nfile); |
|||
|
|||
# This program handles updating nfileindex-arch-dists.deb |
|||
|
|||
# This checks if the ramdisk is on, we will want to turn it off, if it is. |
|||
sub noram { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
my $ramdisk = ram_on(\%commands); |
|||
|
|||
if ($ramdisk eq "yes") { |
|||
my $what = "yes"; |
|||
$commands{"ramdiskoff"} = 1; |
|||
ramdisk(\%commands); |
|||
} # if ramdisk |
|||
|
|||
} # end sub nfile |
|||
|
|||
# This will set-up the argument for ncontents if it can be found. |
|||
sub ncontents_exist { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
my $contentsdb = finddb(\%commands); |
|||
my ($arch,$dist) = which_archdist(\%commands); |
|||
|
|||
|
|||
if (-e "$contentsdb/ncontentsindex$arch$dist.deb.gz") { |
|||
if (-e "$contentsdb/ndirindex$arch$dist.deb.gz") { |
|||
unlink("$contentsdb/ndirindex$arch$dist.deb.gz"); |
|||
} |
|||
if (-e "$contentsdb/nsearchindex$arch$dist.deb.gz") { |
|||
unlink("$contentsdb/nsearchindex$arch$dist.deb.gz"); |
|||
} |
|||
return " $contentsdb/ncontentsindex$arch$dist.deb.gz|"; |
|||
} |
|||
else { |
|||
return "no"; |
|||
} |
|||
|
|||
} # end sub ncontents_exist |
|||
|
|||
# Find where the new Contents is on the on the command line vs the old |
|||
# Contents database (when the FDB argument isn't used). |
|||
sub find_contents { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
############ |
|||
# CONTENTS # |
|||
############ |
|||
# Figure out where Contents is |
|||
if ($commands->{"Contents"}) { |
|||
my ($Contents,$FDB); |
|||
for ($commands->{"Contents"}) { |
|||
|
|||
############### |
|||
# SITUATION 0 # |
|||
############### |
|||
# this doesn't work to well for anything less simple than ../../ |
|||
if (m,^\.\./|^\.\.$,) { |
|||
if ($_ !~ m,/[\w-+]+/[\.\$\^\+\?\*\[\]\w-]*$,) { |
|||
my $dd; tr/\/// ? ($dd = tr/\///) : ($dd = 1); |
|||
my @pwd = split(m,/,,$pwd); |
|||
s,\.\./,,g; |
|||
my $tpwd = ""; |
|||
for (1 .. $#pwd - $dd) { |
|||
$_ == 1 ? ($tpwd = "/$pwd[$_]") |
|||
: (x$tpwd = $tpwd . "/$pwd[$_]"); |
|||
} |
|||
$_ ne ".." ? ($Contents = "$tpwd/$_") : ($Contents = "$tpwd/"); |
|||
} |
|||
dir(\%commands); |
|||
fir(\%commands); |
|||
} |
|||
|
|||
############### |
|||
# SITUATION I # |
|||
############### |
|||
elsif ( m,\/,) { |
|||
$Contents = $_; |
|||
if ($Contents =~ m,^\.\/.*,) { |
|||
if ($pwd !~ m,^\/$,) { |
|||
$Contents =~ m,^\.([^\.].*$),; |
|||
$Contents = "$pwd$1"; |
|||
} |
|||
else { |
|||
$Contents =~ m,^\.([^\.].*$),; |
|||
$Contents = "$1"; |
|||
} |
|||
} |
|||
dir(\%commands); |
|||
fir(\%commands); |
|||
} |
|||
|
|||
################ |
|||
# SITUATION II # |
|||
################ |
|||
elsif ($pwd =~ m,^\/$,) { |
|||
$Contents = "/$_"; |
|||
dir(\%commands); |
|||
fir(\%commands); |
|||
} |
|||
|
|||
################# |
|||
# SITUATION III # |
|||
################# |
|||
else { |
|||
$Contents = "$pwd/$_"; |
|||
if ($Contents =~ m,\.$,) { |
|||
$Contents =~ m,(.*)\.$,; |
|||
$Contents = $1; |
|||
} |
|||
dir(\%commands); |
|||
fir(\%commands); |
|||
} |
|||
} |
|||
|
|||
return $Contents; |
|||
|
|||
} # if Contents |
|||
|
|||
} # end sub find_contents |
|||
|
|||
# figure out --df and remove from nfileindex-arch-dists.deb |
|||
sub remove_add_nfile { |
|||
|
|||
my ($argument,$Contents,$subject,$commands) = @_; |
|||
my %commands = %$commands; |
|||
#my $contentsdb = finddb(\%commands); |
|||
#my ($arch,$dist) = which_archdist(\%commands); |
|||
##nzing(\%commands); |
|||
|
|||
# the + solution |
|||
$argument =~ s,\+,\\\\+,g if $argument =~ m,\+,; |
|||
$Contents = "zgrep -E $argument\ $Contents"; |
|||
|
|||
my($dirfile,$package,@dirfile,%all,%again, |
|||
@package_match,@more_things,@file); |
|||
open(CONTENTSDB, "$Contents"); |
|||
while (<CONTENTSDB>) { |
|||
# changed for >= 0.2.9 |
|||
#if (/^FILE\s*LOCATION$/) { |
|||
#while (<CONTENTSDB>) { |
|||
######## |
|||
# --DF # |
|||
######## |
|||
$argument =~ s,\\\\+,\\\+,g if $argument =~ m,\+,; |
|||
if (m,$subject/$argument,) { |
|||
#if (m,\b$argument\b,) { |
|||
|
|||
###################### |
|||
# ENDS WITH / # |
|||
###################### |
|||
if (m,.*/\s+\w*,) { |
|||
($dirfile,$package) = split(/\s+/,$_,2); |
|||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) { |
|||
my @more_things = split(/\s+/,$package); |
|||
$package = $more_things[$#more_things]; |
|||
(my $backpackage = $package) =~ s,\+,\\+,g; |
|||
my @dirfile = split(/\s+$backpackage/,$_); |
|||
$dirfile = $dirfile[0]; |
|||
} |
|||
@dirfile = split(/\//,$dirfile); $dirfile =~ s,/$,,; |
|||
} |
|||
###################### |
|||
# DOESN'T END WITH / # |
|||
###################### |
|||
else { |
|||
($dirfile,$package) = split(/\s+/,$_,2); |
|||
if ($package !~ m,^[a-z0-9-]*/.*$|^[a-z0-9-]*/.*/.*$,) { |
|||
my @more_things = split(/\s+/,$package); |
|||
$package = $more_things[$#more_things]; |
|||
(my $backpackage = $package) =~ s,\+,\\+,g; |
|||
my @dirfile = split(/\s+$backpackage/,$_); |
|||
$dirfile = $dirfile[0]; |
|||
} |
|||
@dirfile = split(/\//,$dirfile); |
|||
} |
|||
########################### |
|||
# PROCESS INTO FILES/DIRS # |
|||
########################### |
|||
my ($count,$holder); |
|||
for ($count = 0; $count <= $#dirfile; $count++) { |
|||
if ($count == 0) { |
|||
$holder = "/$dirfile[$count]"; |
|||
my $again = "$dirfile[$count]"; |
|||
$again{$again}++; |
|||
#my $all = "/."; |
|||
#$all{$all}++; |
|||
#if ($all{$all} == 1) { |
|||
#print FILELIST "/.\n"; |
|||
#} |
|||
if ($again{$again} == 1) { |
|||
push(@file,"/$dirfile[$count]"); |
|||
#print FILELIST "/$dirfile[$count]\n"; |
|||
} |
|||
} |
|||
else { |
|||
$holder = $holder . "/$dirfile[$count]"; |
|||
my $again = "$holder"; |
|||
$again{$again}++; |
|||
if ($again{$again} == 1) { |
|||
push(@file,"$holder"); |
|||
#print FILELIST "$holder\n"; |
|||
} |
|||
} |
|||
} # end for |
|||
} |
|||
undef @package_match; |
|||
#} |
|||
#} |
|||
} # while |
|||
close(CONTENTSDB); |
|||
undef @more_things; undef @dirfile; undef %again; undef %all; |
|||
return @file; |
|||
|
|||
|
|||
} # end sub remove_nfile |
|||
|
|||
1; |
|||
File diff suppressed because it is too large
@ -0,0 +1,97 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Pn_print; |
|||
use strict; |
|||
use SWIM::Global qw($argument); |
|||
use vars qw(@ISA @EXPORT); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(singular); |
|||
|
|||
|
|||
# There are times when it is good to print out the "package name_version" |
|||
# and there are times when it is unecessary. This sub tries to resolve |
|||
# these situations, basically it's printme() |
|||
sub singular { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
# for files, dirs, or groups |
|||
if (($commands->{"f"} || $commands->{"dir"} || $commands->{"g"} || |
|||
$commands->{"q"}) && |
|||
!($commands->{"i"} || $commands->{"l"} || |
|||
$commands->{"df"} || $commands->{"d"} || $commands->{"c"} || |
|||
$commands->{"scripts"} || $commands->{"preinst"} || $commands->{"postinst"} || |
|||
$commands->{"prerm"} || $commands->{"postrm"} || $commands->{"T"} || |
|||
$commands->{"pre_depends"} || $commands->{"depends"} || |
|||
$commands->{"recommends"} || $commands->{"suggests"} || |
|||
$commands->{"provides"} || $commands->{"replaces"} || |
|||
$commands->{"conflicts"} || $commands->{"requires"} || |
|||
$commands->{"changelog"} || $commands->{"m"} || $commands->{"menu"} || |
|||
$commands->{"copyright"})) { |
|||
print "$argument\n"; |
|||
} |
|||
elsif (($commands->{"f"} || $commands->{"dir"} || $commands->{"g"} || |
|||
$commands->{"q"}) && |
|||
$commands {"c"} && !($commands->{"i"} || |
|||
$commands->{"df"} || $commands->{"d"} || $commands->{"l"} || |
|||
$commands->{"scripts"} || $commands->{"preinst"} || $commands->{"postinst"} || |
|||
$commands->{"prerm"} || $commands->{"postrm"} || $commands->{"T"} && |
|||
$commands->{"pre_depends"} || $commands->{"depends"} || |
|||
$commands->{"recommends"} || $commands->{"suggests"} || |
|||
$commands->{"provides"} || $commands->{"replaces"} || |
|||
$commands->{"conflicts"} || $commands->{"requires"} || |
|||
$commands->{"changelog"} || $commands->{"m"} || $commands->{"menu"} || |
|||
$commands->{"copyright"})) { |
|||
print "$argument\n"; |
|||
} |
|||
elsif (($commands->{"f"} || $commands->{"dir"} || $commands->{"g"} || |
|||
$commands->{"q"}) && |
|||
$commands {"c"} && $commands->{"d"} && |
|||
!($commands->{"i"} || $commands->{"df"} || $commands->{"l"} || |
|||
$commands->{"scripts"} || $commands->{"preinst"} || $commands->{"postinst"} || |
|||
$commands->{"prerm"} || $commands->{"postrm"} || $commands->{"T"} || |
|||
$commands->{"pre_depends"} || $commands->{"depends"} || |
|||
$commands->{"recommends"} || $commands->{"suggests"} || |
|||
$commands->{"provides"} || $commands->{"replaces"} || |
|||
$commands->{"conflicts"} || $commands->{"requires"} || |
|||
$commands->{"changelog"} || $commands->{"m"} || $commands->{"menu"} || |
|||
$commands->{"copyright"})) { |
|||
print "$argument\n"; |
|||
} |
|||
elsif (($commands->{"f"} || $commands->{"dir"} || $commands->{"g"} || |
|||
$commands->{"q"}) && |
|||
$commands {"c"} && ($commands->{"d"} || |
|||
$commands->{"l"}) && !($commands->{"i"} || $commands->{"df"} || |
|||
$commands->{"scripts"} || $commands->{"preinst"} || $commands->{"postinst"} || |
|||
$commands->{"prerm"} || $commands->{"postrm"} || $commands->{"T"} || |
|||
$commands->{"pre_depends"} || $commands->{"depends"} || |
|||
$commands->{"recommends"} || $commands->{"suggests"} || |
|||
$commands->{"provides"} || $commands->{"replaces"} || |
|||
$commands->{"conflicts"} || $commands->{"requires"} || |
|||
$commands->{"changelog"} || $commands->{"m"} || $commands->{"menu"} || |
|||
$commands->{"copyright"})) { |
|||
print "$argument\n"; |
|||
} |
|||
|
|||
} # end sub singular |
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,951 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Qftp; |
|||
use strict; |
|||
use SWIM::Conf; |
|||
use SWIM::Global qw(@PACKAGES $argument %db); |
|||
use SWIM::DB_Library qw(:Xyz); |
|||
use SWIM::Deb qw(md5sumo); |
|||
use vars qw(@ISA @EXPORT); |
|||
use Net::FTP; |
|||
use SWIM::F; |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(qftp); |
|||
|
|||
|
|||
=pod |
|||
|
|||
This is the ftp client when --ftp is called with -q, --search/--ps. The |
|||
downloaded packages are put in the Default directory (DF) in a directory |
|||
mirroring (in a way relative to the design of swim) the dists structure |
|||
which is standard with Debian. This is desirable if a person wants to mirror |
|||
parts of a remote ftp site above the |
|||
default_directory/default_root_directory/; this also makes it easy for a |
|||
person to make their own distribution if they want, and apt can be used to |
|||
install the packages at a later time by temporarily placing them in |
|||
/var/cache/apt/archives using --df2apt. Obviously, this is nicer than using |
|||
apt just to download the packages, but the --nz option (apt) is provided |
|||
just in case a person is too lazed to do the -T thing, then they can do the |
|||
--apt2df thingy to move the packages from /var/cache/apt/archives to the |
|||
appropriate place in the DF. Ofcourse, maybe the -T thing was what the |
|||
person didn't want to do, or maybe the person wants to do a combination of |
|||
both (like something in the -T apt doesn't care about), this would be an |
|||
instance where --ftp would be more useful. The configuration file presents |
|||
a way to set this up so that the directory particular to the local ftpd can |
|||
be integrated into the DF. The DF can be given any unique named |
|||
directories, and the permisions of the directories created above can also be |
|||
specified. Other options to control the DF will be provided, and -h will be |
|||
available for querying the database pertaining to the packages in the DF, |
|||
thereby allowing manipulation of the packages in the DF. The database will |
|||
be made from Packages databases updated whenever the DF is called. There |
|||
will be two types of Packages, one pertaining to the state of the local |
|||
system, and the other pertaining to the state of the real distribution. |
|||
--file, and --http will also be integrated with DF when they become |
|||
available. |
|||
|
|||
IMPORTANT: Support will only be provided for not-installed databases, use a |
|||
not-installed database which reflects the currently installed package you |
|||
want to download in binary or source code. This is due to the fact that swim |
|||
thinks in terms of distribution states, and your installed system may |
|||
represent a combination of these things. The md5sum is currently checked |
|||
for packages, but not for source, if the md5sum data exists (not a new |
|||
debian-revision, for instance) the package will be checked. Whether or not |
|||
the package is OK it will be placed in it's appropriate place if it |
|||
downloads correctly. If you get FAILED, examine the package and alert |
|||
the |
|||
community (download place, what's wrong with the package), then delete the |
|||
package. |
|||
|
|||
=cut |
|||
sub qftp { |
|||
|
|||
my ($arg,$commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
|
|||
# Although the /dists/... could be found with -i, it's simpler |
|||
# just to use name_versionFILENAME instead. People shouldn't |
|||
# edit --stdin to combine different distributions when doing --ftp, |
|||
# (note: ofcourse apt-cache dumpavail could be used, and |
|||
# ncontentsindex could be put together from many dbs) |
|||
# since swim can only figure out what distribution is wanted |
|||
# from the default value or the one provided on the command line. |
|||
# The same is true of using apt. Whatever package is |
|||
# provided to --stdin is assumed to be of the specified distribution, |
|||
# anyways. |
|||
if (!$commands->{"n"}) { |
|||
dbi(\%commands); |
|||
@PACKAGES = map($db{$_},(@PACKAGES = split(/\s/,$arg))); |
|||
} |
|||
else { |
|||
ndb(\%commands); |
|||
@PACKAGES = map($db{$_},(@PACKAGES = split(/\s/,$arg))) |
|||
} |
|||
|
|||
|
|||
my @LOCATION; |
|||
for (0 .. $#PACKAGES) { |
|||
if (!defined $PACKAGES[$_]) { |
|||
print "swim: specified package(s) not found in database\n"; |
|||
exit; |
|||
} |
|||
} |
|||
if (defined $db{$PACKAGES[0] . "FN"}) { |
|||
@LOCATION = map($db{$_ . "FN"},@PACKAGES); |
|||
} |
|||
else { |
|||
print "swim: incorrect database was specified\n"; |
|||
exit; |
|||
} |
|||
|
|||
# might as well check for a temporary directory for downloads, if it |
|||
# doesn't exist create it. |
|||
mkdir("$default_directory/partial",$permission) |
|||
if !-d "$default_directory/partial"; |
|||
|
|||
# Check if there is a sources.list specified |
|||
if (-e "$swim_conf/swimz.list") { |
|||
undef @FTP; |
|||
open(SOURCES,"$swim_conf/swimz.list") |
|||
or warn "swim: could not find swimz.list\n"; |
|||
while (<SOURCES>) { |
|||
if ($_ !~ m,#.*|^\s+,) { |
|||
chomp; push(@FTP,$_); |
|||
} |
|||
} |
|||
if ($#FTP == -1) { |
|||
print "swim: no sites specified in swimz.list, quiting\n"; |
|||
exit; |
|||
} |
|||
} |
|||
|
|||
# let's make unique sites |
|||
my (%site,@sites,$site); |
|||
foreach $site (@FTP) { |
|||
my @parts = split(' ', $site); |
|||
$parts[1] =~ m,^ftp:/+( (?: (?!/). ) *)(.*),sx; |
|||
$site{$1}++; |
|||
push(@sites,"$1!$site") if $site{$1} == 1; |
|||
} |
|||
|
|||
|
|||
foreach $site (@sites) { |
|||
|
|||
# will provide all kinds of options for ftp..like firewall |
|||
|
|||
my $uri; ($site, $uri) = split(/!/,$site); |
|||
my $ftp = Net::FTP->new($site, |
|||
Debug => $debug, |
|||
Timeout => $timeout, |
|||
Passive => $passive, |
|||
Firewall => $firewall, |
|||
Port => $port |
|||
); |
|||
|
|||
########### |
|||
# CONNECT # |
|||
########### |
|||
if (defined $ftp) { |
|||
my $connected = $ftp->code(); |
|||
if ($connected == 220) { |
|||
print "swim: connected to $site\n"; |
|||
} |
|||
} |
|||
else { |
|||
print "swim: could not find $site\n"; |
|||
next; |
|||
} |
|||
|
|||
|
|||
######### |
|||
# LOGIN # |
|||
######### |
|||
$ftp->login("anonymous","swim\@the.netpedia.net"); |
|||
my $logged = $ftp->code(); |
|||
# we are logged, but what is the time difference. |
|||
if ($logged == 230 || $logged == 332) { |
|||
print "swim: logged in to $site\n"; |
|||
$ftp->binary; |
|||
} |
|||
else { |
|||
# 530 "not logged in" will have to test this |
|||
$ftp->code(); |
|||
print "swim: not logged in to $site\n"; |
|||
next; |
|||
} |
|||
|
|||
# find the base to the distribution |
|||
my @parts = split(' ', $uri); |
|||
$parts[1] =~ m,^ftp:/+( (?: (?!/). ) *)(.*),sx; |
|||
my $base = $2; |
|||
|
|||
# this finds the base, but it only needs to be found once, ofcourse |
|||
# a foreach is totally unecessary unless the site has weird symlinks. |
|||
my @tryme_again; my $base_count = 0; |
|||
foreach (@FTP) { |
|||
next if $base_count == 1; |
|||
|
|||
############ |
|||
# SETUP # |
|||
############ |
|||
LOCUS: foreach (@LOCATION) { |
|||
m,(.*)/(.*)$,; |
|||
my $uptopackage = $1; |
|||
my $packagename = $2; my $packagen = $2; |
|||
$packagename =~ s,\+,\\\+,g; |
|||
my ($source_drd,$drd); |
|||
# make directories with permissions if they don't already exist |
|||
# and also establish standardized (swimy) debian-non-US and the |
|||
# appropriate symlinks |
|||
# if a non-US file is requested. |
|||
if ($uptopackage !~ /non-US/) { |
|||
if (!-d "$default_directory/$default_root_directory/$uptopackage") { |
|||
my $place = "$default_directory/$default_root_directory"; |
|||
my @DP = split(m,/,,$uptopackage); |
|||
my $placement = "/"; |
|||
for (0 .. $#DP) { |
|||
$_ == 0 ? ($placement = "/$DP[$_]") |
|||
: ($placement = $placement . "/" . $DP[$_]); |
|||
mkdir("$place$placement",$permission); |
|||
# will fix this later |
|||
# or warn "swim: could not create dists directory\n"; |
|||
# Ofcourse there is even a better fix. |
|||
} |
|||
} |
|||
} |
|||
#################### |
|||
# ################ # |
|||
# # NON-US FILES # # |
|||
# ################ # |
|||
#################### |
|||
else { |
|||
(my $above_drd = $uptopackage) =~ s,dists,,; |
|||
$above_drd =~ s,non-US/,,; |
|||
$source_drd = (split(m,/,,$above_drd))[1]; |
|||
($drd = $default_root_directory) =~ s,/debian,,; |
|||
if (!-e "$default_directory$drd/debian-non-US$above_drd") { |
|||
my $place = "$default_directory"; |
|||
my $create = "$drd/debian-non-US$above_drd"; |
|||
my @DP = split(m,/,,$create); |
|||
my $placement = "/"; |
|||
for (0 .. $#DP) { |
|||
$_ == 0 ? ($placement = "/$DP[$_]") |
|||
: ($placement = $placement . "/" . $DP[$_]); |
|||
mkdir("$place$placement",$permission) |
|||
or warn "swim: could not create debian-non-US directory\n"; |
|||
} |
|||
if (!-d "$default_directory$drd/debian-non-US/$source_drd/source") { |
|||
my $place = "$default_directory"; |
|||
my $create = "$drd/debian-non-US/$source_drd/source"; |
|||
my @DP = split(m,/,,$create); |
|||
my $placement = "/"; |
|||
for (0 .. $#DP) { |
|||
$_ == 0 ? ($placement = "/$DP[$_]") |
|||
: ($placement = $placement . "/" . $DP[$_]); |
|||
mkdir("$place$placement",$permission) |
|||
or warn "swim: could not create debian-non-US directory\n"; |
|||
} |
|||
} |
|||
|
|||
$place = "$default_directory$drd/debian-non-US"; |
|||
my $disty = (split(m,/,))[1]; $create = "/dists/$disty"; |
|||
undef @DP; |
|||
@DP = split(m,/,,$create); |
|||
for (0 .. $#DP) { |
|||
$_ == 0 ? ($placement = "/$DP[$_]") |
|||
: ($placement = $placement . "/" . $DP[$_]); |
|||
mkdir("$place$placement",$permission) |
|||
or warn "swim: could not create debian-non-US directory\n"; |
|||
} |
|||
|
|||
# make the symlinks |
|||
chdir("$place$placement"); |
|||
symlink("../../$disty","non-US"); |
|||
symlink("../../$disty/source","source"); |
|||
|
|||
$place = "$default_directory$drd/debian"; $create = "/dists/$disty"; |
|||
undef @DP; |
|||
@DP = split(m,/,,$create); |
|||
for (0 .. $#DP) { |
|||
$_ == 0 ? ($placement = "/$DP[$_]") |
|||
: ($placement = $placement . "/" . $DP[$_]); |
|||
mkdir("$place$placement",$permission) |
|||
or warn "swim: could not create debian-non-US directory\n"; |
|||
} |
|||
chdir("$place$placement"); |
|||
|
|||
# make more symlinks |
|||
symlink |
|||
("../../../debian-non-US/dists/$disty/non-US","non-US"); |
|||
} # if non-US dir !-e |
|||
} # end non-us |
|||
|
|||
|
|||
####### |
|||
# GET # |
|||
####### |
|||
my $file; |
|||
($packagen = $packagename) =~ s,\\\+,\+,g; |
|||
my $localfile = |
|||
"$default_directory/partial/$packagen"; |
|||
my $home = |
|||
"$default_directory/$default_root_directory/$_"; |
|||
my $size = $ftp->size("$base/$_"); |
|||
my $rmtime = $ftp->mdtm("$base/$_"); |
|||
my $file_exist = $ftp->code(); |
|||
######################### |
|||
# CHECK DEBIAN-REVISION # |
|||
######################### |
|||
# the way this is set up, it is assumed that something exists for |
|||
# the -(debian-revision). |
|||
if ($file_exist == 550) { |
|||
print "swim: $packagen does not exist on the server\n"; |
|||
print "swim: checking to see if the debian-revision has changed\n"; |
|||
$packagename =~ m,^(.*)-[\dA-Za-z\.\+]+\.deb$,; |
|||
my $matcher = $1; |
|||
$_ =~ m,^(.*)/$matcher[-\da-zA-Z\.\+]+\.deb$,; |
|||
my $otherthing = $1; |
|||
my $REVISIONCHANGE = $ftp->ls("$base/$uptopackage"); |
|||
my $singfile; |
|||
foreach (@{$REVISIONCHANGE}) { |
|||
m,^.*/($matcher[-\dA-Za-z\.\+]+\.deb)$, |
|||
? ($singfile = $1) |
|||
: ($singfile = $_); |
|||
if ($singfile =~ /^$matcher/) { |
|||
$file = $singfile; |
|||
} |
|||
} |
|||
my $checkfile; |
|||
defined $file |
|||
? ($checkfile = $otherthing . "/$file") |
|||
: ($checkfile = "NOFILE"); |
|||
$size = $ftp->size("$base/$checkfile"); |
|||
$rmtime = $ftp->mdtm("$base/$checkfile"); |
|||
$file_exist = $ftp->code(); |
|||
print "swim: could not find $packagen debian-revision\n" |
|||
if $file_exist == 550; |
|||
push(@tryme_again,$_) if $file_exist == 550; |
|||
next if $file_exist == 550; |
|||
$localfile =~ s,$matcher[-\dA-Za-z\.\+]*\.deb$,$file,; |
|||
$home = |
|||
"$default_directory/$default_root_directory/$uptopackage/$file"; |
|||
$packagename = $file; $file = $otherthing . "/$file"; |
|||
} # END DEBIAN-REVISION |
|||
else {$file = $_; } |
|||
my ($lsize,$lmtime); |
|||
|
|||
|
|||
######################## |
|||
# SAME PACKAGE LOCALLY # |
|||
######################## |
|||
$packagename =~ m,(^[A-Za-z\d\+-\\+]*)_([\\+A-Za-z\d\+\.:]*) |
|||
[-]?[\dA-Za-z\.\+]*\.deb$,x; |
|||
my $spackage = $1; my $upstream_revision = $2; |
|||
$spackage =~ s,\+,\\\+,g; |
|||
if (-e $home) { |
|||
($lsize,$lmtime) = (stat($home))[7,9]; |
|||
} |
|||
# If the upstream-revision has changed and |
|||
# a local package with the same name exists, we want to delete it. |
|||
else { |
|||
opendir(DF,"$default_directory/$default_root_directory/$uptopackage"); |
|||
my $grepthing = "^" . $spackage . "_"; |
|||
#my $grepthing = $spackage . "_" . $upstream_revision; |
|||
foreach (sort grep(/$grepthing/, readdir(DF))) { |
|||
m,(.*)_([\dA-Za-z\+\.:]+)[-]?[\dA-Za-z\+\.]*\.deb$,; |
|||
my $lupstream_revision = $2; |
|||
if ($lupstream_revision eq $upstream_revision) { |
|||
print "swim: $_ with different debian-revision exists\n"; |
|||
$_ = ""; |
|||
|
|||
########## |
|||
# SOURCE # |
|||
########## |
|||
if ($commands->{"source"} || $commands->{"source_only"}) { |
|||
my (@SOURCE,$upstream_change); |
|||
my ($matcher,$local_source,$remote_source,$base) = |
|||
source_calc($base,$uptopackage,$packagename,$drd,$source_drd); |
|||
my $REVISIONCHANGE = $ftp->ls("$base/$remote_source"); |
|||
my $singfile; |
|||
foreach (@{$REVISIONCHANGE}) { |
|||
m,^.*/($matcher.*)$, |
|||
? ($singfile = $1) |
|||
: ($singfile = $_); |
|||
if ($singfile =~ /^$matcher/) { |
|||
$file = $singfile; |
|||
push(@SOURCE,"$base/$remote_source/$singfile"); |
|||
} |
|||
} |
|||
if (!defined @SOURCE) { |
|||
print "swim: checking for upstream-revsion change\n"; |
|||
($matcher) = (split(/_/,$matcher))[0]; |
|||
foreach (@{$REVISIONCHANGE}) { |
|||
m,^.*/($matcher.*)$, |
|||
? ($singfile = $1) |
|||
: ($singfile = $_); |
|||
if ($singfile =~ /^$matcher/) { |
|||
$file = $singfile; |
|||
push(@SOURCE,"$base/$remote_source/$singfile"); |
|||
} |
|||
} |
|||
$upstream_change = "yes" if defined @SOURCE; |
|||
} |
|||
foreach (@SOURCE) { |
|||
m,.*/(.*)$,; $packagename = $1; |
|||
$lmtime = (stat("$local_source/$packagename"))[9]; |
|||
-e "$local_source/$packagename" |
|||
? ($lmtime = (stat("$local_source/$packagename"))[9]) |
|||
: ($lmtime = -1); |
|||
$size = $ftp->size("$_"); |
|||
$rmtime = $ftp->mdtm("$_"); |
|||
$file_exist = $ftp->code(); |
|||
if ($lmtime != $rmtime) { |
|||
if (!$commands->{"diff"}) { |
|||
$localfile = "$default_directory/partial/$packagename"; |
|||
!defined $upstream_change |
|||
? print "swim: downloading $packagename ($size bytes)\n" |
|||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n"; |
|||
get($ftp,"$_",$localfile); |
|||
my $complete = $ftp->code(); |
|||
$lsize = (stat($localfile))[7]; |
|||
if ($lsize == $size && $complete == 226 && |
|||
$lmtime != $rmtime) { |
|||
print "swim: successful retrieval of $packagename\n"; |
|||
rename("$localfile","$local_source/$packagename") |
|||
or system "$mv","$localfile","$local_source/$packagename"; |
|||
} |
|||
else { |
|||
print "swim: unsuccessful retrieval of $packagename\n"; |
|||
} |
|||
} |
|||
else { |
|||
if (m,diff\.gz,) { |
|||
$localfile = "$default_directory/partial/$packagename"; |
|||
!defined $upstream_change |
|||
? print "swim: downloading $packagename ($size bytes)\n" |
|||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n"; |
|||
get($ftp,"$_",$localfile); |
|||
my $complete = $ftp->code(); |
|||
$lsize = (stat($localfile))[7]; |
|||
if ($lsize == $size && $complete == 226 && |
|||
$lmtime != $rmtime) { |
|||
print "swim: successful retrieval of $packagename\n"; |
|||
rename("$localfile","$local_source/$packagename") |
|||
or system "$mv","$localfile","$local_source/$packagename"; |
|||
} |
|||
else { |
|||
print "swim: unsuccessful retrieval of $packagename\n"; |
|||
} |
|||
} |
|||
} |
|||
utime(time,$rmtime,"$local_source/$packagename"); |
|||
$_ = ""; |
|||
} |
|||
else { |
|||
print "swim: $packagename already exists\n" |
|||
} |
|||
} |
|||
} # source |
|||
next LOCUS; |
|||
} |
|||
elsif ($lupstream_revision ne $upstream_revision) { |
|||
if (!$commands->{"source_only"}) { |
|||
print "swim: replacing $_ with a different upstream-revision\n"; |
|||
unlink |
|||
("$default_directory/$default_root_directory/$uptopackage/$_"); |
|||
} |
|||
print "swim: $_ exists with a different upstream-revision\n"; |
|||
} |
|||
} |
|||
closedir(DF); |
|||
} |
|||
|
|||
################## |
|||
# EXISTS LOCALLY # |
|||
################## |
|||
# got here but localtime was greater. |
|||
if (defined $rmtime && defined $lmtime) { |
|||
# ofcourse if the file does exist locally and has the same name |
|||
# and version, and this exists, something strange is going on. |
|||
if ($lmtime < $rmtime) { |
|||
print "swim: downloading $packagen, strange......... |
|||
same upstream version exists in the same package locally\n"; |
|||
get($ftp,"$base/$file",$localfile); |
|||
my $complete = $ftp->code(); |
|||
$argument = $localfile; |
|||
$commands{"md5sum"} = 1; |
|||
md5sumo(\%commands) if $complete == 226; |
|||
($packagen = $packagename) =~ s,\\\+,\+,g; |
|||
print "swim: successful retrieval of $packagen\n" |
|||
if $complete == 226; |
|||
$_ = "" if $complete == 226; |
|||
utime(time,$rmtime,$localfile); |
|||
} |
|||
elsif ($lmtime == $rmtime) { |
|||
$_ = ""; |
|||
($packagen = $packagename) =~ s,\\\+,\+,g; |
|||
print "swim: $packagen already exists\n"; |
|||
########## |
|||
# SOURCE # |
|||
########## |
|||
if ($commands->{"source"} || $commands->{"source_only"}) { |
|||
my (@SOURCE,$upstream_change); |
|||
my ($matcher,$local_source,$remote_source,$base) = |
|||
source_calc($base,$uptopackage,$packagename,$drd,$source_drd); |
|||
my $REVISIONCHANGE = $ftp->ls("$base/$remote_source"); |
|||
my $singfile; |
|||
foreach (@{$REVISIONCHANGE}) { |
|||
m,^.*/($matcher.*)$, |
|||
? ($singfile = $1) |
|||
: ($singfile = $_); |
|||
if ($singfile =~ /^$matcher/) { |
|||
$file = $singfile; |
|||
push(@SOURCE,"$base/$remote_source/$singfile"); |
|||
} |
|||
} |
|||
if (!defined @SOURCE) { |
|||
print "swim: checking for upstream-revsion change\n"; |
|||
($matcher) = (split(/_/,$matcher))[0]; |
|||
foreach (@{$REVISIONCHANGE}) { |
|||
m,^.*/($matcher.*)$, |
|||
? ($singfile = $1) |
|||
: ($singfile = $_); |
|||
if ($singfile =~ /^$matcher/) { |
|||
$file = $singfile; |
|||
push(@SOURCE,"$base/$remote_source/$singfile"); |
|||
} |
|||
} |
|||
$upstream_change = "yes" if defined @SOURCE; |
|||
} |
|||
foreach (@SOURCE) { |
|||
m,.*/(.*)$,; $packagename = $1; |
|||
-e "$local_source/$packagename" |
|||
? ($lmtime = (stat("$local_source/$packagename"))[9]) |
|||
: ($lmtime = -1); |
|||
$size = $ftp->size("$_"); |
|||
$rmtime = $ftp->mdtm("$_"); |
|||
$file_exist = $ftp->code(); |
|||
if ($lmtime != $rmtime) { |
|||
if (!$commands->{"diff"}) { |
|||
$localfile = "$default_directory/partial/$packagename"; |
|||
!defined $upstream_change |
|||
? print "swim: downloading $packagename ($size bytes)\n" |
|||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n"; |
|||
get($ftp,"$_",$localfile); |
|||
my $complete = $ftp->code(); |
|||
$lsize = (stat($localfile))[7]; |
|||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) { |
|||
print "swim: successful retrieval of $packagename\n"; |
|||
rename("$localfile","$local_source/$packagename") |
|||
or system "$mv","$localfile","$local_source/$packagename"; |
|||
} |
|||
else { |
|||
print "swim: unsuccessful retrieval of $packagename\n"; |
|||
} |
|||
} |
|||
else { |
|||
if (m,diff\.gz,) { |
|||
$localfile = "$default_directory/partial/$packagename"; |
|||
!defined $upstream_change |
|||
? print "swim: downloading $packagename ($size bytes)\n" |
|||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n"; |
|||
get($ftp,"$_",$localfile); |
|||
my $complete = $ftp->code(); |
|||
$lsize = (stat($localfile))[7]; |
|||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) { |
|||
print "swim: successful retrieval of $packagename\n"; |
|||
rename("$localfile","$local_source/$packagename") |
|||
or system "$mv","$localfile","$local_source/$packagename"; |
|||
} |
|||
else { |
|||
print "swim: unsuccessful retrieval of $packagename\n"; |
|||
} |
|||
} |
|||
} |
|||
utime(time,$rmtime,"$local_source/$packagename"); |
|||
$_ = ""; |
|||
} |
|||
else { |
|||
print "swim: $packagename already exists\n" |
|||
} |
|||
} |
|||
} # source |
|||
} |
|||
} |
|||
######################################################### |
|||
# DOESN'T EXIST LOCALLY OR DIFFERENT UPSTREAM-REVISION # |
|||
######################################################### |
|||
else { |
|||
######################## |
|||
# BINARY AND/OR SOURCE # |
|||
######################## |
|||
if (!$commands->{"source_only"}) { |
|||
print "swim: downloading $packagen ($size bytes)\n"; |
|||
my $upstream_change; |
|||
get($ftp,"$base/$file",$localfile); |
|||
my $complete = $ftp->code(); |
|||
$lsize = (stat($localfile))[7]; |
|||
if ($lsize == $size && $complete == 226) { |
|||
$argument = $localfile; |
|||
$commands{"md5sum"} = 1; md5sumo(\%commands); |
|||
($packagen = $packagename) =~ s,\\\+,\+,g; |
|||
print "swim: successful retrieval of $packagen\n"; |
|||
rename("$localfile","$home") |
|||
or system "$mv", "$localfile", "$home"; |
|||
utime(time,$rmtime,"$home"); |
|||
} |
|||
else { |
|||
print "swim: unsuccessful retrieval of $file\n"; |
|||
} |
|||
$_ = ""; |
|||
########## |
|||
# SOURCE # |
|||
########## |
|||
if ($commands->{"source"}) { |
|||
my (@SOURCE,$upstream_change); |
|||
my ($matcher,$local_source,$remote_source,$base) = |
|||
source_calc($base,$uptopackage,$packagename,$drd,$source_drd); |
|||
my $REVISIONCHANGE = $ftp->ls("$base/$remote_source"); |
|||
my $singfile; |
|||
foreach (@{$REVISIONCHANGE}) { |
|||
m,^.*/($matcher.*)$, |
|||
? ($singfile = $1) |
|||
: ($singfile = $_); |
|||
if ($singfile =~ /^$matcher/) { |
|||
$file = $singfile; |
|||
push(@SOURCE,"$base/$remote_source/$singfile"); |
|||
} |
|||
} |
|||
if (!defined @SOURCE) { |
|||
print "swim: checking for upstream-revsion change\n"; |
|||
($matcher) = (split(/_/,$matcher))[0]; |
|||
foreach (@{$REVISIONCHANGE}) { |
|||
m,^.*/($matcher.*)$, |
|||
? ($singfile = $1) |
|||
: ($singfile = $_); |
|||
if ($singfile =~ /^$matcher/) { |
|||
$file = $singfile; |
|||
push(@SOURCE,"$base/$remote_source/$singfile"); |
|||
} |
|||
} |
|||
$upstream_change = "yes" if defined @SOURCE; |
|||
} |
|||
foreach (@SOURCE) { |
|||
m,.*/(.*)$,; $packagename = $1; |
|||
-e "$local_source/$packagename" |
|||
? ($lmtime = (stat("$local_source/$packagename"))[9]) |
|||
: ($lmtime = -1); |
|||
$size = $ftp->size("$_"); |
|||
$rmtime = $ftp->mdtm("$_"); |
|||
$file_exist = $ftp->code(); |
|||
if ($lmtime != $rmtime) { |
|||
if (!$commands->{"diff"}) { |
|||
$localfile = "$default_directory/partial/$packagename"; |
|||
!defined $upstream_change |
|||
? print "swim: downloading $packagename ($size bytes)\n" |
|||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n"; |
|||
get($ftp,"$_",$localfile); |
|||
my $complete = $ftp->code(); |
|||
$lsize = (stat($localfile))[7]; |
|||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) { |
|||
print "swim: successful retrieval of $packagename\n"; |
|||
rename("$localfile","$local_source/$packagename") |
|||
or system "$mv","$localfile","$local_source/$packagename"; |
|||
} |
|||
else { |
|||
print "swim: unsuccessful retrieval of $packagename\n"; |
|||
} |
|||
} |
|||
else { |
|||
if (m,diff\.gz,) { |
|||
$localfile = "$default_directory/partial/$packagename"; |
|||
!defined $upstream_change |
|||
? print "swim: downloading $packagename ($size bytes)\n" |
|||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n"; |
|||
get($ftp,"$_",$localfile); |
|||
my $complete = $ftp->code(); |
|||
$lsize = (stat($localfile))[7]; |
|||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) { |
|||
print "swim: successful retrieval of $packagename\n"; |
|||
rename("$localfile","$local_source/$packagename") |
|||
or system "$mv","$localfile","$local_source/$packagename"; |
|||
} |
|||
else { |
|||
print "swim: unsuccessful retrieval of $packagename\n"; |
|||
} |
|||
} |
|||
} |
|||
utime(time,$rmtime,"$local_source/$packagename"); |
|||
$_ = ""; |
|||
} |
|||
else { |
|||
print "swim: $packagename already exists\n" |
|||
} |
|||
} |
|||
} # source |
|||
} |
|||
############### |
|||
# SOURCE-ONLY # |
|||
############### |
|||
else { |
|||
my (@SOURCE,$upstream_change); |
|||
my ($matcher,$local_source,$remote_source,$base) = |
|||
source_calc($base,$uptopackage,$packagename,$drd,$source_drd); |
|||
my $REVISIONCHANGE = $ftp->ls("$base/$remote_source"); |
|||
my $singfile; |
|||
foreach (@{$REVISIONCHANGE}) { |
|||
m,^.*/($matcher.*)$, |
|||
? ($singfile = $1) |
|||
: ($singfile = $_); |
|||
if ($singfile =~ /^$matcher/) { |
|||
$file = $singfile; |
|||
push(@SOURCE,"$base/$remote_source/$singfile"); |
|||
} |
|||
} |
|||
if (!defined @SOURCE) { |
|||
print "swim: checking for upstream-revsion change\n"; |
|||
($matcher) = (split(/_/,$matcher))[0]; |
|||
foreach (@{$REVISIONCHANGE}) { |
|||
m,^.*/($matcher.*)$, |
|||
? ($singfile = $1) |
|||
: ($singfile = $_); |
|||
if ($singfile =~ /^$matcher/) { |
|||
$file = $singfile; |
|||
push(@SOURCE,"$base/$remote_source/$singfile"); |
|||
} |
|||
} |
|||
$upstream_change = "yes" if defined @SOURCE; |
|||
} |
|||
foreach (@SOURCE) { |
|||
m,.*/(.*)$,; $packagename = $1; |
|||
-e "$local_source/$packagename" |
|||
? ($lmtime = (stat("$local_source/$packagename"))[9]) |
|||
: ($lmtime = -1); |
|||
$size = $ftp->size("$_"); |
|||
$rmtime = $ftp->mdtm("$_"); |
|||
$file_exist = $ftp->code(); |
|||
if ($lmtime != $rmtime) { |
|||
if (!$commands->{"diff"}) { |
|||
$localfile = "$default_directory/partial/$packagename"; |
|||
!defined $upstream_change |
|||
? print "swim: downloading $packagename ($size bytes)\n" |
|||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n"; |
|||
get($ftp,"$_",$localfile); |
|||
my $complete = $ftp->code(); |
|||
$lsize = (stat($localfile))[7]; |
|||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) { |
|||
print "swim: successful retrieval of $packagename\n"; |
|||
rename("$localfile","$local_source/$packagename") |
|||
or system "$mv","$localfile","$local_source/$packagename"; |
|||
} |
|||
else { |
|||
print "swim: unsuccessful retrieval of $packagename\n"; |
|||
} |
|||
} |
|||
else { |
|||
if (m,diff\.gz,) { |
|||
$localfile = "$default_directory/partial/$packagename"; |
|||
!defined $upstream_change |
|||
? print "swim: downloading $packagename ($size bytes)\n" |
|||
: print "swim: downloading upstream-revision $packagename ($size bytes)\n"; |
|||
get($ftp,"$_",$localfile); |
|||
my $complete = $ftp->code(); |
|||
$lsize = (stat($localfile))[7]; |
|||
if ($lsize == $size && $complete == 226 && $lmtime != $rmtime) { |
|||
print "swim: successful retrieval of $packagename\n"; |
|||
rename("$localfile","$local_source/$packagename") |
|||
or system "$mv","$localfile","$local_source/$packagename"; |
|||
} |
|||
else { |
|||
print "swim: unsuccessful retrieval of $packagename\n"; |
|||
} |
|||
} |
|||
} |
|||
utime(time,$rmtime,"$local_source/$packagename"); |
|||
$_ = ""; |
|||
} |
|||
else { |
|||
print "swim: $packagename already exists\n" |
|||
} |
|||
} |
|||
} # source-only |
|||
} |
|||
} |
|||
$base_count++; |
|||
} # foreach FTP |
|||
undef @LOCATION; |
|||
@LOCATION = @tryme_again; |
|||
$ftp->quit() if !defined @LOCATION; |
|||
my $good_bye = $ftp->code(); |
|||
print "swim: logged out\n" if $good_bye == 221; |
|||
undef @sites if !defined @LOCATION; |
|||
|
|||
} # foreach sites |
|||
untie %db; |
|||
|
|||
} # end sub qftp |
|||
|
|||
|
|||
# figure out the source stuff, make appropriate directories for sections |
|||
# which aren't non-US |
|||
sub source_calc { |
|||
|
|||
my($base,$uptopackage,$packagename,$drd,$source_drd) = @_; |
|||
|
|||
|
|||
# if source is empty in %db we can use the package name, need |
|||
# to watch for experimental |
|||
my ($remote_source,$local_source,@SOURCE); |
|||
# NON-US |
|||
if ($uptopackage =~ /non-US/) { |
|||
$local_source = |
|||
"$default_directory$drd/debian-non-US/$source_drd/source"; |
|||
$uptopackage =~ m,(.*)/.*$,; $remote_source = $1; |
|||
$remote_source = "$remote_source/source"; |
|||
# for safety's sake and because most sites don't have |
|||
# /pub/debian/dists/unstable/non-US/source except for a |
|||
# site made with swim, convert debian to debian-non-US and |
|||
# hope everything is standard. |
|||
if ($base !~ /debian-non-US/) { |
|||
$base =~ s/debian/debian-non-US/; |
|||
} |
|||
} |
|||
# EVERYTHING ELSE |
|||
else { |
|||
$uptopackage =~ m,(.*)/(.*)$,; |
|||
my $subject = $2; $1 =~ m,(.*)/.*$,; $local_source = $1; |
|||
#$remote_source =~ m,(.*)/.*$,; $remote_source = $1; |
|||
$remote_source = $local_source; |
|||
$local_source = "$remote_source/source/$subject"; |
|||
$remote_source = $local_source; |
|||
$local_source = |
|||
"$default_directory$default_root_directory/$local_source"; |
|||
} |
|||
|
|||
# exciting matcher realities..if it isn't non-US than the |
|||
# %db needs to be searched for anything found in Source:, |
|||
# if it is defined, then vola, herein this section lays the |
|||
# source, otherwise it's probably in the section which pertains |
|||
# to the package being queried..we hope. Epochs aren't used |
|||
# fortunately they aren't in package_versionFN, but they can |
|||
# be in the Source: area so they need to be removed. |
|||
$packagename =~ m,(^[A-Za-z\d\+-\\+]*_[\\+A-Za-z\d\+\.:]*) |
|||
[-]?[\dA-Za-z\.\+]*\.deb$,x; |
|||
|
|||
# everything, but revision |
|||
my $matcher = $1; |
|||
$matcher =~ m,^(.*)_(.*)$,; my $mat = $1; |
|||
if (defined $db{$mat}) { |
|||
$mat = $db{$mat}; $mat = $db{$mat}; |
|||
if ($mat =~ m,Installed-Size:\s\d+\s+Source:\s(.*),){ |
|||
$matcher = $1; |
|||
########################################## |
|||
# DIFFERENT VERSION AND DIFFERENT SOURCE # |
|||
########################################## |
|||
if ($matcher =~ m,[\(\)], ) { |
|||
$matcher =~ /:/ |
|||
? $matcher =~ m,^(.*) |
|||
\s\([\d]?[:]? |
|||
([A-Za-z0-9\+\.]+) |
|||
[-]?[\dA-Za-z\+\.]*\)$,x |
|||
: $matcher =~ m,^(.*) |
|||
\s\( |
|||
([A-Za-z0-9\+\.]+) |
|||
[-]?[\dA-Za-z\+\.]*\)$,x; |
|||
|
|||
my $mat2 = $1; my $mat2_ver = $2; |
|||
$matcher = $mat2 . "_" . $mat2_ver; |
|||
if (defined $db{$mat2}) { |
|||
$matcher = $mat2 . "_" . $mat2_ver; |
|||
# time to change the $remote_source and $local_source |
|||
if ($uptopackage !~ /non-US/) { |
|||
my $change = $db{$mat2}; |
|||
$change = $db{$change ."FN"}; |
|||
$change =~ m,(.*)/(.*)$,; |
|||
$uptopackage = $1; $uptopackage =~ m,(.*)/(.*)$,; |
|||
my $subject = $2; |
|||
$1 =~ m,(.*)/.*$,; $local_source = $1; |
|||
$local_source = "$local_source/source/$subject"; |
|||
$remote_source = $local_source; |
|||
$local_source = |
|||
"$default_directory$default_root_directory/$local_source"; |
|||
} |
|||
} |
|||
} |
|||
##################################### |
|||
# SAME VERSION AND DIFFERENT SOURCE # |
|||
##################################### |
|||
else { |
|||
if (defined $db{$matcher}) { |
|||
# time to change the |
|||
# $remote_source and $local_source |
|||
if ($uptopackage !~ /non-US/) { |
|||
my $change = $db{$matcher}; |
|||
$change = $db{$change ."FN"}; |
|||
$change =~ m,(.*)/(.*)$,; |
|||
$uptopackage = $1; $uptopackage =~ m,(.*)/(.*)$,; |
|||
my $subject = $2; |
|||
$1 =~ m,(.*)/.*$,; $local_source = $1; |
|||
$local_source = "$local_source/source/$subject"; |
|||
$remote_source = $local_source; |
|||
$local_source = |
|||
"$default_directory$default_root_directory/$local_source"; |
|||
} |
|||
} |
|||
} |
|||
} # Source: found |
|||
} # should be defined |
|||
|
|||
|
|||
# time to make direcorties if $local_source isn't defined |
|||
# non-US already made, if source if already made, just the |
|||
# subject above needs to be made |
|||
if (!-e $local_source) { |
|||
my $place; |
|||
my @LS = split(m,/,,$local_source); |
|||
for (1 .. $#LS - 2) { |
|||
$_ == 1 ? ($place = "/$LS[$_]") |
|||
: ($place = $place . "/" . $LS[$_]); |
|||
} |
|||
my $create = "$LS[$#LS -1]/$LS[$#LS]"; |
|||
if (-d "$place/$LS[$#LS - 1]") { |
|||
mkdir("$place/$create",$permission) |
|||
or warn "swim: could not create source directory\n"; |
|||
} |
|||
else { |
|||
my @DP = split(m,/,,$create); |
|||
my $placement = "/"; |
|||
for (0 .. $#DP) { |
|||
$_ == 0 ? ($placement = "/$DP[$_]") |
|||
: ($placement = $placement . "/" . $DP[$_]); |
|||
mkdir("$place$placement",$permission) |
|||
or warn "swim: could not create source directory\n"; |
|||
} |
|||
} |
|||
} |
|||
|
|||
return($matcher,$local_source,$remote_source,$base); |
|||
|
|||
} # end source_calc |
|||
|
|||
|
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,180 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Ramdisk; |
|||
use strict; |
|||
use SWIM::Conf; |
|||
use SWIM::Library; |
|||
use vars qw(@ISA @EXPORT); |
|||
|
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(ramdisk); |
|||
|
|||
|
|||
=pod |
|||
|
|||
make access a lot faster for contentsindex.deb.gz, alternatively |
|||
searchindex.deb & file/dirindex. Ramdisks don't work well for |
|||
everything like the creation of a database. The goal is to |
|||
automatically determine the size of the disk based on the files |
|||
put into it (which will all be compressed) This also has a residual |
|||
effect, so when the ramdisk is umounted stuff still stays in |
|||
the memory. |
|||
|
|||
=cut |
|||
|
|||
sub ramdisk { |
|||
|
|||
|
|||
my ($commands) = @_; |
|||
|
|||
# lot's of thing can be put into the ramdisk, ncontentsindex being the |
|||
# most important, but flat search files, too. --ramdiskon -n would be |
|||
# the most important application. |
|||
my $size = 0; |
|||
my (@storage,@files); |
|||
my $count = 0; |
|||
my %commands = %$commands; |
|||
my $where = finddb(\%commands); |
|||
my ($arch,$dist) = which_archdist(\%commands); |
|||
my $not = "n" if defined $arch; |
|||
$not = "" if !$commands->{"n"}; |
|||
$arch = "" if !$commands->{"n"}; |
|||
$dist = "" if !$commands->{"n"}; |
|||
my $contentsindex = "contentsindex"; |
|||
my $searchindex = "searchindex"; |
|||
my $dirindex = "dirindex"; |
|||
|
|||
if ($commands->{"ramdiskon"}) { |
|||
|
|||
my $rambo = "$cat /proc/mounts|"; |
|||
open(RAM, "$rambo"); |
|||
while (<RAM>) { |
|||
if (/ram/) { |
|||
my($device,$mount) = split(/\s/,$_,2); |
|||
if ($mount =~ /dramdisk/) { |
|||
print "swim: use --ramdiskoff\n"; |
|||
exit; |
|||
} |
|||
$storage[$count] = $device; |
|||
$count++; |
|||
} |
|||
} |
|||
close(RAM); |
|||
|
|||
if (-e "$where/$not$contentsindex$arch$dist.deb.gz" && |
|||
-B "$where/$not$contentsindex$arch$dist.deb.gz") { |
|||
$size = (stat("$where/$not$contentsindex$arch$dist.deb.gz"))[7]; |
|||
push(@files,"$where/$not$contentsindex$arch$dist.deb.gz"); |
|||
} |
|||
|
|||
if ($commands->{"searchfile"}) { |
|||
# stat caused some weirdisms based on the boolean logic |
|||
#if (-e "$where/$not$searchindex$arch$dist.deb" && |
|||
# -e "$where/$not$dirindex$arch$dist.deb") { |
|||
# compress the monsters |
|||
if (!-e "$where/$not$dirindex$arch$dist.deb.gz") { |
|||
print "swim: please wait while dirindex.deb is compressed\n"; |
|||
if (-e "$where/$not$dirindex$arch$dist.deb") { |
|||
system "$gzip -c9 $where/$not$dirindex$arch$dist.deb > $where/$not$dirindex$arch$dist.deb.gz"; |
|||
} |
|||
} |
|||
if (!-e "$where/$not$searchindex$arch$dist.deb.gz") { |
|||
print "swim: please wait while searchindex.deb is compressed\n"; |
|||
if (-e "$where/$not$searchindex$arch$dist.deb") { |
|||
system "$gzip -c9 $where/$not$searchindex$arch$dist.deb > $where/$not$searchindex$arch$dist.deb.gz"; |
|||
} |
|||
} |
|||
push(@files,"$where/$not$dirindex$arch$dist.deb.gz"); |
|||
push(@files,"$where/$not$searchindex$arch$dist.deb.gz"); |
|||
my $size1 = (stat("$where/$not$searchindex$arch$dist.deb.gz"))[7]; |
|||
my $size2 = (stat("$where/$not$dirindex$arch$dist.deb.gz"))[7]; |
|||
if (defined $size) { |
|||
$size = $size + $size1 + $size2; |
|||
} |
|||
else { |
|||
$size = $size1 + $size2; |
|||
} |
|||
#} |
|||
} |
|||
|
|||
# it will be assumed that ext2 is used, and hopefully there isn't a mount |
|||
# of the exact same name..hence dramdisk should be unusual |
|||
my $number; |
|||
if (defined @storage) { |
|||
@storage = sort {$a cmp $b} @storage; |
|||
$storage[$#storage] =~ s/\D//g; |
|||
$number = $storage[$#storage] + 1; |
|||
} |
|||
else { |
|||
$number = 0; |
|||
} |
|||
|
|||
# the size will be the sizes added together/1024 + (.15 of the total) |
|||
if (-e "$where/dramdisk") { |
|||
if (!-d "$where/dramdisk") { |
|||
print "swim: --ramdiskon requires dir dramdisk, but a file named dramdisk already exists\n"; |
|||
exit; |
|||
} |
|||
} |
|||
elsif (!-d "$where/dramdisk") { |
|||
mkdir("$where/dramdisk",0666); |
|||
} |
|||
|
|||
my $increase = $size * 0.15; |
|||
$size = $increase + $size; |
|||
$size = $size/1024; |
|||
$size = sprintf("%.f",$size); |
|||
if ($size > 0) { |
|||
system "$mke2fs", "-m0", "/dev/ram$number", "$size"; |
|||
system "$mount", "-t", "ext2", "/dev/ram$number", "$where/dramdisk"; |
|||
foreach (@files) { |
|||
system "$copy", "$_", "$where/dramdisk"; |
|||
} |
|||
} |
|||
} # if on |
|||
else { |
|||
|
|||
my $rambo = "$cat /proc/mounts|"; |
|||
open(RAM, "$rambo"); |
|||
while (<RAM>) { |
|||
if (/ram/) { |
|||
my($device,$mount) = split(/\s/,$_,2); |
|||
if ($mount =~ /dramdisk/) { |
|||
system "$umount", "$device"; |
|||
exit; |
|||
} |
|||
$storage[$count] = $device; |
|||
$count++; |
|||
} |
|||
} |
|||
close(RAM); |
|||
|
|||
|
|||
} # if off |
|||
|
|||
exit; |
|||
|
|||
} # end sub ramdisk |
|||
|
|||
|
|||
|
|||
|
|||
|
|||
1; |
|||
@ -0,0 +1,470 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Safex; |
|||
use strict; |
|||
use Term::ReadLine; |
|||
use SWIM::Conf qw($apt_get $dpkg $tmp $HISTORY); |
|||
use SWIM::Global qw(@PACKAGES $argument $aptor_group %db); |
|||
use SWIM::DB_Library qw(:Xyz); |
|||
use SWIM::Library; |
|||
use vars qw(@ISA @EXPORT %EXPORT_TAGS); |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(safex); |
|||
|
|||
|
|||
# when x is called |
|||
sub safex { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
if ($commands->{"x"} || $commands->{"ftp"} || $commands->{"source"} || |
|||
$commands->{"source_only"} || $commands->{"remove"} || $commands->{"r"} || |
|||
$commands->{"purge"}) { |
|||
|
|||
|
|||
if (!defined @PACKAGES) { |
|||
if ($commands->{"search"} || $commands->{"ps"} || $commands->{"research"} |
|||
|| $commands->{"refinesearch"}) { |
|||
@PACKAGES = "NOPACKAGES"; |
|||
} |
|||
else { |
|||
@PACKAGES = @ARGV; |
|||
} |
|||
} |
|||
|
|||
#print "PACKAGES @PACKAGES $argument\n"; |
|||
|
|||
my ($aptor,$arg); |
|||
if (defined $argument) { |
|||
if ($argument =~ /_/) { |
|||
$argument =~ m,(.*)_.*,; |
|||
$aptor = $1; |
|||
} |
|||
else { |
|||
if (($argument =~ m,/, && ($commands->{"y"} || $commands->{"z"} || |
|||
$commands->{"ftp"} || $commands->{"nz"})) || defined $aptor_group || |
|||
$commands->{"ftp"} || $commands->{"purge"} || $commands->{"remove"} || |
|||
$commands->{"r"}) { |
|||
if ($PACKAGES[$#PACKAGES] =~ /_/) { |
|||
$PACKAGES[$#PACKAGES] =~ m,(.*)_.*,; |
|||
$aptor = $1; |
|||
} |
|||
else { |
|||
$aptor = $PACKAGES[$#PACKAGES]; |
|||
} |
|||
} |
|||
else { |
|||
$aptor = $argument; |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
if ($commands->{"y"} || $commands->{"z"} || $commands->{"ftp"} || |
|||
$commands->{"nz"} || $commands->{"purge"} || $commands->{"remove"} || |
|||
$commands->{"r"}) { |
|||
if ($PACKAGES[$#PACKAGES] =~ /_/) { |
|||
$PACKAGES[$#PACKAGES] =~ m,(.*)_.*,; |
|||
$aptor = $1; |
|||
} |
|||
else { |
|||
$aptor = $PACKAGES[$#PACKAGES]; |
|||
} |
|||
} |
|||
} |
|||
|
|||
if ($PACKAGES[$#PACKAGES] =~ m,/,) { |
|||
$PACKAGES[$#PACKAGES] =~ m,.*/(.*)$,; |
|||
$arg = $1; |
|||
foreach (@PACKAGES) { |
|||
$_ =~ m,.*/(.*)$,; |
|||
shift @PACKAGES; |
|||
push(@PACKAGES,$1); |
|||
} |
|||
} |
|||
else { |
|||
if ($PACKAGES[$#PACKAGES] =~ /_/) { |
|||
$PACKAGES[$#PACKAGES] =~ m,(.*)_.*,; |
|||
$arg = $1; |
|||
foreach (0 .. $#PACKAGES) { |
|||
if ($PACKAGES[$_] =~ /_/) { |
|||
$PACKAGES[$_] =~ m,^(.*)_.*$,; |
|||
$PACKAGES[$_] = $1; |
|||
} |
|||
else { |
|||
$PACKAGES[$_] = $PACKAGES[$_]; |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
$arg = $PACKAGES[$#PACKAGES]; |
|||
foreach (0 .. $#PACKAGES) { |
|||
if ($PACKAGES[$_] =~ /_/) { |
|||
$PACKAGES[$_] =~ m,^(.*)_.*$,; |
|||
$PACKAGES[$_] = $1; |
|||
} |
|||
else { |
|||
$PACKAGES[$_] = $PACKAGES[$_]; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
|
|||
$aptor = "DEFINEDONE" if !defined $aptor; |
|||
if (($aptor eq $arg) || ($commands->{"search"} || |
|||
$commands->{"ps"} || $commands->{"research"} || |
|||
$commands->{"refinesearch"} || $aptor eq "/.") && |
|||
$PACKAGES[0] ne "NOPACKAGES") { |
|||
xyz(\%commands); |
|||
} |
|||
} |
|||
|
|||
|
|||
} |
|||
|
|||
|
|||
# swim provides a great interface to apt. The trick is to not actually |
|||
# run apt-get until all the arguments are stored in an array. This is |
|||
# done easily for xy and for for xyz which provides virtual installation |
|||
# and querying completion after --db && --ndb updates. Obviously, the |
|||
# package virtually installed needs to be the same architecture as the |
|||
# machine running, since this is how apt works, but the databases can be |
|||
# in any specified directory. This function also provides an interface for |
|||
# ftp, as well as dpkg's --remove & --purge. |
|||
sub xyz { |
|||
|
|||
my ($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
if (!$commands->{"ftp"}) { |
|||
if (!defined $apt_get) { |
|||
print "swim: configure swimrc\n"; |
|||
exit; |
|||
} |
|||
} |
|||
|
|||
# error correcting |
|||
if ($commands->{"ftp"} && ($commands->{"r"} || $commands->{"remove"} || |
|||
$commands->{"purge"})) { |
|||
print "swim: --ftp cannot be used with "; |
|||
print "-r " if defined $commands->{"r"}; |
|||
print "--remove " if defined $commands->{"remove"}; |
|||
print "--purge " if defined $commands->{"purge"}; |
|||
print "\n"; |
|||
exit; |
|||
} |
|||
if (($commands->{"r"} || $commands->{"remove"}) && $commands->{"purge"}) { |
|||
print "swim: "; |
|||
print "-r " if defined $commands->{"r"}; |
|||
print "--remove " if defined $commands->{"remove"}; |
|||
print "--purge " if defined $commands->{"purge"}; |
|||
print "cannot be used together\n"; |
|||
exit; |
|||
} |
|||
if (($commands->{"y"} || $commands->{"z"} || $commands->{"x"} || |
|||
$commands->{"nz"}) && ($commands->{"ftp"} || $commands->{"purge"})) { |
|||
print "swim: -"; |
|||
print "x" if $commands->{"x"}; |
|||
print "y" if $commands->{"y"}; |
|||
print "z" if $commands->{"z"}; |
|||
print " --nz" if $commands->{"nz"}; |
|||
print " cannot be used with "; |
|||
print "--purge " if defined $commands->{"purge"}; |
|||
print "--ftp " if defined $commands->{"ftp"}; |
|||
print "\n"; |
|||
exit; |
|||
} |
|||
if (($commands->{"source"} && $commands->{"source_only"})) { |
|||
print "swim: --source and --source_only cannot be used together\n"; |
|||
exit; |
|||
} |
|||
if (($commands->{"source"} || $commands->{"source_only"}) && |
|||
!$commands->{"ftp"}) { |
|||
print "swim: --"; |
|||
print "source" if $commands->{"source"}; |
|||
print "source_only" if $commands->{"source_only"}; |
|||
print " cannot be used without --ftp\n"; |
|||
exit; |
|||
} |
|||
if (($commands->{"y"} || $commands->{"z"} || $commands->{"nz"}) && |
|||
!$commands->{"x"}) { |
|||
print "swim: requires -x option\n"; |
|||
exit; |
|||
} |
|||
|
|||
if ($commands->{"x"}) { |
|||
# There's no sense in doing this if the wrong architecture is called. |
|||
if (defined $dpkg) { |
|||
system "$dpkg --print-installation-architecture > $tmp/arch.deb"; |
|||
open(ARCH, "$tmp/arch.deb") or warn "couldn't find arch\n"; |
|||
my @arch = <ARCH>; chomp $arch[0]; |
|||
my($arch,$dist) = which_archdist(\%commands); $arch =~ m,^-(.*),; |
|||
if ($1 ne $arch[0]) { |
|||
print "swim: apt uses the $arch[0] architecture\n"; |
|||
exit; |
|||
} |
|||
} |
|||
} |
|||
|
|||
|
|||
############### |
|||
# SAFETY MODE # |
|||
############### |
|||
if ((($commands->{"x"} || ($commands->{"x"} && $commands->{"y"})) || |
|||
($commands->{"x"} && ($commands->{"r"} || $commands->{"remove"}) || |
|||
($commands->{"x"} && $commands->{"y"} && ($commands->{"r"} || |
|||
$commands->{"remove"})))) && |
|||
!($commands->{"z"} || $commands->{"nz"})) { |
|||
my $arg; |
|||
my $count = 0; |
|||
foreach (@PACKAGES) { |
|||
if ($count == 0) { |
|||
$arg = "$_"; |
|||
} |
|||
else { |
|||
$arg = $arg . " " . "$_"; |
|||
} |
|||
$count++; |
|||
} |
|||
######### |
|||
# STDIN # |
|||
######### |
|||
if ($commands->{"stdin"}) { |
|||
my $term = Term::ReadLine->new("Simple Shell"); |
|||
my @HISTORY = history(\%commands); |
|||
$term->addhistory(@HISTORY); |
|||
my @history; push(@history,"$arg"); |
|||
print "swim: type exit to finish --stdin\n"; |
|||
my $termcount = 0; |
|||
while ($termcount < 1 ) { |
|||
$_ = $term->readline('swim: ',"$arg"); |
|||
push (@history,$_); |
|||
$termcount++; |
|||
} do { $_ = $term->readline('swim: '); |
|||
push (@history,$_); |
|||
} while $_ ne "exit"; |
|||
$arg = $history[$#history - 1]; |
|||
if ($arg ne $HISTORY[$#HISTORY]) { |
|||
if ($arg =~ m,^[^\w],) { |
|||
$arg =~ s,^\s+(\w+),$1,; |
|||
} |
|||
history_print($arg,\%commands); |
|||
} |
|||
} |
|||
!($commands->{"r"} || $commands{"remove"}) ? |
|||
system "$apt_get install -qs $arg" : |
|||
system "$apt_get remove -qs $arg"; |
|||
} |
|||
##################### |
|||
# INSTALLATION MODE # |
|||
##################### |
|||
# provides optional --stdin to change packages to be installed |
|||
# from the command line |
|||
else { |
|||
my $arg; |
|||
my $count = 0; |
|||
foreach (@PACKAGES) { |
|||
if ($count == 0) { |
|||
$arg = "$_"; |
|||
} |
|||
else { |
|||
$arg = $arg . " " . "$_"; |
|||
} |
|||
$count++; |
|||
} |
|||
######### |
|||
# STDIN # |
|||
######### |
|||
if ($commands->{"stdin"}) { |
|||
my $term = Term::ReadLine->new("Simple Shell"); |
|||
my @HISTORY = history(\%commands); |
|||
$term->addhistory(@HISTORY); |
|||
my @history; push(@history,"$arg"); |
|||
print "swim: type exit to finish --stdin\n"; |
|||
my $termcount = 0; |
|||
while ($termcount < 1 ) { |
|||
$_ = $term->readline('swim: ',"$arg"); |
|||
push (@history,$_); |
|||
$termcount++; |
|||
} do { $_ = $term->readline('swim: '); |
|||
push (@history,$_); |
|||
} while $_ ne "exit"; |
|||
$arg = $history[$#history - 1]; |
|||
if ("$arg" ne "$HISTORY[$#HISTORY]") { |
|||
if ($arg =~ m,^[^\w],) { |
|||
$arg =~ s,^\s+(\w+),$1,; |
|||
} |
|||
history_print($arg,\%commands); |
|||
} |
|||
} |
|||
####### |
|||
# XYZ # |
|||
####### |
|||
if (!($commands->{"ftp"} || $commands->{"purge"})) { |
|||
if (!$commands->{"y"}) { |
|||
if (!$commands->{"nz"}) { |
|||
!($commands->{"r"} || $commands{"remove"}) ? |
|||
system "$apt_get install $arg" : |
|||
system "$apt_get remove $arg"; |
|||
} |
|||
else { |
|||
!($commands->{"r"} || $commands{"remove"}) ? |
|||
system "$apt_get -d install $arg" : |
|||
system "$apt_get remove $arg"; |
|||
} |
|||
} |
|||
else { |
|||
if (!$commands->{"nz"}) { |
|||
!($commands->{"r"} || $commands{"remove"}) ? |
|||
system "$apt_get install -y $arg" : |
|||
system "$apt_get remove -y $arg"; |
|||
} |
|||
else { |
|||
# not that the y does anything |
|||
!($commands->{"r"} || $commands{"remove"}) ? |
|||
system "$apt_get install -y -d $arg" : |
|||
system "$apt_get remove -y $arg"; |
|||
} |
|||
} |
|||
} |
|||
####### |
|||
# FTP # |
|||
####### |
|||
elsif ($commands->{"ftp"}) { |
|||
require SWIM::Qftp; |
|||
SWIM::Qftp->import(qw(qftp)); |
|||
qftp($arg,\%commands); |
|||
} |
|||
|
|||
################## |
|||
# PURGE & REMOVE # |
|||
################## |
|||
elsif ($commands->{"purge"} || $commands->{"remove"} || $commands->{"r"}) { |
|||
purge($arg,\%commands); |
|||
} |
|||
|
|||
# this is a good time to return the versions, too, as well as |
|||
# including any NEW packages from --db and --ndb. We'll assume $arg |
|||
# from qftp will never be too large |
|||
if (!$commands->{"n"}) { |
|||
dbi(\%commands); |
|||
@PACKAGES = map($db{$_},(@PACKAGES = split(/\s/,$arg))); |
|||
} |
|||
else { |
|||
ndb(\%commands); |
|||
@PACKAGES = map($db{$_},(@PACKAGES = split(/\s/,$arg))); |
|||
} |
|||
untie %db; |
|||
} |
|||
|
|||
} # end sub xyz |
|||
|
|||
|
|||
# Remove (keep configuration files) or purge everything for each package. |
|||
sub purge { |
|||
|
|||
my ($arg,$commands) = @_; |
|||
|
|||
if (!$commands->{"n"}) { |
|||
if ($commands->{"purge"}) { |
|||
system "$dpkg --purge $arg"; |
|||
|
|||
} |
|||
elsif ($commands->{"remove"} || $commands->{"r"}) { |
|||
system "$dpkg -r $arg"; |
|||
} |
|||
} |
|||
else { |
|||
print "swim: "; |
|||
print "-r " if defined $commands->{"r"}; |
|||
print "--remove " if defined $commands->{"remove"}; |
|||
print "--purge " if defined $commands->{"purge"}; |
|||
print "can only be used with installed packages\n"; |
|||
} |
|||
|
|||
|
|||
} # end sub purge |
|||
|
|||
|
|||
# find the history file and return proper output |
|||
sub history { |
|||
|
|||
my($commands) = @_; |
|||
my %commands = %$commands; |
|||
|
|||
my($arch,$dist) = which_archdist(\%commands); |
|||
my($place) = finddb(\%commands); |
|||
my $swim_history; |
|||
if ($commands->{"n"}) { |
|||
$swim_history = "$place/.nswim$arch$dist" . "_history"; |
|||
} |
|||
else { |
|||
$swim_history = "$place/.swim" . "_history"; |
|||
} |
|||
open(HISTORY,"$swim_history") or exit; |
|||
my (@HISTORY,$line); |
|||
while (<HISTORY>) { |
|||
chomp; |
|||
foreach (split(/\s/,$_)) { |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
} |
|||
push(@HISTORY,$line); undef $line; |
|||
} |
|||
|
|||
return @HISTORY; |
|||
|
|||
} # end sub history |
|||
|
|||
# append history if it has changed |
|||
sub history_print { |
|||
|
|||
my($arg,$commands) = @_; |
|||
my %commands = %$commands; |
|||
my($arch,$dist) = which_archdist(\%commands); |
|||
my($place) = finddb(\%commands); |
|||
my $swim_history; |
|||
if ($commands->{"n"}) { |
|||
$swim_history = "$place/.nswim$arch$dist" . "_history"; |
|||
} |
|||
else { |
|||
$swim_history = "$place/.swim" . "_history"; |
|||
} |
|||
open(HISTORY,"$swim_history") or exit; |
|||
my @HISTORY = <HISTORY>; |
|||
close(HISTORY); |
|||
if ($#HISTORY < $HISTORY - 1) { |
|||
push(@HISTORY,"$arg\n"); |
|||
} |
|||
else { |
|||
shift(@HISTORY); |
|||
push(@HISTORY,"$arg\n"); |
|||
} |
|||
open(HISTORY,">$swim_history") or exit; |
|||
print HISTORY @HISTORY; |
|||
|
|||
|
|||
} # end sub history_print |
|||
|
|||
1; |
|||
@ -0,0 +1,850 @@ |
|||
# Package administration and research tool for Debian |
|||
# Copyright (C) 1999-2000 Jonathan D. Rosenbaum |
|||
|
|||
# This program is free software; you can redistribute it and/or modify |
|||
# it under the terms of the GNU General Public License as published by |
|||
# the Free Software Foundation; either version 2 of the License, or |
|||
# (at your option) any later version. |
|||
|
|||
# This program is distributed in the hope that it will be useful, |
|||
# but WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
# GNU General Public License for more details. |
|||
|
|||
# You should have received a copy of the GNU General Public License |
|||
# along with this program; if not, write to the Free Software |
|||
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|||
|
|||
|
|||
package SWIM::Search; |
|||
use vars qw(@ISA @EXPORT); |
|||
use strict; |
|||
use SWIM::Global; |
|||
use SWIM::Conf; |
|||
use SWIM::DB_Library qw(:Search); |
|||
use SWIM::Library; |
|||
use Exporter; |
|||
@ISA = qw(Exporter); |
|||
@EXPORT = qw(search); |
|||
|
|||
|
|||
# search() and searchdf() = mm --search, --ps --refinesearch --research |
|||
|
|||
=pod |
|||
|
|||
This searches for keyword(s) amongst the descriptions, and then |
|||
shows the packages which match, a little more sophisticated than |
|||
swim -qait | grep <keyword>, besides you can use perl regexping |
|||
notation when you do your search. By default the description is |
|||
automatically presented, but a list of package names which match is kept |
|||
which can then be queried using -S in the normal fashion, until the |
|||
next search. |
|||
|
|||
=cut |
|||
|
|||
sub search { |
|||
|
|||
my ($search_mem,$commands,$num,$argv) = @_; |
|||
|
|||
$argument = "/."; |
|||
my %commands = %$commands; |
|||
|
|||
my %morethanone; |
|||
my $keyword = $commands->{"search"}; |
|||
if ($commands->{"search"}) { |
|||
$keyword = $commands->{"search"}; |
|||
} |
|||
elsif ($commands->{"research"}) { |
|||
$keyword = $commands->{"research"}; |
|||
} |
|||
elsif ($commands->{"refinesearch"}) { |
|||
$keyword = $commands->{"refinesearch"}; |
|||
} |
|||
elsif ($commands->{"powersearch"} || $commands->{"ps"}) { |
|||
if ($commands->{"powersearch"}) { |
|||
$keyword = $commands->{"powersearch"}; |
|||
} |
|||
if ($commands->{"ps"}) { |
|||
$keyword = $commands->{"ps"}; |
|||
} |
|||
} |
|||
my $count = 0; |
|||
|
|||
my ($search_file, $search_dir); |
|||
if (!$commands->{"n"}) { |
|||
ib(\%commands); |
|||
dbi(\%commands); |
|||
if ($commands->{"ps"} || $commands->{"powersearch"}) { |
|||
($search_file,$search_dir) = searchdf(\%commands); |
|||
if (-B $search_file && -B $search_dir) { |
|||
$search_file = "$gzip -dc $search_file|"; |
|||
$search_dir = "$gzip -dc $search_dir|"; |
|||
} |
|||
} |
|||
} |
|||
##### |
|||
# N # |
|||
##### |
|||
else { |
|||
my $return = nib(\%commands); |
|||
if (!defined $return) { |
|||
untie %ib; |
|||
nsb(\%commands); |
|||
$ib{"/."} = $nsb{"/."}; |
|||
} |
|||
ndb(\%commands); |
|||
if ($commands->{"ps"} || $commands->{"powersearch"}) { |
|||
($search_file,$search_dir) = searchdf(\%commands); |
|||
if (!-e $search_file || !-e $search_dir) { |
|||
delete $commands{"ps"} if defined $commands->{"ps"}; |
|||
delete $commands{"powersearch"} if defined $commands->{"powersearch"}; |
|||
} |
|||
if (-B $search_file && -B $search_dir) { |
|||
$search_file = "$gzip -dc $search_file|"; |
|||
$search_dir = "$gzip -dc $search_dir|"; |
|||
} |
|||
} |
|||
} |
|||
|
|||
########## |
|||
# # |
|||
# SEARCH # |
|||
# # |
|||
########## |
|||
# Here starts --search & optionally -g |
|||
my ($line,@HISTORY); |
|||
if ($commands->{"search"}) { |
|||
my @stuff; |
|||
if ($commands->{"g"}) { |
|||
# check for some errors |
|||
if ($commands->{"a"} || $commands->{"f"} || $commands->{"dir"}) { |
|||
print "swim: one type of query/verify may be performed at a time\n"; |
|||
exit; |
|||
} |
|||
# extract the packages related to the group. |
|||
if (!$commands->{"n"}) { |
|||
gb(\%commands); |
|||
} |
|||
else { |
|||
ngb(\%commands) |
|||
} |
|||
if ($#ARGV != -1) { |
|||
foreach (@ARGV) { |
|||
$argument = $_; |
|||
if (defined $gb{$argument}) { |
|||
@stuff = split(/\s/, $gb{$argument}); |
|||
} |
|||
else { |
|||
print "group $argument does not contain any packages\n"; |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
print "swim: no arguments given for query\n"; |
|||
} |
|||
untie %gb; |
|||
} # if ($commands->{"g"}) |
|||
|
|||
# not yet for -g |
|||
if ($commands->{"search"} && !$commands->{"g"}) { |
|||
if (defined $argument) { |
|||
if ($ib{"$argument"}){ |
|||
foreach (split(/\s/, $ib{"$argument"})) { |
|||
if ($keyword =~ /\/i$/) { |
|||
$keyword =~ m,(.*)\/i$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$_} =~ /$1/i) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/m$/) { |
|||
$keyword =~ m,(.*)\/m$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$_} =~ /$1/m ) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/.[im]$/) { |
|||
$keyword =~ m,(.*)\/.[im]$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$_} =~ /$1/im ) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
if (defined $db{$_}) { |
|||
if ($db{$_} =~ /$keyword/) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
print "swim: found $count package(s)\n"; |
|||
#exit; |
|||
} |
|||
if (!defined $line) { |
|||
$line = ""; |
|||
} |
|||
else { |
|||
$line = "$line\n"; |
|||
} |
|||
history($line,$search_mem); |
|||
} |
|||
} |
|||
|
|||
# ok -g |
|||
elsif ($commands->{"search"} && $commands->{"g"}) { |
|||
if (defined @stuff) { |
|||
#unlink("$search_mem"); |
|||
foreach (@stuff) { |
|||
$argument = $_; |
|||
version(\%commands); |
|||
# if we just did a group search we don't want to append it to |
|||
# the .search.deb file. |
|||
if ($keyword =~ /\/i$/) { |
|||
$keyword =~ m,(.*)\/i$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$argument} =~ /$1/i) { |
|||
print "$db{$argument}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$argument); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/m$/) { |
|||
$keyword =~ m,(.*)\/m$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$argument} =~ /$1/m ) { |
|||
print "$db{$argument}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$argument); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/.[im]$/) { |
|||
$keyword =~ m,(.*)\/.[im]$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$argument} =~ /$1/im ) { |
|||
print "$db{$argument}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$argument); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
if (defined $db{$_}) { |
|||
if ($db{$argument} =~ /$keyword/) { |
|||
print "$db{$argument}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$argument); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
print "swim: found $count package(s)\n"; |
|||
if (!defined $line) { |
|||
$line = ""; |
|||
} |
|||
else { |
|||
$line = "$line\n"; |
|||
} |
|||
history($line,$search_mem); |
|||
} |
|||
} |
|||
exit if !($commands->{"stdin"} || $commands->{"x"} || $commands->{"y"} || |
|||
$commands->{"z"} || $commands->{"ftp"}); |
|||
} |
|||
|
|||
############################# |
|||
# # |
|||
# RESEARCH || REFINESEARCH # |
|||
# # |
|||
############################# |
|||
# research time or refining time |
|||
if ($commands->{"research"} || $commands{"refinesearch"}) { |
|||
if ($commands->{"g"}) { |
|||
print "swim: use -g only with a new search\n"; |
|||
exit; |
|||
} |
|||
foreach (@$argv) { |
|||
if ($keyword =~ /\/i$/) { |
|||
$keyword =~ m,(.*)\/i$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$db{$_}} =~ /$1/i) { |
|||
print "$db{$db{$_}}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/m$/) { |
|||
$keyword =~ m,(.*)\/m$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$db{$_}} =~ /$1/m ) { |
|||
print "$db{$db{$_}}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/.[im]$/) { |
|||
$keyword =~ m,(.*)\/.[im]$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$db{$_}} =~ /$1/im ) { |
|||
print "$db{$db{$_}}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
if (defined $db{$_}) { |
|||
if ($db{$db{$_}} =~ /$keyword/) { |
|||
print "$db{$db{$_}}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
print "swim: found $count package(s)\n"; |
|||
if (!defined $line) { |
|||
$line = ""; |
|||
} |
|||
else { |
|||
$line = "$line\n"; |
|||
} |
|||
# refine the search |
|||
if ($commands->{"refinesearch"}) { |
|||
open(HISTORY, "$search_mem") || exit; |
|||
my @HISTORY = reverse <HISTORY>; |
|||
close(HISTORY); |
|||
$HISTORY[$num - 1] = $line; |
|||
open(HISTORY, ">$search_mem") || exit; |
|||
print HISTORY reverse @HISTORY; |
|||
close(HISTORY); |
|||
} |
|||
exit if !($commands->{"stdin"} || $commands->{"x"} || |
|||
$commands->{"y"} || $commands->{"z"} || $commands->{"ftp"}); |
|||
} |
|||
|
|||
|
|||
################ |
|||
# # |
|||
# POWERSEARCH # |
|||
# # |
|||
################ |
|||
# powersearch with no -g option since this searchs all files. |
|||
if (($commands->{"powersearch"} || $commands->{"ps"}) && !$commands->{"g"}) { |
|||
open(FLATFILE, "$search_file"); |
|||
while (<FLATFILE>) { |
|||
chomp $_; |
|||
if ($keyword =~ /\/i$/) { |
|||
$keyword =~ m,(.*)\/i$,; |
|||
if ($_ =~ /$1/i) { |
|||
if (defined $ib{$_}) { |
|||
$morethanone{$ib{$_}}++; |
|||
if ($morethanone{$ib{$_}} == 1) { |
|||
print "$db{$ib{$_}}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$ib{$_}); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$ib{$_}))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$ib{$_}))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/m$/) { |
|||
$keyword =~ m,(.*)\/m$,; |
|||
if ($_ =~ /$1/m ) { |
|||
if (defined $ib{$_}) { |
|||
$morethanone{$ib{$_}}++; |
|||
if ($morethanone{$ib{$_}} == 1) { |
|||
print "$db{$ib{$_}}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$ib{$_}); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$ib{$_}))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$ib{$_}))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/.[im]$/) { |
|||
$keyword =~ m,(.*)\/.[im]$,; |
|||
if ($_ =~ /$1/im ) { |
|||
if (defined $ib{$_}) { |
|||
$morethanone{$ib{$_}}++; |
|||
if ($morethanone{$ib{$_}} == 1) { |
|||
print "$db{$ib{$_}}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$ib{$_}); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$ib{$_}))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$ib{$_}))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
if ($_ =~ /$keyword/) { |
|||
if (defined $ib{$_}) { |
|||
$morethanone{$ib{$_}}++; |
|||
if ($morethanone{$ib{$_}} == 1) { |
|||
# ofcourse this won't work if a dir filters through. |
|||
# hummm. |
|||
#print "HUMM DIR $_ ", $ib{$_}, "\n"; |
|||
print "$db{$ib{$_}}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$ib{$_}); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$ib{$_}))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$ib{$_}))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} # while (<FLATFILE>) |
|||
close(FLATFILE); |
|||
|
|||
####### |
|||
# DIR # |
|||
####### |
|||
# Somebody wants to do a rare --dir search, but this is done by default |
|||
# for the n* because often enough more than one package shares one |
|||
# file. |
|||
if ($commands->{"dir"} || $commands{"n"}) { |
|||
open(FLATFILE, "$search_dir"); |
|||
while (<FLATFILE>) { |
|||
chomp $_; |
|||
if ($keyword =~ /\/i$/) { |
|||
$keyword =~ m,(.*)\/i$,; |
|||
if ($_ =~ /$1/i) { |
|||
if (defined $ib{$_}) { |
|||
$morethanone{$ib{$_}}++; |
|||
if ($morethanone{$ib{$_}} == 1) { |
|||
my @dir = split(/\s/,$ib{$_}); |
|||
foreach (@dir) { |
|||
$morethanone{$_}++; |
|||
if (defined $morethanone{$_}) { |
|||
if ($morethanone{$_} == 1) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/m$/) { |
|||
$keyword =~ m,(.*)\/m$,; |
|||
if ($_ =~ /$1/m ) { |
|||
if (defined $ib{$_}) { |
|||
$morethanone{$ib{$_}}++; |
|||
if ($morethanone{$ib{$_}} == 1) { |
|||
my @dir = split(/\s/,$ib{$_}); |
|||
foreach (@dir) { |
|||
$morethanone{$_}++; |
|||
if (defined $morethanone{$_}) { |
|||
if ($morethanone{$_} == 1) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/.[im]$/) { |
|||
$keyword =~ m,(.*)\/.[im]$,; |
|||
if ($_ =~ /$1/im ) { |
|||
if (defined $ib{$_}) { |
|||
$morethanone{$ib{$_}}++; |
|||
if ($morethanone{$ib{$_}} == 1) { |
|||
my @dir = split(/\s/,$ib{$_}); |
|||
foreach (@dir) { |
|||
$morethanone{$_}++; |
|||
if (defined $morethanone{$_}) { |
|||
if ($morethanone{$_} == 1) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
if ($_ =~ /$keyword/) { |
|||
if (defined $ib{$_}) { |
|||
#my @dir = split(/\s/,$ib{$_}); |
|||
#foreach (@dir) { |
|||
$morethanone{$ib{$_}}++; |
|||
if ($morethanone{$ib{$_}} == 1) { |
|||
my @dir = split(/\s/,$ib{$_}); |
|||
foreach (@dir) { |
|||
$morethanone{$_}++; |
|||
if (defined $morethanone{$_}) { |
|||
if ($morethanone{$_} == 1) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} # while (<FLATFILE>) |
|||
close(FLATFILE); |
|||
} |
|||
|
|||
################# |
|||
# NORMAL SEARCH # |
|||
################# |
|||
# now we can do a normal search for the powersearch |
|||
if (defined $argument) { |
|||
if ($ib{"$argument"}){ |
|||
foreach (split(/\s/, $ib{$argument})) { |
|||
if ($keyword =~ /\/i$/) { |
|||
$morethanone{$_}++; |
|||
if ($morethanone{$_} == 1) { |
|||
$keyword =~ m,(.*)\/i$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$_} =~ /$1/i) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/m$/) { |
|||
$morethanone{$_}++; |
|||
if ($morethanone{$_} == 1) { |
|||
$keyword =~ m,(.*)\/m$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$_} =~ /$1/m ) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
elsif ($keyword =~ /\/.[im]$/) { |
|||
$morethanone{$_}++; |
|||
if ($morethanone{$_} == 1) { |
|||
$keyword =~ m,(.*)\/.[im]$,; |
|||
if (defined $db{$_}) { |
|||
if ($db{$_} =~ /$1/im ) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
$morethanone{$_}++; |
|||
if ($morethanone{$_} == 1) { |
|||
if (defined $db{$_}) { |
|||
if ($db{$_} =~ /$keyword/) { |
|||
print "$db{$_}\n" if !$commands->{"no"}; |
|||
push(@PACKAGES,$_); |
|||
if (!defined $line) { |
|||
$line = (split(/_/,$_))[0]; |
|||
} |
|||
else { |
|||
$line = $line . " " . (split(/_/,$_))[0]; |
|||
} |
|||
$count++; |
|||
} |
|||
} |
|||
} |
|||
} |
|||
} |
|||
print "swim: found $count package(s)\n"; |
|||
if (!defined $line) { |
|||
$line = ""; |
|||
} |
|||
else { |
|||
$line = "$line\n"; |
|||
} |
|||
history($line,$search_mem); |
|||
#exit if !($commands->{"stdin"} || $commands->{"x"} || |
|||
# $commands->{"y"} || $commands->{"z"} || $commands->{"ftp"}); |
|||
} |
|||
} |
|||
} |
|||
|
|||
untie %ib; |
|||
untie %db; |
|||
|
|||
|
|||
} # end sub search |
|||
|
|||
# for finding the search flatfiles |
|||
sub searchdf { |
|||
|
|||
my ($commands) = @_; |
|||
|
|||
my($sfile,$sdir); |
|||
if (!$commands->{"n"}) { |
|||
my ($ramdisk) = ram_on(); |
|||
if ($ramdisk eq 1) { |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$sfile = "$parent$library/searchindex.deb"; |
|||
$sdir = "$parent$library/dirindex.deb"; |
|||
return ($sfile,$sdir); |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$sfile = "$parent$base/searchindex.deb"; |
|||
$sdir = "$parent$base/dirindex.deb"; |
|||
return ($sfile,$sdir); |
|||
} |
|||
} |
|||
elsif ($ramdisk eq "yes") { |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$sfile = "$parent$library/dramdisk/searchindex.deb.gz"; |
|||
$sdir = "$parent$library/dramdisk/dirindex.deb.gz"; |
|||
if (!-e $sdir && !-e $sfile) { |
|||
print "swim: found wrong database(s), use --ramdiskoff\n"; |
|||
exit; |
|||
} |
|||
return ($sfile,$sdir); |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$sfile = "$parent$base/dramdisk/searchindex.deb.gz"; |
|||
$sdir = "$parent$base/dramdisk/dirindex.deb.gz"; |
|||
if (!-e $sdir && !-e $sfile) { |
|||
print "swim: found wrong database(s), use --ramdiskoff\n"; |
|||
exit; |
|||
} |
|||
return ($sfile,$sdir); |
|||
} |
|||
} |
|||
} |
|||
else { |
|||
my ($ramdisk) = ram_on(); |
|||
my($arch,$dist) = which_archdist(\%commands); |
|||
if ($ramdisk eq 1) { |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$sfile = "$parent$library/nsearchindex$arch$dist.deb"; |
|||
$sdir = "$parent$library/ndirindex$arch$dist.deb"; |
|||
return ($sfile,$sdir); |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$sfile = "$parent$base/nsearchindex$arch$dist.deb"; |
|||
$sdir = "$parent$base/ndirindex$arch$dist.deb"; |
|||
return ($sfile,$sdir); |
|||
} |
|||
} |
|||
elsif ($ramdisk eq "yes") { |
|||
if (($commands->{"dbpath"} && $commands->{"root"}) || |
|||
($commands->{"dbpath"} && !$commands->{"root"}) || |
|||
(!$commands->{"dbpath"} && !$commands->{"root"})) { |
|||
$sfile = "$parent$library/dramdisk/nsearchindex$arch$dist.deb.gz"; |
|||
$sdir = "$parent$library/dramdisk/ndirindex$arch$dist.deb.gz"; |
|||
if (!-e $sdir && !-e $sfile) { |
|||
print "swim: found wrong database(s), use --ramdiskoff\n"; |
|||
exit; |
|||
} |
|||
return ($sfile,$sdir); |
|||
} |
|||
elsif (!$commands->{"dbpath"} && $commands->{"root"}) { |
|||
$sfile = "$parent$base/dramdisk/nsearchindex$arch$dist.deb.gz"; |
|||
$sdir = "$parent$base/dramdisk/ndirindex$arch$dist.deb.gz"; |
|||
if (!-e $sdir && !-e $sfile) { |
|||
print "swim: found wrong database(s), use --ramdiskoff\n"; |
|||
exit; |
|||
} |
|||
return ($sfile,$sdir); |
|||
} |
|||
} |
|||
} |
|||
|
|||
} # end sub searchdf |
|||
|
|||
# print the search out to the right spot on the HISTORY |
|||
# this is just shift and push |
|||
sub history { |
|||
|
|||
my($line,$file) = @_; |
|||
my @HISTORY; |
|||
|
|||
if (-e "$file") { |
|||
open(HISTORY,"$file"); |
|||
@HISTORY = <HISTORY>; |
|||
close(HISTORY); |
|||
if ($#HISTORY < $HISTORY - 1) { |
|||
push(@HISTORY,$line); |
|||
} |
|||
else { |
|||
shift(@HISTORY); |
|||
push(@HISTORY,$line); |
|||
} |
|||
} |
|||
else { |
|||
@HISTORY = $line; |
|||
} |
|||
|
|||
open(HISTORY,">$file") or exit; |
|||
print HISTORY @HISTORY; |
|||
close(HISTORY); |
|||
|
|||
} # end sub history |
|||
|
|||
|
|||
1; |
|||
Loading…
Reference in new issue