summaryrefslogtreecommitdiffstats
path: root/dselect/methods/Dselect
diff options
context:
space:
mode:
authorDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-15 18:35:28 +0000
committerDaniel Baumann <daniel.baumann@progress-linux.org>2024-04-15 18:35:28 +0000
commitea314d2f45c40a006c0104157013ab4b857f665f (patch)
tree3ef2971cb3675c318b8d9effd987854ad3f6d3e8 /dselect/methods/Dselect
parentInitial commit. (diff)
downloaddpkg-ea314d2f45c40a006c0104157013ab4b857f665f.tar.xz
dpkg-ea314d2f45c40a006c0104157013ab4b857f665f.zip
Adding upstream version 1.22.4.upstream/1.22.4
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to 'dselect/methods/Dselect')
-rw-r--r--dselect/methods/Dselect/Method.pm267
-rw-r--r--dselect/methods/Dselect/Method/Ftp.pm232
2 files changed, 499 insertions, 0 deletions
diff --git a/dselect/methods/Dselect/Method.pm b/dselect/methods/Dselect/Method.pm
new file mode 100644
index 0000000..d5fe984
--- /dev/null
+++ b/dselect/methods/Dselect/Method.pm
@@ -0,0 +1,267 @@
+# 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, see <https://www.gnu.org/licenses/>.
+
+=encoding utf8
+
+=head1 NAME
+
+Dselect::Method - dselect method support
+
+=head1 DESCRIPTION
+
+This module provides support functions to implement methods.
+
+B<Note>: This is a private module, its API can change at any time.
+
+=cut
+
+package Dselect::Method 0.01;
+
+use strict;
+use warnings;
+
+our @EXPORT = qw(
+ %CONFIG
+ yesno
+ nb
+ view_mirrors
+ add_site
+ edit_site
+ edit_config
+ read_config
+ store_config
+);
+
+use Exporter qw(import);
+use Carp;
+
+eval q{
+ use Data::Dumper;
+
+ use Dpkg::File;
+};
+if ($@) {
+ warn "Missing Dpkg modules required by the access method.\n\n";
+ exit 1;
+}
+
+our %CONFIG;
+
+sub yesno($$) {
+ my ($d, $msg) = @_;
+
+ my ($res, $r);
+ $r = -1;
+ $r = 0 if $d eq 'n';
+ $r = 1 if $d eq 'y';
+ croak 'incorrect usage of yesno, stopped' if $r == -1;
+ while (1) {
+ print $msg, " [$d]: ";
+ $res = <STDIN>;
+ $res =~ /^[Yy]/ and return 1;
+ $res =~ /^[Nn]/ and return 0;
+ $res =~ /^[ \t]*$/ and return $r;
+ print "Please enter one of the letters 'y' or 'n'\n";
+ }
+}
+
+sub nb {
+ my $nb = shift;
+
+ if ($nb > 1024 ** 2) {
+ return sprintf '%.2fM', $nb / 1024 ** 2;
+ } elsif ($nb > 1024) {
+ return sprintf '%.2fk', $nb / 1024;
+ } else {
+ return sprintf '%.2fb', $nb;
+ }
+}
+
+sub read_config {
+ my $vars = shift;
+ my ($code, $conf);
+
+ eval {
+ $code = file_slurp($vars);
+ };
+ if ($@) {
+ warn "$@\n";
+ die "Try to relaunch the 'Access' step in dselect, thanks.\n";
+ }
+
+ my $VAR1; ## no critic (Variables::ProhibitUnusedVariables)
+ $conf = eval $code;
+ die "couldn't eval $vars content: $@\n" if $@;
+ if (ref($conf) =~ /HASH/) {
+ foreach (keys %{$conf}) {
+ $CONFIG{$_} = $conf->{$_};
+ }
+ } else {
+ print "Bad $vars file : removing it.\n";
+ print "Please relaunch the 'Access' step in dselect. Thanks.\n";
+ unlink $vars;
+ exit 0;
+ }
+}
+
+sub store_config {
+ my $vars = shift;
+
+ # Check that config is completed
+ return if not $CONFIG{done};
+
+ file_dump($vars, Dumper(\%CONFIG));
+}
+
+sub view_mirrors {
+ print <<'MIRRORS';
+Please see <https://www.debian.org/mirror/list> for a current
+list of Debian mirror sites.
+MIRRORS
+}
+
+sub edit_config {
+ my ($method, $methdir) = @_;
+ my $i;
+
+ # Get a config for the sites
+ while (1) {
+ $i = 1;
+ print "\n\nList of selected $method sites :\n";
+ foreach (@{$CONFIG{site}}) {
+ print "$i. $method://$_->[0]$_->[1] @{$_->[2]}\n";
+ $i++;
+ }
+ print "\nEnter a command (a=add e=edit d=delete q=quit m=mirror list) \n";
+ print 'eventually followed by a site number : ';
+ chomp($_ = <STDIN>);
+ /q/i && last;
+ /a/i && add_site($method);
+ /d\s*(\d+)/i && do {
+ splice(@{$CONFIG{site}}, $1 - 1, 1) if $1 <= @{$CONFIG{site}};
+ next;
+ };
+ /e\s*(\d+)/i && do {
+ edit_site($method, $CONFIG{site}[$1 - 1]) if $1 <= @{$CONFIG{site}};
+ next;
+ };
+ /m/i && view_mirrors();
+ }
+
+ print "\n";
+ $CONFIG{use_auth_proxy} = yesno($CONFIG{use_auth_proxy} ? 'y' : 'n',
+ 'Go through an authenticated proxy');
+
+ if ($CONFIG{use_auth_proxy}) {
+ print "\nEnter proxy hostname [$CONFIG{proxyhost}] : ";
+ chomp($_ = <STDIN>);
+ $CONFIG{proxyhost} = $_ || $CONFIG{proxyhost};
+
+ print "\nEnter proxy log name [$CONFIG{proxylogname}] : ";
+ chomp($_ = <STDIN>);
+ $CONFIG{proxylogname} = $_ || $CONFIG{proxylogname};
+
+ print "\nEnter proxy password [$CONFIG{proxypassword}] : ";
+ chomp($_ = <STDIN>);
+ $CONFIG{proxypassword} = $_ || $CONFIG{proxypassword};
+ }
+
+ print "\nEnter directory to download binary package files to\n";
+ print "(relative to $methdir)\n";
+ while (1) {
+ print "[$CONFIG{dldir}] : ";
+ chomp($_ = <STDIN>);
+ s{/$}{};
+ $CONFIG{dldir} = $_ if $_;
+ last if -d "$methdir/$CONFIG{dldir}";
+ print "$methdir/$CONFIG{dldir} is not a directory !\n";
+ }
+}
+
+sub add_site {
+ my $method = shift;
+
+ my $pas = 1;
+ my $user = 'anonymous';
+ my $email = qx(whoami);
+ chomp $email;
+ $email .= '@' . qx(cat /etc/mailname || dnsdomainname);
+ chomp $email;
+ my $dir = '/debian';
+
+ push @{$CONFIG{site}}, [
+ '',
+ $dir,
+ [
+ 'dists/stable/main',
+ 'dists/stable/contrib',
+ 'dists/stable/non-free-firmware',
+ 'dists/stable/non-free',
+ ],
+ $pas,
+ $user,
+ $email,
+ ];
+ edit_site($method, $CONFIG{site}[@{$CONFIG{site}} - 1]);
+}
+
+sub edit_site {
+ my ($method, $site) = @_;
+
+ local $_;
+
+ print "\nEnter $method site [$site->[0]] : ";
+ chomp($_ = <STDIN>);
+ $site->[0] = $_ || $site->[0];
+
+ print "\nUse passive mode [" . ($site->[3] ? 'y' : 'n') . '] : ';
+ chomp($_ = <STDIN>);
+ $site->[3] = (/y/i ? 1 : 0) if $_;
+
+ print "\nEnter username [$site->[4]] : ";
+ chomp($_ = <STDIN>);
+ $site->[4] = $_ || $site->[4];
+
+ print <<"EOF";
+
+If you are using anonymous $method to retrieve files, enter your email
+address for use as a password. Otherwise enter your password,
+or "?" if you want the $method method to prompt you each time.
+
+EOF
+
+ print "Enter password [$site->[5]] : ";
+ chomp($_ = <STDIN>);
+ $site->[5] = $_ || $site->[5];
+
+ print "\nEnter debian directory [$site->[1]] : ";
+ chomp($_ = <STDIN>);
+ $site->[1] = $_ || $site->[1];
+
+ print "\nEnter space separated list of distributions to get\n";
+ print "[@{$site->[2]}] : ";
+ chomp($_ = <STDIN>);
+ $site->[2] = [ split(/\s+/) ] if $_;
+}
+
+=head1 CHANGES
+
+=head2 Version 0.xx
+
+This is a private module.
+
+=cut
+
+1;
+
+__END__
diff --git a/dselect/methods/Dselect/Method/Ftp.pm b/dselect/methods/Dselect/Method/Ftp.pm
new file mode 100644
index 0000000..c149e0e
--- /dev/null
+++ b/dselect/methods/Dselect/Method/Ftp.pm
@@ -0,0 +1,232 @@
+# 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, see <https://www.gnu.org/licenses/>.
+
+=encoding utf8
+
+=head1 NAME
+
+Dselect::Method::Ftp - dselect FTP method support
+
+=head1 DESCRIPTION
+
+This module provides support functions for the FTP method.
+
+B<Note>: This is a private module, its API can change at any time.
+
+=cut
+
+package Dselect::Method::Ftp 0.01;
+
+use strict;
+use warnings;
+
+our @EXPORT = qw(
+ do_connect
+ do_mdtm
+);
+
+use Exporter qw(import);
+use Carp;
+
+eval q{
+ use Net::FTP;
+ use Data::Dumper;
+};
+if ($@) {
+ warn "Missing Net::FTP modules required by the FTP access method.\n\n";
+ exit 1;
+}
+
+sub do_connect {
+ my (%opts) = @_;
+
+ my($rpass,$remotehost,$remoteuser,$ftp);
+
+ TRY_CONNECT:
+ while(1) {
+ my $exit = 0;
+
+ if ($opts{useproxy}) {
+ $remotehost = $opts{proxyhost};
+ $remoteuser = $opts{username} . '@' . $opts{ftpsite};
+ } else {
+ $remotehost = $opts{ftpsite};
+ $remoteuser = $opts{username};
+ }
+ print "Connecting to $opts{ftpsite}...\n";
+ $ftp = Net::FTP->new($remotehost, Passive => $opts{passive});
+ if(!$ftp || !$ftp->ok) {
+ print "Failed to connect\n";
+ $exit = 1;
+ }
+ if (!$exit) {
+# $ftp->debug(1);
+ if ($opts{useproxy}) {
+ print "Login on $opts{proxyhost}...\n";
+ $ftp->_USER($opts{proxylogname});
+ $ftp->_PASS($opts{proxypassword});
+ }
+ print "Login as $opts{username}...\n";
+ if ($opts{password} eq '?') {
+ print 'Enter password for ftp: ';
+ system('stty', '-echo');
+ $rpass = <STDIN>;
+ chomp $rpass;
+ print "\n";
+ system('stty', 'echo');
+ } else {
+ $rpass = $opts{password};
+ }
+ if(!$ftp->login($remoteuser, $rpass))
+ { print $ftp->message() . "\n"; $exit = 1; }
+ }
+ if (!$exit) {
+ print "Setting transfer mode to binary...\n";
+ if(!$ftp->binary()) { print $ftp->message . "\n"; $exit = 1; }
+ }
+ if (!$exit) {
+ print "Cd to '$opts{ftpdir}'...\n";
+ if (!$ftp->cwd($opts{ftpdir})) {
+ print $ftp->message . "\n";
+ $exit = 1;
+ }
+ }
+
+ if ($exit) {
+ if (yesno ('y', 'Retry connection at once')) {
+ next TRY_CONNECT;
+ } else {
+ die 'error';
+ }
+ }
+
+ last TRY_CONNECT;
+ }
+
+# if(!$ftp->pasv()) { print $ftp->message . "\n"; die 'error'; }
+
+ return $ftp;
+}
+
+##############################
+
+# assume server supports MDTM - will be adjusted if needed
+my $has_mdtm = 1;
+
+my %months = (
+ Jan => 0,
+ Feb => 1,
+ Mar => 2,
+ Apr => 3,
+ May => 4,
+ Jun => 5,
+ Jul => 6,
+ Aug => 7,
+ Sep => 8,
+ Oct => 9,
+ Nov => 10,
+ Dec => 11,
+);
+
+my $ls_l_re = qr<
+ ([^ ]+\ *){5} # Perms, Links, User, Group, Size
+ [^ ]+ # Blanks
+ \ ([A-Z][a-z]{2}) # Month name (abbreviated)
+ \ ([0-9 ][0-9]) # Day of month
+ \ ([0-9 ][0-9][:0-9][0-9]{2}) # Filename
+>x;
+
+sub do_mdtm {
+ my ($ftp, $file) = @_;
+ my ($time);
+
+ #if ($has_mdtm) {
+ $time = $ftp->mdtm($file);
+# my $code = $ftp->code();
+# my $message = $ftp->message();
+# print " [ $code: $message ] ";
+ if ($ftp->code() == 502 || # MDTM not implemented
+ $ftp->code() == 500) { # command not understood (SUN firewall)
+ $has_mdtm = 0;
+ } elsif (!$ftp->ok()) {
+ return;
+ }
+ #}
+
+ if (! $has_mdtm) {
+ require Time::Local;
+
+ my @files = $ftp->dir($file);
+ if (($#files == -1) ||
+ ($ftp->code == 550)) { # No such file or directory
+ return;
+ }
+
+# my $code = $ftp->code();
+# my $message = $ftp->message();
+# print " [ $code: $message ] ";
+
+# print "[$#files]";
+
+ # get the date components from the output of 'ls -l'
+ if ($files[0] =~ $ls_l_re) {
+ my($month_name, $day, $year_or_time, $month, $hours, $minutes,
+ $year);
+
+ # what we can read
+ $month_name = $2;
+ $day = 0 + $3;
+ $year_or_time = $4;
+
+ # translate the month name into number
+ $month = $months{$month_name};
+
+ # recognize time or year, and compute missing one
+ if ($year_or_time =~ /([0-9]{2}):([0-9]{2})/) {
+ $hours = 0 + $1; $minutes = 0 + $2;
+ my @this_date = gmtime(time());
+ my $this_month = $this_date[4];
+ my $this_year = $this_date[5];
+ if ($month > $this_month) {
+ $year = $this_year - 1;
+ } else {
+ $year = $this_year;
+ }
+ } elsif ($year_or_time =~ / [0-9]{4}/) {
+ $hours = 0; $minutes = 0;
+ $year = $year_or_time - 1900;
+ } else {
+ die 'cannot parse year-or-time';
+ }
+
+ # build a system time
+ $time = Time::Local::timegm(0, $minutes, $hours, $day, $month, $year);
+ } else {
+ die 'regex match failed on LIST output';
+ }
+ }
+
+ return $time;
+}
+
+=head1 CHANGES
+
+=head2 Version 0.xx
+
+This is a private module.
+
+=cut
+
+1;
+
+__END__