summaryrefslogtreecommitdiffstats
path: root/dselect/methods/ftp
diff options
context:
space:
mode:
Diffstat (limited to 'dselect/methods/ftp')
-rw-r--r--dselect/methods/ftp/desc.ftp2
-rwxr-xr-xdselect/methods/ftp/install.pl632
-rw-r--r--dselect/methods/ftp/names1
-rwxr-xr-xdselect/methods/ftp/setup.pl177
-rwxr-xr-xdselect/methods/ftp/update.pl251
5 files changed, 1063 insertions, 0 deletions
diff --git a/dselect/methods/ftp/desc.ftp b/dselect/methods/ftp/desc.ftp
new file mode 100644
index 0000000..accd994
--- /dev/null
+++ b/dselect/methods/ftp/desc.ftp
@@ -0,0 +1,2 @@
+Installation using ftp, you must know one (or more) ftp site(s) and the
+correct directories for the Debian distribution.
diff --git a/dselect/methods/ftp/install.pl b/dselect/methods/ftp/install.pl
new file mode 100755
index 0000000..9966e7a
--- /dev/null
+++ b/dselect/methods/ftp/install.pl
@@ -0,0 +1,632 @@
+#!/usr/bin/perl
+#
+# Copyright © 1996 Andy Guy <awpguy@acs.ucalgary.ca>
+# Copyright © 1998 Martin Schulze <joey@infodrom.north.de>
+# Copyright © 1999, 2009 Raphaël Hertzog <hertzog@debian.org>
+#
+# 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; version 2 of the License.
+#
+# 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, see <https://www.gnu.org/licenses/>.
+
+use strict;
+use warnings;
+
+eval q{
+ pop @INC if $INC[-1] eq '.';
+ use Net::FTP;
+ use File::Path qw(make_path remove_tree);
+ use File::Basename;
+ use File::Find;
+ use Data::Dumper;
+};
+if ($@) {
+ warn "Please install the 'perl' package if you want to use the\n" .
+ "FTP access method of dselect.\n\n";
+ exit 1;
+}
+
+use Dselect::Ftp;
+
+my $ftp;
+
+# exit value
+my $exit = 0;
+
+# deal with arguments
+my $vardir = $ARGV[0];
+my $method = $ARGV[1];
+my $option = $ARGV[2];
+
+if ($option eq 'manual') {
+ print "manual mode not supported yet\n";
+ exit 1;
+}
+#print "vardir: $vardir, method: $method, option: $option\n";
+
+my $methdir = "$vardir/methods/ftp";
+
+# get info from control file
+read_config("$methdir/vars");
+
+chdir "$methdir";
+make_path("$methdir/$CONFIG{dldir}", { mode => 0755 });
+
+
+#Read md5sums already calculated
+my %md5sums;
+if (-f "$methdir/md5sums") {
+ local $/;
+ open(my $md5sums_fh, '<', "$methdir/md5sums")
+ or die "couldn't read file $methdir/md5sums";
+ my $code = <$md5sums_fh>;
+ close $md5sums_fh;
+ my $VAR1; ## no critic (Variables::ProhibitUnusedVariables)
+ my $res = eval $code;
+ if ($@) {
+ die "couldn't eval $methdir/md5sums content: $@\n";
+ }
+ if (ref($res)) { %md5sums = %{$res} }
+}
+
+# get a block
+# returns a ref to a hash containing flds->fld contents
+# white space from the ends of lines is removed and newlines added
+# (no trailing newline).
+# die's if something unexpected happens
+sub getblk {
+ my $fh = shift;
+ my %flds;
+ my $fld;
+ while (<$fh>) {
+ if (length != 0) {
+ FLDLOOP: while (1) {
+ if ( /^(\S+):\s*(.*)\s*$/ ) {
+ $fld = lc($1);
+ $flds{$fld} = $2;
+ while (<$fh>) {
+ if (length == 0) {
+ return %flds;
+ } elsif ( /^(\s.*)$/ ) {
+ $flds{$fld} = $flds{$fld} . "\n" . $1;
+ } else {
+ next FLDLOOP;
+ }
+ }
+ return %flds;
+ } else {
+ die "expected a start of field line, but got:\n$_";
+ }
+ }
+ }
+ }
+ return %flds;
+}
+
+# process status file
+# create curpkgs hash with version (no version implies not currently installed)
+# of packages we want
+print "Processing status file...\n";
+my %curpkgs;
+sub procstatus {
+ my (%flds, $fld);
+ open(my $status_fh, '<', "$vardir/status") or
+ die 'Could not open status file';
+ while (%flds = getblk($status_fh), %flds) {
+ if($flds{'status'} =~ /^install ok/) {
+ my $cs = (split(/ /, $flds{'status'}))[2];
+ if (($cs eq 'not-installed') ||
+ ($cs eq 'half-installed') ||
+ ($cs eq 'config-files')) {
+ $curpkgs{$flds{'package'}} = '';
+ } else {
+ $curpkgs{$flds{'package'}} = $flds{'version'};
+ }
+ }
+ }
+ close($status_fh);
+}
+procstatus();
+
+sub dcmpvers {
+ my($a, $p, $b) = @_;
+ my ($r);
+ $r = system('dpkg', '--compare-versions', "$a", "$p", "$b");
+ $r = $r/256;
+ if ($r == 0) {
+ return 1;
+ } elsif ($r == 1) {
+ return 0;
+ }
+ die "dpkg --compare-versions $a $p $b - failed with $r";
+}
+
+# process package files, looking for packages to install
+# create a hash of these packages pkgname => version, filenames...
+# filename => md5sum, size
+# for all packages
+my %pkgs;
+my %pkgfiles;
+sub procpkgfile {
+ my $fn = shift;
+ my $site = shift;
+ my $dist = shift;
+ my (@files, @sizes, @md5sums, $pkg, $ver, $nfs, $fld);
+ my(%flds);
+ open(my $pkgfile_fh, '<', $fn) or die "could not open package file $fn";
+ while (%flds = getblk($pkgfile_fh), %flds) {
+ $pkg = $flds{'package'};
+ $ver = $curpkgs{$pkg};
+ @files = split(/[\s\n]+/, $flds{'filename'});
+ @sizes = split(/[\s\n]+/, $flds{'size'});
+ @md5sums = split(/[\s\n]+/, $flds{'md5sum'});
+ if (defined($ver) && (($ver eq '') || dcmpvers($ver, 'lt', $flds{'version'}))) {
+ $pkgs{$pkg} = [ $flds{'version'}, [ @files ], $site ];
+ $curpkgs{$pkg} = $flds{'version'};
+ }
+ $nfs = scalar(@files);
+ if(($nfs != scalar(@sizes)) || ($nfs != scalar(@md5sums)) ) {
+ print "Different number of filenames, sizes and md5sums for $flds{'package'}\n";
+ } else {
+ my $i = 0;
+ foreach my $fl (@files) {
+ $pkgfiles{$fl} = [ $md5sums[$i], $sizes[$i], $site, $dist ];
+ $i++;
+ }
+ }
+ }
+ close $pkgfile_fh or die "cannot close package file $fn: $!\n";
+}
+
+print "\nProcessing Package files...\n";
+my ($fn, $i, $j);
+$i = 0;
+foreach my $site (@{$CONFIG{site}}) {
+ $j = 0;
+ foreach my $dist (@{$site->[2]}) {
+ $fn = $dist;
+ $fn =~ tr#/#_#;
+ $fn = "Packages.$site->[0].$fn";
+ if (-f $fn) {
+ print " $site->[0] $dist...\n";
+ procpkgfile($fn,$i,$j);
+ } else {
+ print "Could not find packages file for $site->[0] $dist distribution (re-run Update)\n"
+ }
+ $j++;
+ }
+ $i++;
+}
+
+my $dldir = $CONFIG{dldir};
+# md5sum
+sub md5sum($) {
+ my $fn = shift;
+ my $m = qx(md5sum $fn);
+ $m = (split(' ', $m))[0];
+ $md5sums{"$dldir/$fn"} = $m;
+ return $m;
+}
+
+# construct list of files to get
+# hash of filenames => size of downloaded part
+# query user for each partial file
+print "\nConstructing list of files to get...\n";
+my %downloads;
+my ($dir, @info, @files, $csize, $size);
+my $totsize = 0;
+foreach my $pkg (keys(%pkgs)) {
+ @files = @{$pkgs{$pkg}[1]};
+ foreach my $fn (@files) {
+ #Look for a partial file
+ if (-f "$dldir/$fn.partial") {
+ rename "$dldir/$fn.partial", "$dldir/$fn";
+ }
+ $dir = dirname($fn);
+ if(! -d "$dldir/$dir") {
+ make_path("$dldir/$dir", { mode => 0755 });
+ }
+ @info = @{$pkgfiles{$fn}};
+ $csize = int($info[1]/1024)+1;
+ if(-f "$dldir/$fn") {
+ $size = -s "$dldir/$fn";
+ if($info[1] > $size) {
+ # partial download
+ if (yesno('y', "continue file: $fn (" . nb($size) . '/' .
+ nb($info[1]) . ')')) {
+ $downloads{$fn} = $size;
+ $totsize += $csize - int($size/1024);
+ } else {
+ $downloads{$fn} = 0;
+ $totsize += $csize;
+ }
+ } else {
+ # check md5sum
+ if (! exists $md5sums{"$dldir/$fn"}) {
+ $md5sums{"$dldir/$fn"} = md5sum("$dldir/$fn");
+ }
+ if ($md5sums{"$dldir/$fn"} eq $info[0]) {
+ print "already got: $fn\n";
+ } else {
+ print "corrupted: $fn\n";
+ $downloads{$fn} = 0;
+ }
+ }
+ } else {
+ my $ffn = $fn;
+ $ffn =~ s/binary-[^\/]+/.../;
+ print 'want: ' .
+ $CONFIG{site}[$pkgfiles{$fn}[2]][0] . " $ffn (${csize}k)\n";
+ $downloads{$fn} = 0;
+ $totsize += $csize;
+ }
+ }
+}
+
+my $avsp = qx(df -Pk $dldir| awk '{ print \$4}' | tail -n 1);
+chomp $avsp;
+
+print "\nApproximate total space required: ${totsize}k\n";
+print "Available space in $dldir: ${avsp}k\n";
+
+#$avsp = qx(df -k $::dldir| paste -s | awk '{ print \$11});
+#chomp $avsp;
+
+if($totsize == 0) {
+ print 'Nothing to get.';
+} else {
+ if($totsize > $avsp) {
+ print "Space required is greater than available space,\n";
+ print "you will need to select which items to get.\n";
+ }
+# ask user which files to get
+ if (($totsize > $avsp) ||
+ yesno('n', 'Do you want to select the files to get')) {
+ $totsize = 0;
+ my @files = sort(keys(%downloads));
+ my $def = 'y';
+ foreach my $fn (@files) {
+ my @info = @{$pkgfiles{$fn}};
+ my $csize = int($info[1] / 1024) + 1;
+ my $rsize = int(($info[1] - $downloads{$fn}) / 1024) + 1;
+ if ($rsize + $totsize > $avsp) {
+ print "no room for: $fn\n";
+ delete $downloads{$fn};
+ } else {
+ if(yesno($def, $downloads{$fn}
+ ? "download: $fn ${rsize}k/${csize}k (total = ${totsize}k)"
+ : "download: $fn ${rsize}k (total = ${totsize}k)")) {
+ $def = 'y';
+ $totsize += $rsize;
+ } else {
+ $def = 'n';
+ delete $downloads{$fn};
+ }
+ }
+ }
+ }
+}
+
+sub download() {
+
+ my $i = 0;
+
+ foreach my $site (@{$CONFIG{site}}) {
+
+ my @getfiles = grep { $pkgfiles{$_}[2] == $i } keys %downloads;
+ my @pre_dist = (); # Directory to add before $fn
+
+ #Scan distributions for looking at "(../)+/dir/dir"
+ my ($n,$cp);
+ $cp = -1;
+ foreach (@{$site->[2]}) {
+ $cp++;
+ $pre_dist[$cp] = '';
+ $n = (s{\.\./}{../}g);
+ next if (! $n);
+ if (m<^((?:\.\./){$n}(?:[^/]+/){$n})>) {
+ $pre_dist[$cp] = $1;
+ }
+ }
+
+ if (! @getfiles) { $i++; next; }
+
+ $ftp = do_connect(ftpsite => $site->[0],
+ ftpdir => $site->[1],
+ passive => $site->[3],
+ username => $site->[4],
+ password => $site->[5],
+ useproxy => $CONFIG{use_auth_proxy},
+ proxyhost => $CONFIG{proxyhost},
+ proxylogname => $CONFIG{proxylogname},
+ proxypassword => $CONFIG{proxypassword});
+
+ local $SIG{INT} = sub { die "Interrupted !\n"; };
+
+ my ($rsize, $res, $pre);
+ foreach my $fn (@getfiles) {
+ $pre = $pre_dist[$pkgfiles{$fn}[3]] || '';
+ if ($downloads{$fn}) {
+ $rsize = ${pkgfiles{$fn}}[1] - $downloads{$fn};
+ print "getting: $pre$fn (" . nb($rsize) . '/' .
+ nb($pkgfiles{$fn}[1]) . ")\n";
+ } else {
+ print "getting: $pre$fn (". nb($pkgfiles{$fn}[1]) . ")\n";
+ }
+ $res = $ftp->get("$pre$fn", "$dldir/$fn", $downloads{$fn});
+ if(! $res) {
+ my $r = $ftp->code();
+ print $ftp->message() . "\n";
+ if (!($r == 550 || $r == 450)) {
+ return 1;
+ } else {
+ #Try to find another file or this package
+ print "Looking for another version of the package...\n";
+ my ($dir, $package) = ($fn =~ m{^(.*)/([^/]+)_[^/]+.deb$});
+ my $list = $ftp->ls("$pre$dir");
+ if ($ftp->ok() && ref($list)) {
+ foreach my $file (@{$list}) {
+ if ($file =~ m/($dir\/\Q$package\E_[^\/]+.deb)/i) {
+ print "Package found : $file\n";
+ print "getting: $file (size not known)\n";
+ $res = $ftp->get($file, "$dldir/$1");
+ if (! $res) {
+ $r = $ftp->code();
+ print $ftp->message() . "\n";
+ return 1 if ($r != 550 and $r != 450);
+ }
+ }
+ }
+ }
+ }
+ }
+ # fully got, remove it from list in case we have to re-download
+ delete $downloads{$fn};
+ }
+ $ftp->quit();
+ $i++;
+ }
+ return 0;
+}
+
+# download stuff (protect from ^C)
+if($totsize != 0) {
+ if (yesno('y', "\nDo you want to download the required files")) {
+ DOWNLOAD_TRY: while (1) {
+ print "Downloading files... use ^C to stop\n";
+ eval {
+ if ((download() == 1) &&
+ yesno('y', "\nDo you want to retry downloading at once")) {
+ next DOWNLOAD_TRY;
+ }
+ };
+ if($@ =~ /Interrupted|Timeout/i ) {
+ # close the FTP connection if needed
+ if ((ref($ftp) =~ /Net::FTP/) and ($@ =~ /Interrupted/i)) {
+ $ftp->abort();
+ $ftp->quit();
+ undef $ftp;
+ }
+ print "FTP ERROR\n";
+ if (yesno('y', "\nDo you want to retry downloading at once")) {
+ # get the first $fn that foreach would give:
+ # this is the one that got interrupted.
+ MY_ITER: foreach my $ffn (keys(%downloads)) {
+ $fn = $ffn;
+ last MY_ITER;
+ }
+ my $size = -s "$dldir/$fn";
+ # partial download
+ if (yesno('y', "continue file: $fn (at $size)")) {
+ $downloads{$fn} = $size;
+ } else {
+ $downloads{$fn} = 0;
+ }
+ next DOWNLOAD_TRY;
+ } else {
+ $exit = 1;
+ last DOWNLOAD_TRY;
+ }
+ } elsif ($@) {
+ print "An error occurred ($@) : stopping download\n";
+ }
+ last DOWNLOAD_TRY;
+ }
+ }
+}
+
+# remove duplicate packages (keep latest versions)
+# move half downloaded files out of the way
+# delete corrupted files
+print "\nProcessing downloaded files...(for corrupt/old/partial)\n";
+my %vers; # package => version
+my %files; # package-version => files...
+
+# check a deb or split deb file
+# return 1 if it a deb file, 2 if it is a split deb file
+# else 0
+sub chkdeb($) {
+ my ($fn) = @_;
+ # check to see if it is a .deb file
+ if(!system("dpkg-deb --info $fn 2>&1 >/dev/null && dpkg-deb --contents $fn 2>&1 >/dev/null")) {
+ return 1;
+ } elsif(!system("dpkg-split --info $fn 2>&1 >/dev/null")) {
+ return 2;
+ }
+ return 0;
+}
+sub getdebinfo($) {
+ my ($fn) = @_;
+ my $type = chkdeb($fn);
+ my ($pkg, $ver);
+ if($type == 1) {
+ open(my $pkgfile_fh, '-|', "dpkg-deb --field $fn")
+ or die "cannot create pipe for 'dpkg-deb --field $fn'";
+ my %fields = getblk($pkgfile_fh);
+ close($pkgfile_fh);
+ $pkg = $fields{'package'};
+ $ver = $fields{'version'};
+ return $pkg, $ver;
+ } elsif ( $type == 2) {
+ open(my $pkgfile_fh, '-|', "dpkg-split --info $fn")
+ or die "cannot create pipe for 'dpkg-split --info $fn'";
+ while (<$pkgfile_fh>) {
+ /Part of package:\s*(\S+)/ and $pkg = $1;
+ /\.\.\. version:\s*(\S+)/ and $ver = $1;
+ }
+ close($pkgfile_fh);
+ return $pkg, $ver;
+ }
+ print "could not figure out type of $fn\n";
+ return $pkg, $ver;
+}
+
+# process deb file to make sure we only keep latest versions
+sub prcdeb($$) {
+ my ($dir, $fn) = @_;
+ my ($pkg, $ver) = getdebinfo($fn);
+ if(!defined($pkg) || !defined($ver)) {
+ print "could not get package info from file\n";
+ return 0;
+ }
+ if($vers{$pkg}) {
+ if (dcmpvers($vers{$pkg}, 'eq', $ver)) {
+ $files{$pkg . $ver} = [ $files{$pkg . $ver }, "$dir/$fn" ];
+ } elsif (dcmpvers($vers{$pkg}, 'gt', $ver)) {
+ print "old version\n";
+ unlink $fn;
+ } else { # else $ver is gt current version
+ foreach my $c (@{$files{$pkg . $vers{$pkg}}}) {
+ print "replaces: $c\n";
+ unlink "$vardir/methods/ftp/$dldir/$c";
+ }
+ $vers{$pkg} = $ver;
+ $files{$pkg . $ver} = [ "$dir/$fn" ];
+ }
+ } else {
+ $vers{$pkg} = $ver;
+ $files{$pkg . $ver} = [ "$dir/$fn" ];
+ }
+}
+
+sub prcfile() {
+ my ($fn) = $_;
+ if (-f $fn and $fn ne '.') {
+ my $dir = '.';
+ if (length($File::Find::dir) > length($dldir)) {
+ $dir = substr($File::Find::dir, length($dldir)+1);
+ }
+ print "$dir/$fn\n";
+ if(defined($pkgfiles{"$dir/$fn"})) {
+ my @info = @{$pkgfiles{"$dir/$fn"}};
+ my $size = -s $fn;
+ if($size == 0) {
+ print "zero length file\n";
+ unlink $fn;
+ } elsif($size < $info[1]) {
+ print "partial file\n";
+ rename $fn, "$fn.partial";
+ } elsif(( (exists $md5sums{"$dldir/$fn"})
+ and ($md5sums{"$dldir/$fn"} ne $info[0]) )
+ or
+ (md5sum($fn) ne $info[0])) {
+ print "corrupt file\n";
+ unlink $fn;
+ } else {
+ prcdeb($dir, $fn);
+ }
+ } elsif($fn =~ /.deb$/) {
+ if(chkdeb($fn)) {
+ prcdeb($dir, $fn);
+ } else {
+ print "corrupt file\n";
+ unlink $fn;
+ }
+ } else {
+ print "non-debian file\n";
+ }
+ }
+}
+find(\&prcfile, "$dldir/");
+
+# install .debs
+if (yesno('y', "\nDo you want to install the files fetched")) {
+ print "Installing files...\n";
+ #Installing pre-dependent package before !
+ my (@flds, $package, @filename, $r);
+ while (@flds = qx(dpkg --predep-package), $? == 0) {
+ foreach my $field (@flds) {
+ $field =~ s/\s*\n//;
+ $package = $field if $field =~ s/^Package: //i;
+ @filename = split / +/, $field if $field =~ s/^Filename: //i;
+ }
+ @filename = map { "$dldir/$_" } @filename;
+ next if (! @filename);
+ $r = system('dpkg', '-iB', '--', @filename);
+ if ($r) { print "DPKG ERROR\n"; $exit = 1; }
+ }
+ #Installing other packages after
+ $r = system('dpkg', '-iGREOB', $dldir);
+ if($r) {
+ print "DPKG ERROR\n";
+ $exit = 1;
+ }
+}
+
+sub removeinstalled {
+ my $fn = $_;
+ if (-f $fn and $fn ne '.') {
+ my $dir = '.';
+ if (length($File::Find::dir) > length($dldir)) {
+ $dir = substr($File::Find::dir, length($dldir)+1);
+ }
+ if($fn =~ /.deb$/) {
+ my($pkg, $ver) = getdebinfo($fn);
+ if(!defined($pkg) || !defined($ver)) {
+ print "Could not get info for: $dir/$fn\n";
+ } else {
+ if ($curpkgs{$pkg} and dcmpvers($ver, 'le', $curpkgs{$pkg})) {
+ print "deleting: $dir/$fn\n";
+ unlink $fn;
+ } else {
+ print "leaving: $dir/$fn\n";
+ }
+ }
+ } else {
+ print "non-debian: $dir/$fn\n";
+ }
+ }
+}
+
+# remove .debs that have been installed (query user)
+# first need to reprocess status file
+if (yesno('y', "\nDo you wish to delete the installed package (.deb) files?")) {
+ print "Removing installed files...\n";
+ %curpkgs = ();
+ procstatus();
+ find(\&removeinstalled, "$dldir/");
+}
+
+# remove whole ./debian directory if user wants to
+if (yesno('n', "\nDo you want to remove $dldir directory?")) {
+ remove_tree($dldir);
+}
+
+#Store useful md5sums
+foreach my $file (keys %md5sums) {
+ next if -f $file;
+ delete $md5sums{$file};
+}
+open(my $md5sums_fh, '>', "$methdir/md5sums")
+ or die "can't open $methdir/md5sums in write mode: $!\n";
+print { $md5sums_fh } Dumper(\%md5sums);
+close $md5sums_fh;
+
+exit $exit;
diff --git a/dselect/methods/ftp/names b/dselect/methods/ftp/names
new file mode 100644
index 0000000..6499279
--- /dev/null
+++ b/dselect/methods/ftp/names
@@ -0,0 +1 @@
+60 ftp Install using ftp.
diff --git a/dselect/methods/ftp/setup.pl b/dselect/methods/ftp/setup.pl
new file mode 100755
index 0000000..562a61f
--- /dev/null
+++ b/dselect/methods/ftp/setup.pl
@@ -0,0 +1,177 @@
+#!/usr/bin/perl
+#
+# Copyright © 1996 Andy Guy <awpguy@acs.ucalgary.ca>
+# Copyright © 1998 Martin Schulze <joey@infodrom.north.de>
+# Copyright © 1999, 2009 Raphaël Hertzog <hertzog@debian.org>
+#
+# 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; version 2 of the License.
+#
+# 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, see <https://www.gnu.org/licenses/>.
+
+use strict;
+use warnings;
+
+eval q{
+ pop @INC if $INC[-1] eq '.';
+ use Net::FTP;
+};
+if ($@) {
+ warn "Please install the 'perl' package if you want to use the\n" .
+ "FTP access method of dselect.\n\n";
+ exit 1;
+}
+use Dselect::Ftp;
+
+# deal with arguments
+my $vardir = $ARGV[0];
+my $method = $ARGV[1];
+my $option = $ARGV[2];
+
+if ($option eq 'manual') {
+ print "Manual package installation.\n";
+ exit 0;
+}
+#print "vardir: $vardir, method: $method, option: $option\n";
+
+#Defaults
+my $arch = qx(dpkg --print-architecture);
+$arch='i386' if $?;
+chomp $arch;
+
+my $logname = qx(whoami);
+chomp $logname;
+my $host = qx(cat /etc/mailname || dnsdomainname);
+chomp $host;
+
+$CONFIG{dldir} = 'debian';
+$CONFIG{use_auth_proxy} = 0;
+$CONFIG{proxyhost} = '';
+$CONFIG{proxylogname} = $logname;
+$CONFIG{proxypassword} = '';
+
+my $methdir = "$vardir/methods/ftp";
+my $exit = 0;
+my $problem = 0;
+
+if (-f "$methdir/vars") {
+ read_config("$methdir/vars");
+}
+
+chdir "$methdir";
+if (! -d 'debian') {
+ mkdir 'debian', 0755;
+}
+# get info from user
+
+$| = 1;
+
+print <<"EOM";
+
+You must supply an ftp site, use of passive mode, username, password,
+path to the debian directory,list of distributions you are interested
+in and place to download the binary package files to (relative to
+/var/lib/dpkg/methods/ftp). You can add as much sites as you like. Later
+entries will always override older ones.
+
+Supply "?" as a password to be asked each time you connect.
+
+Eg: ftp site: ftp.debian.org
+ passive: y
+ username: anonymous
+ password: $logname\@$host
+ ftp dir: /debian
+ distributions: dists/stable/main dists/stable/contrib
+ download dir: debian
+
+You may have to use an authenticated FTP proxy in order to reach the
+FTP site:
+
+Eg: use auth proxy: y
+ proxy: proxy.isp.com
+ proxy account: $CONFIG{proxylogname}
+ proxy password: ?
+EOM
+
+if (! $CONFIG{done}) {
+ view_mirrors() if (yesno('y', 'Would you like to see a list of ftp mirrors'));
+ add_site();
+}
+edit_config($methdir);
+
+my $ftp;
+sub download() {
+ foreach (@{$CONFIG{site}}) {
+
+ $ftp = do_connect(ftpsite => $_->[0],
+ ftpdir => $_->[1],
+ passive => $_->[3],
+ username => $_->[4],
+ password => $_->[5],
+ useproxy => $CONFIG{use_auth_proxy},
+ proxyhost => $CONFIG{proxyhost},
+ proxylogname => $CONFIG{proxylogname},
+ proxypassword => $CONFIG{proxypassword});
+
+ my @dists = @{$_->[2]};
+
+ foreach my $dist (@dists) {
+ my $dir = "$dist/binary-$arch";
+ print "Checking $dir...\n";
+# if (!$ftp->pasv()) { print $ftp->message . "\n"; die 'error'; }
+ my @dirlst = $ftp->ls("$dir/");
+ my $got_pkgfile = 0;
+
+ foreach my $line (@dirlst) {
+ if($line =~ /Packages/) {
+ $got_pkgfile=1;
+ }
+ }
+ if( !$got_pkgfile) {
+ print "Warning: Could not find a Packages file in $dir\n",
+ "This may not be a problem if the directory is a symbolic link\n";
+ $problem=1;
+ }
+ }
+ print "Closing ftp connection...\n";
+ $ftp->quit();
+ }
+}
+
+# download stuff (protect from ^C)
+print "\nUsing FTP to check directories...(stop with ^C)\n\n";
+eval {
+ local $SIG{INT} = sub {
+ die "interrupted!\n";
+ };
+ download();
+};
+if($@) {
+ $ftp->quit();
+ print 'FTP ERROR - ';
+ if ($@ eq 'connect') {
+ print "config was untested\n";
+ } else {
+ print "$@\n";
+ }
+ $exit = 1;
+};
+
+# output new vars file
+$CONFIG{done} = 1;
+store_config("$methdir/vars");
+chmod 0600, "$methdir/vars";
+
+if($exit || $problem) {
+ print "Press <enter> to continue\n";
+ <STDIN>;
+}
+
+exit $exit;
diff --git a/dselect/methods/ftp/update.pl b/dselect/methods/ftp/update.pl
new file mode 100755
index 0000000..a40f6f0
--- /dev/null
+++ b/dselect/methods/ftp/update.pl
@@ -0,0 +1,251 @@
+#!/usr/bin/perl
+#
+# Copyright © 1996 Andy Guy <awpguy@acs.ucalgary.ca>
+# Copyright © 1998 Martin Schulze <joey@infodrom.north.de>
+# Copyright © 1999, 2009 Raphaël Hertzog <hertzog@debian.org>
+#
+# 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; version 2 of the License.
+#
+# 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, see <https://www.gnu.org/licenses/>.
+
+use strict;
+use warnings;
+
+eval q{
+ pop @INC if $INC[-1] eq '.';
+ use Net::FTP;
+};
+if ($@) {
+ warn "Please install the 'perl' package if you want to use the\n" .
+ "FTP access method of dselect.\n\n";
+ exit 1;
+}
+
+use Dselect::Ftp;
+
+# deal with arguments
+my $vardir = $ARGV[0];
+my $method = $ARGV[1];
+my $option = $ARGV[2];
+
+if ($option eq 'manual') {
+ print "Enter package file names or a blank line to finish\n";
+ while(1) {
+ print 'Enter package file name:';
+ my $fn = <STDIN>;
+ chomp $fn;
+ if ($fn eq '') {
+ exit 0;
+ }
+ if ( -f $fn ) {
+ system('dpkg', '--merge-avail', $fn);
+ } else {
+ print "Could not find $fn, try again\n";
+ }
+ };
+};
+
+#print "vardir: $vardir, method: $method, option: $option\n";
+
+my $arch = qx(dpkg --print-architecture);
+$arch='i386' if $?;
+chomp $arch;
+my $exit = 0;
+
+# get info from control file
+read_config("$vardir/methods/ftp/vars");
+
+chdir "$vardir/methods/ftp";
+
+print "Getting Packages files...(stop with ^C)\n\n";
+
+my @pkgfiles;
+my $ftp;
+my $packages_modified = 0;
+
+sub download {
+foreach (@{$CONFIG{site}}) {
+
+ my $site = $_;
+
+ $ftp = do_connect(ftpsite => $_->[0],
+ ftpdir => $_->[1],
+ passive => $_->[3],
+ username => $_->[4],
+ password => $_->[5],
+ useproxy => $CONFIG{use_auth_proxy},
+ proxyhost => $CONFIG{proxyhost},
+ proxylogname => $CONFIG{proxylogname},
+ proxypassword => $CONFIG{proxypassword});
+
+ my @dists = @{$_->[2]};
+ PACKAGE:
+ foreach my $dist (@dists) {
+ my $dir = "$dist/binary-$arch";
+ my $must_get = 0;
+ my $newest_pack_date;
+
+ # check existing Packages on remote site
+ print "\nChecking for Packages file... ";
+ $newest_pack_date = do_mdtm ($ftp, "$dir/Packages.gz");
+ if (defined $newest_pack_date) {
+ print "$dir/Packages.gz\n";
+ } else {
+ $dir = "$dist";
+ $newest_pack_date = do_mdtm ($ftp, "$dir/Packages.gz");
+ if (defined $newest_pack_date) {
+ print "$dir/Packages.gz\n";
+ } else {
+ print "Couldn't find Packages.gz in $dist/binary-$arch or $dist; ignoring.\n";
+ print "Your setup is probably wrong, check the distributions directories,\n";
+ print "and try with passive mode enabled/disabled (if you use a proxy/firewall)\n";
+ next PACKAGE;
+ }
+ }
+
+ # we now have $dir set to point to an existing Packages.gz file
+
+ # check if we already have a Packages file (and get its date)
+ $dist =~ tr/\//_/;
+ my $file = "Packages.$site->[0].$dist";
+
+ # if not
+ if (! -f $file) {
+ # must get one
+# print "No Packages here; must get it.\n";
+ $must_get = 1;
+ } else {
+ # else check last modification date
+ my @pack_stat = stat($file);
+ if($newest_pack_date > $pack_stat[9]) {
+# print "Packages has changed; must get it.\n";
+ $must_get = 1;
+ } elsif ($newest_pack_date < $pack_stat[9]) {
+ print " Our file is newer than theirs; skipping.\n";
+ } else {
+ print " Already up-to-date; skipping.\n";
+ }
+ }
+
+ if ($must_get) {
+ -f 'Packages.gz' and unlink 'Packages.gz';
+ -f 'Packages' and unlink 'Packages';
+ my $size = 0;
+
+ TRY_GET_PACKAGES:
+ while (1) {
+ if ($size) {
+ print ' Continuing ';
+ } else {
+ print ' Getting ';
+ }
+ print "Packages file from $dir...\n";
+ eval {
+ if ($ftp->get("$dir/Packages.gz", 'Packages.gz', $size)) {
+ if (system('gunzip', 'Packages.gz')) {
+ print " Couldn't gunzip Packages.gz, stopped";
+ die 'error';
+ }
+ } else {
+ print " Couldn't get Packages.gz from $dir !!! Stopped.";
+ die 'error';
+ }
+ };
+ if ($@) {
+ $size = -s 'Packages.gz';
+ if (ref($ftp)) {
+ $ftp->abort();
+ $ftp->quit();
+ };
+ if (yesno ('y', "Transfer failed at $size: retry at once")) {
+ $ftp = do_connect(ftpsite => $site->[0],
+ ftpdir => $site->[1],
+ passive => $site->[3],
+ username => $site->[4],
+ password => $site->[5],
+ useproxy => $CONFIG{use_auth_proxy},
+ proxyhost => $CONFIG{proxyhost},
+ proxylogname => $CONFIG{proxylogname},
+ proxypassword => $CONFIG{proxypassword});
+
+ if ($newest_pack_date != do_mdtm ($ftp, "$dir/Packages.gz")) {
+ print ("Packages file has changed !\n");
+ $size = 0;
+ }
+ next TRY_GET_PACKAGES;
+ } else {
+ die 'error';
+ }
+ }
+ last TRY_GET_PACKAGES;
+ }
+
+ if (!rename 'Packages', "Packages.$site->[0].$dist") {
+ print " Couldn't rename Packages to Packages.$site->[0].$dist";
+ die 'error';
+ } else {
+ # set local Packages file to same date as the one it mirrors
+ # to allow comparison to work.
+ utime $newest_pack_date, $newest_pack_date, "Packages.$site->[0].$dist";
+ $packages_modified = 1;
+ }
+ }
+ push @pkgfiles, "Packages.$site->[0].$dist";
+ }
+ $ftp->quit();
+ }
+}
+
+eval {
+ local $SIG{INT} = sub {
+ die "interrupted!\n";
+ };
+ download();
+};
+if($@) {
+ $ftp->quit() if (ref($ftp));
+ if($@ =~ /timeout/i) {
+ print "FTP TIMEOUT\n";
+ } else {
+ print "FTP ERROR - $@\n";
+ }
+ $exit = 1;
+};
+
+# Don't clear if nothing changed.
+if ($packages_modified) {
+ print <<'EOM';
+
+It is a good idea to clear the available list of old packages.
+However if you have only downloaded a Package files from non-main
+distributions you might not want to do this.
+
+EOM
+ if (yesno ('y', 'Do you want to clear available list')) {
+ print "Clearing...\n";
+ if (system('dpkg', '--clear-avail')) {
+ print 'dpkg --clear-avail failed.';
+ die 'error';
+ }
+ }
+}
+
+if (!$packages_modified) {
+ print "No Packages files was updated.\n";
+} else {
+ foreach my $file (@pkgfiles) {
+ if (system('dpkg', '--merge-avail', $file)) {
+ print "Dpkg merge available failed on $file";
+ $exit = 1;
+ }
+ }
+}
+exit $exit;
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-28 02:15:20 +0000