This is an automated email from the git hooks/post-receive script. guillem pushed a commit to branch main in repository dpkg.
View the commit online: https://git.dpkg.org/cgit/dpkg/dpkg.git/commit/?id=dcc5a20b1f30662bcca94f9c0da3f4e0a022b7b3 commit dcc5a20b1f30662bcca94f9c0da3f4e0a022b7b3 Author: Guillem Jover <[email protected]> AuthorDate: Sat Sep 13 18:59:17 2025 +0200 dselect: Rewrite all methods install scripts from shell to Perl Most of these method scripts were already in Perl, but because they were embedded in shell scripts they could not be checked by the authorchecks, for syntax and style issues. Besides the simple rewrites of the shell parts into Perl, we also need to fix the quotes so that perlcritic does not fail now, which could not easily be fixed before as the Perl code itself was within quotes. And update the copyright statements. Changelog: internal Warned-by: perlcritic Fixes: ValuesAndExpressions::ProhibitInterpolationOfLiterals --- dselect/methods/Makefile.am | 4 +- dselect/methods/file/install.pl | 146 ++++++++++++++++++ dselect/methods/file/install.sh | 134 ---------------- dselect/methods/media/install.pl | 321 +++++++++++++++++++++++++++++++++++++++ dselect/methods/media/install.sh | 310 ------------------------------------- 5 files changed, 469 insertions(+), 446 deletions(-) diff --git a/dselect/methods/Makefile.am b/dselect/methods/Makefile.am index d435afc21..e02577b69 100644 --- a/dselect/methods/Makefile.am +++ b/dselect/methods/Makefile.am @@ -31,13 +31,13 @@ nobase_methods_SCRIPTS = \ EXTRA_DIST = \ file/setup.sh \ file/update.sh \ - file/install.sh \ + file/install.pl \ ftp/setup.pl \ ftp/update.pl \ ftp/install.pl \ media/setup.sh \ media/update.sh \ - media/install.sh \ + media/install.pl \ media/README.media \ # EOL diff --git a/dselect/methods/file/install.pl b/dselect/methods/file/install.pl new file mode 100755 index 000000000..6897a982c --- /dev/null +++ b/dselect/methods/file/install.pl @@ -0,0 +1,146 @@ +#!/usr/bin/perl +# +# Copyright © 1996 Ian Jackson <[email protected]> +# Copyright © 2000 Adam Heath <[email protected]> +# Copyright © 2009-2025 Guillem Jover <[email protected]> +# +# 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/>. + +use v5.36; + +use Dselect::Method::Config; + +my $vardir = $ARGV[0]; +my $method = $ARGV[1]; +my $option = $ARGV[2]; + +chdir "$vardir/methods/file"; + +my $conf = Dselect::Method::Config->new(); + +$conf->load("./shvar.$option"); + +my $exit = 1; + +my $predep = "$vardir/predep-package"; +my $binaryprefix = $conf->get('p_mountpoint') . $conf->get('p_main_binary'); +$binaryprefix =~ s{/*$}{/} if length($binaryprefix); + +while (1) { + my $package; + my $version; + my @filename; + + system "dpkg --admindir '$vardir' --predep-package >'$predep'"; + my $rc = $? >> 8; + last if $rc == 1; + die if $rc != 0; + + open my $predep_fh, '<', $predep + or die "cannot open $predep: $!\n"; + while (<$predep_fh>) { + s/\s*\n$//; + $package = $_ if s/^Package: //i; + $version = $_ if s{^Version: }{}i; + @filename = split / / if s/^Filename: //i; + } + close $predep_fh; + die 'internal error - no package' if length($package) == 0; + die 'internal error - no filename' if not @filename; + + my @invoke = (); + $| = 1; + foreach my $i (0 .. $#filename) { + my $ppart = $i + 1; + my $print; + my $invoke; + my $base; + + print "Looking for part $ppart of $package ... "; + if (-f "$binaryprefix$filename[$i]") { + $print = $filename[$i]; + $invoke = "$binaryprefix$filename[$i]"; + } else { + $base = $filename[$i]; + $base =~ s{.*/}{}; + my $c = open my $find_fh, '-|'; + if (not defined $c) { + die "failed to fork for find: $!\n"; + } + if (!$c) { + exec('find', '-L', + length($binaryprefix) ? + $binaryprefix : q{.}, + '-name', $base); + die "failed to exec find: $!\n"; + } + while (chop($invoke = <$find_fh>)) { + last if -f $invoke; + } + close $find_fh; + $print = $invoke; + if (substr($print,0,length($binaryprefix)+1) eq + "$binaryprefix/") { + $print = substr($print,length($binaryprefix)); + } + } + if (!length($invoke)) { + warn <<"WARN"; + +Cannot find the appropriate file(s) anywhere needed to install or upgrade +package $package. Expecting version $version or later, as listed in the +Packages file. + +Perhaps the package was downloaded with an unexpected name? In any case, +you must find the file(s) and then either place it with the correct +filename(s) (as listed in the Packages file or in $vardir/available) +and rerun the installation, or upgrade the package by using +"dpkg --install --auto-deconfigure" by hand. + +WARN + exit(1); + } + print "$print\n"; + push(@invoke, $invoke); + } + + print "Running dpkg -iB for $package ...\n"; + exec('dpkg', '--admindir', $vardir, '-iB', '--', @invoke); + die "failed to exec dpkg: $!\n"; +} + +foreach my $f (qw(main ctb nf lcl)) { + my $this_binary = $conf->get("p_${f}_binary"); + next if length $this_binary == 0; + + my @cmd = ( + 'dpkg', + '--admindir', $vardir, + '-iGROEB', + $conf->get('p_mountpoint') . $this_binary, + ); + + print "Running @cmd\n"; + system(@cmd) == 0 + or die; +} + +print 'Installation OK. Hit RETURN.'; +<STDIN>; + +$exit = 0; + +END { + exit $exit; +} diff --git a/dselect/methods/file/install.sh b/dselect/methods/file/install.sh deleted file mode 100755 index 890612f91..000000000 --- a/dselect/methods/file/install.sh +++ /dev/null @@ -1,134 +0,0 @@ -#!/bin/sh -# -# 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/>. - -set -e -vardir="$1" -method=$2 -option=$3 - -cd "$vardir/methods/file" - -. ./shvar.$option - -xit=1 -trap ' - exit $xit -' 0 - -predep="$vardir/predep-package" -while true; do - set +e - dpkg --admindir "$vardir" --predep-package >"$predep" - rc=$? - set -e - if test $rc = 1; then - break - fi - test $rc = 0 - - perl -e ' - my $predep = $ARGV[0]; - my $binaryprefix = $ARGV[1]; - $binaryprefix =~ s{/*$}{/} if length($binaryprefix); - - my $package; - my $version; - my @filename; - - open my $predep_fh, "<", $predep - or die "cannot open $predep: $!\n"; - while (<$predep_fh>) { - s/\s*\n$//; - $package = $_ if s/^Package: //i; - $version = $_ if s{^Version: }{}i; - @filename = split / / if s/^Filename: //i; - } - close $predep_fh; - die "internal error - no package" if length($package) == 0; - die "internal error - no filename" if not @filename; - my @invoke = (); - $| = 1; - foreach my $i (0 .. $#filename) { - my $ppart = $i + 1; - my $print; - my $invoke; - my $base; - - print "Looking for part $ppart of $package ... "; - if (-f "$binaryprefix$filename[$i]") { - $print = $filename[$i]; - $invoke = "$binaryprefix$filename[$i]"; - } else { - $base = $filename[$i]; - $base =~ s{.*/}{}; - my $c = open my $find_fh, "-|"; - if (not defined $c) { - die "failed to fork for find: $!\n"; - } - if (!$c) { - exec("find", "-L", - length($binaryprefix) ? - $binaryprefix : ".", - "-name", $base); - die "failed to exec find: $!\n"; - } - while (chop($invoke = <$find_fh>)) { - last if -f $invoke; - } - close $find_fh; - $print = $invoke; - if (substr($print,0,length($binaryprefix)+1) eq - "$binaryprefix/") { - $print = substr($print,length($binaryprefix)); - } - } - if (!length($invoke)) { - warn <<"WARN"; - -Cannot find the appropriate file(s) anywhere needed to install or upgrade -package $package. Expecting version $version or later, as listed in the -Packages file. - -Perhaps the package was downloaded with an unexpected name? In any case, -you must find the file(s) and then either place it with the correct -filename(s) (as listed in the Packages file or in $vardir/available) -and rerun the installation, or upgrade the package by using -"dpkg --install --auto-deconfigure" by hand. - -WARN - exit(1); - } - print "$print\n"; - push(@invoke,$invoke); - } - print "Running dpkg -iB for $package ...\n"; - exec("dpkg","--admindir",$vardir,"-iB","--",@invoke); - die "failed to exec dpkg: $!\n"; - ' -- "$p_mountpoint$p_main_binary" "$predep" -done - -for f in main ctb nf lcl; do - eval 'this_binary=$p_'$f'_binary' - if [ -z "$this_binary" ]; then - continue - fi - echo Running dpkg --admindir $vardir -iGROEB "$p_mountpoint$this_binary" - dpkg --admindir $vardir -iGROEB "$p_mountpoint$this_binary" -done - -echo -n 'Installation OK. Hit RETURN. ' -read response - -xit=0 diff --git a/dselect/methods/media/install.pl b/dselect/methods/media/install.pl new file mode 100755 index 000000000..b13ba53b1 --- /dev/null +++ b/dselect/methods/media/install.pl @@ -0,0 +1,321 @@ +#!/usr/bin/perl +# +# Copyright © 1995-1998 Ian Jackson <[email protected]> +# Copyright © 1998 Heiko Schlittermann <[email protected]> +# Copyright © 2009 Raphaël Hertzog <[email protected]> +# Copyright © 2009-2025 Guillem Jover <[email protected]> +# +# This 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/>. + +use v5.36; + +use Dselect::Method::Config; +use Dselect::Method::Media; + +eval q{ + use Dpkg::Version; +}; +if ($@) { + warn "Missing Dpkg modules required by the Media access method.\n\n"; + exit 1; +} + +my $vardir = $ARGV[0]; +my $method = $ARGV[1]; +my $option = $ARGV[2]; + +chdir "$vardir/methods/$method"; + +my $conf = Dselect::Method::Config->new(); + +$conf->load("./shvar.$option"); + +my $p_blockdev = $conf->get('p_blockdev'); +my $p_mountpoint = $conf->get('p_mountpoint'); +my $p_hierbase = $conf->get('p_hierbase'); + +my $iarch = qx(dpkg --print-architecture); +my $umount; + +my $exit = 1; + +sub do_umount { + if (length $umount) { + system 'umount', $umount; + } +} + +sub do_mount { + my $opts = 'nosuid,nodev'; + if (! -b $p_blockdev) { + $opts .= ',loop'; + } + + if (length $p_blockdev) { + $umount = $p_mountpoint; + system qw(mount -rt iso9660 -o), $opts, $p_blockdev, $p_mountpoint; + } +} + +do_mount(); + +my $predep = "$vardir/predep-package"; +my $binaryprefix = "$p_mountpoint$p_hierbase"; + +while (1) { + my $package; + my $version; + my @filename; + my $medium; + + my $thisdisk = get_disk_label($p_mountpoint, $p_hierbase); + + system "dpkg --admindir '$vardir' --predep-package >'$predep'"; + my $rc = $? >> 8; + last if $rc == 1; + die if $rc != 0; + + open my $predep_fh, '<', $predep + or die "cannot open $predep: $!\n"; + while (<$predep_fh>) { + s/\s*\n$//; + $package = $_ if s/^Package: //i; + $version = $_ if s{^Version: }{}i; + /^X-Medium:\s+(.*)\s*/ and $medium = $1; + @filename = split / / if s/^Filename: //i; + } + close $predep_fh; + die 'internal error - no package' if length($package) == 0; + die 'internal error - no filename' if not @filename; + if ($medium && ($medium ne $thisdisk)) { + print <<"INFO"; + +This is + $thisdisk +However, $package is expected on disc: + $medium +Please change the discs and press <RETURN>. + +INFO + exit(1); + } + + my @invoke = (); + $| = 1; + foreach my $i (0 .. $#filename) { + my $ppart = $i + 1; + my $print; + my $invoke; + my $base; + + print "Looking for part $ppart of $package ... "; + if (-f "$binaryprefix$filename[$i]") { + $print = $filename[$i]; + $invoke = "$binaryprefix$filename[$i]"; + } else { + $base = $filename[$i]; + $base =~ s{.*/}{}; + my $c = open my $find_fh, '-|'; + if (not defined $c) { + die "failed to fork for find: $!\n"; + } + if (!$c) { + exec('find', '-L', + length($binaryprefix) ? $binaryprefix : '.', + '-name', $base); + die "failed to exec find: $!\n"; + } + while (chop($invoke = <$find_fh>)) { + last if -f $invoke; + } + close $find_fh; + $print = $invoke; + if (substr($print,0,length($binaryprefix)+1) eq + "$binaryprefix/") { + $print = substr($print,length($binaryprefix)); + } + } + if (!length($invoke)) { + warn <<"WARN"; + +Cannot find the appropriate file(s) anywhere needed to install or upgrade +package $package. Expecting version $version or later, as listed in the +Packages file. + +Perhaps the package was downloaded with an unexpected name? In any case, +you must find the file(s) and then either place it with the correct +filename(s) (as listed in the Packages file or in $vardir/available) +and rerun the installation, or upgrade the package by using +"dpkg --install --auto-deconfigure" by hand. + +WARN + exit(1); + } + + print "$print\n"; + push(@invoke,$invoke); + } + + print "Running dpkg -iB for $package ...\n"; + exec('dpkg', '-iB', '--', @invoke); + die "failed to exec dpkg: $!\n"; +} + +$SIG{INT} = sub { + chdir $vardir; + unlink <tmp/*>; + exit 1; +}; +$| = 1; + +my $mountpoint = $p_mountpoint; +my $hierbase = $p_hierbase; +my $line; +my $AVAIL = "$vardir/methods/media/available"; +my $STATUS = "$vardir/status"; +my (%installed, %filename, %medium); + +print 'Get currently installed package versions...'; +open my $status_fh, '<', $STATUS + or die "cannot open $STATUS: $!\n"; +$line = 0; +{ + local $/ = q{}; + + while (<$status_fh>) { + $line++ % 20 or print q{.}; + s/\n\s+/ /g; + my %status = ( + q{}, + split /^(\S*?):\s*/m, + ); + foreach my $field (keys %status) { + chomp $status{$_}; + $status{$_} =~ s/^\s*(.*?)\s*$/$1/; + } + my @pstat = split(/ /, $status{Status}); + next unless ($pstat[0] eq 'install'); + if ($pstat[2] eq 'config-files' || $pstat[2] eq 'not-installed') { + $installed{$status{Package}} = '0.0'; + } else { + $installed{$status{Package}} = $status{Version} || q{}; + } + } +} +close $status_fh; +print "\nGot ", scalar keys %installed, " installed/pending packages\n"; + +print 'Scanning available packages...'; +$line = 0; +open my $avail_fh, '<', $AVAIL + or die("Cannot open $AVAIL: $!\n"); +{ + local $/ = q{}; + while (<$avail_fh>) { + my $updated; + + $line++ % 20 or print q{.}; + + s/\n\s+/ /g; + my %avail = ( + q{}, + split /^(\S*?):\s*/m, + ); + foreach my $field (keys %avail) { + chomp $avail{$_}; + $avail{$_} =~ s/^\s*(.*?)\s*$/$1/; + } + + next unless defined $installed{$avail{Package}}; + + $updated = version_compare($avail{Version}, + $installed{$avail{Package}}) > 0; + #print "$avail{Package}(" . ($updated ? "+" : "=") . ") "; + $updated or next; + + $filename{$avail{Package}} = $avail{Filename}; + + next unless defined $avail{'X-Medium'}; + $medium{$avail{'X-Medium'}} or $medium{$avail{'X-Medium'}} = []; + push @{$medium{$avail{'X-Medium'}}}, $avail{Package}; + } +} +close $avail_fh; +print "\n"; + +my $ouch; + +my @media = sort keys %medium; +if (@media) { + print "You will need the following distribution disc(s):\n", + join(q{, }, @media), "\n"; +} + +foreach my $need (@media) { + my $disk = get_disk_label($mountpoint, $hierbase); + + print "Processing disc\n $need\n"; + + while ($disk ne $need) { + print "Wrong disc. This is disc\n $disk\n"; + print "However, the needed disc is\n $need\n"; + print "Please change the discs and press <RETURN>\n"; + do_umount(); + <STDIN>; + do_mount(); + $? and warn "cannot mount $mountpoint\n"; + } continue { + $disk = get_disk_label($mountpoint, $hierbase); + } + + if (! -d 'tmp') { + mkdir 'tmp', 0755 + or die("Cannot mkdir tmp: $!\n"); + } + unlink <tmp/*>; + + print "creating symlinks...\n"; + foreach (@{$medium{$need}}) { + my $basename; + + ($basename = $filename{$_}) =~ s/.*\///; + symlink "$mountpoint/$hierbase/$filename{$_}", + "tmp/$basename"; + } + chdir 'tmp' or die "cannot chdir to tmp: $!\n"; + system 'dpkg', '-iGROEB', q{.}; + unlink <*>; + chdir q{..}; + + if ($?) { + print "\nThe dpkg run produced errors. Please state whether to\n", + 'continue with the next media disc. [Y/n]: '; + my $answer = <STDIN>; + exit 1 if $answer =~ /^n/i; + $ouch = $?; + } +} + +exit $ouch; + + +print 'Installation OK. Hit RETURN.'; +<STDIN>; + +$exit = 0; + +END { + do_umount(); + exit $exit; +} diff --git a/dselect/methods/media/install.sh b/dselect/methods/media/install.sh deleted file mode 100755 index 06a827707..000000000 --- a/dselect/methods/media/install.sh +++ /dev/null @@ -1,310 +0,0 @@ -#!/bin/sh -# -# Copyright © 1995-1998 Ian Jackson <[email protected]> -# Copyright © 1998 Heiko Schlittermann <[email protected]> -# -# This 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/>. - -set -e -vardir="$1" -method=$2 -option=$3 - -cd "$vardir/methods/$method" - -. ./shvar.$option - -#debug() { echo "DEBUG: $@"; } -debug() { - true -} -iarch=$(dpkg --print-architecture) - -# 1/ mountpoint -# 2/ hierarchy -getdisklabel () { - debug "$1" "$2" - if [ -f $1/.disk/info ]; then - echo -n $(head -1 "$1/.disk/info") - elif [ -f $1$2/.disk/info ]; then - echo -n $(head -1 "$1$2/.disk/info") - else - echo -n 'Non-Debian disc' - fi -} - -xit=1 - -do_umount() { - if [ -n "$umount" ]; then - echo umount "$umount" - #">/dev/null" "2>&1" - fi -} - -do_mount() { - if [ ! -b "$p_blockdev" ]; then - loop=",loop" - fi - - if [ -n "$p_blockdev" ]; then - umount="$p_mountpoint" - echo mount -rt iso9660 -o nosuid,nodev${loop} "$p_blockdev" "$p_mountpoint"\; umount="$p_mountpoint" - fi -} - -trap 'eval $(do_umount); exit $xit' 0 - -eval $(do_mount) - -predep="$vardir/predep-package" -while true; do - thisdisk="$(getdisklabel ${p_mountpoint} ${p_hierbase})" - set +e - dpkg --predep-package >"$predep" - rc=$? - set -e - if test $rc = 1; then - break - fi - test $rc = 0 - - perl -e ' - my ($binaryprefix, $predep, $thisdisk) = @ARGV; - - my $package; - my $version; - my $medium; - my @filename; - - open my $predep_fh, "<", $predep - or die "cannot open $predep: $!\n"; - while (<$predep_fh>) { - s/\s*\n$//; - $package = $_ if s/^Package: //i; - $version = $_ if s{^Version: }{}i; - /^X-Medium:\s+(.*)\s*/ and $medium = $1; - @filename = split / / if s/^Filename: //i; - } - close $predep_fh; - die "internal error - no package" if length($package) == 0; - die "internal error - no filename" if not @filename; - if ($medium && ($medium ne $thisdisk)) { - print <<"INFO"; - -This is - $thisdisk -However, $package is expected on disc: - $medium -Please change the discs and press <RETURN>. - -INFO - exit(1); - } - my @invoke = (); - $| =1; - foreach my $i (0 .. $#filename) { - my $ppart = $i + 1; - my $print; - my $invoke; - my $base; - - print "Looking for part $ppart of $package ... "; - if (-f "$binaryprefix$filename[$i]") { - $print = $filename[$i]; - $invoke = "$binaryprefix$filename[$i]"; - } else { - $base = $filename[$i]; - $base =~ s{.*/}{}; - my $c = open my $find_fh, "-|"; - if (not defined $c) { - die "failed to fork for find: $!\n"; - } - if (!$c) { - exec("find", "-L", - length($binaryprefix) ? $binaryprefix : ".", - "-name", $base); - die "failed to exec find: $!\n"; - } - while (chop($invoke = <$find_fh>)) { - last if -f $invoke; - } - close $find_fh; - $print = $invoke; - if (substr($print,0,length($binaryprefix)+1) eq - "$binaryprefix/") { - $print = substr($print,length($binaryprefix)); - } - } - if (!length($invoke)) { - warn <<"WARN"; - -Cannot find the appropriate file(s) anywhere needed to install or upgrade -package $package. Expecting version $version or later, as listed in the -Packages file. - -Perhaps the package was downloaded with an unexpected name? In any case, -you must find the file(s) and then either place it with the correct -filename(s) (as listed in the Packages file or in $vardir/available) -and rerun the installation, or upgrade the package by using -"dpkg --install --auto-deconfigure" by hand. - -WARN - exit(1); - } - print "$print\n"; - push(@invoke,$invoke); - } - print "Running dpkg -iB for $package ...\n"; - exec("dpkg","-iB","--",@invoke); - die "failed to exec dpkg: $!\n"; - ' -- "$p_mountpoint$p_hierbase" "$predep" "$thisdisk" -done - -perl -MDpkg::Version -MDselect::Method::Media -e ' - $SIG{INT} = sub { - chdir $vardir; - unlink <tmp/*>; - exit 1; - }; - $| = 1; - my ($vardir, $mountpoint, $hierbase, $mount, $umount) = @ARGV; - my $line; - my $AVAIL = "$vardir/methods/media/available"; - my $STATUS = "$vardir/status"; - my (%installed, %filename, %medium); - print "Get currently installed package versions..."; - open my $status_fh, "<", $STATUS - or die "cannot open $STATUS: $!\n"; - $line = 0; - { local $/ = ""; - while (<$status_fh>) { - $line++ % 20 or print "."; - s/\n\s+/ /g; - my %status = ( - "", - split /^(\S*?):\s*/m, - ); - foreach my $field (keys %status) { - chomp $status{$_}; - $status{$_} =~ s/^\s*(.*?)\s*$/$1/; - } - my @pstat = split(/ /, $status{Status}); - next unless ($pstat[0] eq "install"); - if ($pstat[2] eq "config-files" || $pstat[2] eq "not-installed") { - $installed{$status{Package}} = "0.0"; - } else { - $installed{$status{Package}} = $status{Version} || "" ; - } - } - } - close $status_fh; - print "\nGot ", scalar keys %installed, " installed/pending packages\n"; - print "Scanning available packages..."; - $line = 0; - open my $avail_fh, "<", $AVAIL - or die "Cannot open $AVAIL: $!\n"; - { local $/ = ""; - while (<$avail_fh>) { - my $updated; - $line++ % 20 or print "."; - - s/\n\s+/ /g; - my %avail = ( - "", - split /^(\S*?):\s*/m, - ); - foreach my $field (keys %avail) { - chomp $avail{$_}; - $avail{$_} =~ s/^\s*(.*?)\s*$/$1/; - } - - next unless defined $installed{$avail{Package}}; - - $updated = version_compare($avail{Version}, - $installed{$avail{Package}}) > 0; - #print "$avail{Package}(" . ($updated ? "+" : "=") . ") "; - $updated or next; - - $filename{$avail{Package}} = $avail{Filename}; - - next unless defined $avail{"X-Medium"}; - $medium{$avail{"X-Medium"}} or $medium{$avail{"X-Medium"}} = []; - push @{$medium{$avail{"X-Medium"}}}, $avail{Package}; - } - } - close $avail_fh; - print "\n"; - - my $ouch; - - my @media = sort keys %medium; - if (@media) { - print "You will need the following distribution disc(s):\n", - join(", ", @media), "\n"; - } - - foreach my $need (@media) { - my $disk = get_disk_label($mountpoint, $hierbase); - - print "Processing disc\n $need\n"; - - while ($disk ne $need) { - print "Wrong disc. This is disc\n $disk\n"; - print "However, the needed disc is\n $need\n"; - print "Please change the discs and press <RETURN>\n"; - system($umount); - <STDIN>; - system($mount); - $? and warn("cannot mount $mount\n"); - } continue { - $disk = get_disk_label($mountpoint, $hierbase); - } - - if (! -d "tmp") { - mkdir "tmp", 0755 - or die("Cannot mkdir tmp: $!\n"); - } - unlink <tmp/*>; - - print "creating symlinks...\n"; - foreach (@{$medium{$need}}) { - my $basename; - - ($basename = $filename{$_}) =~ s/.*\///; - symlink "$mountpoint/$hierbase/$filename{$_}", - "tmp/$basename"; - } - chdir "tmp" or die "cannot chdir to tmp: $!\n"; - system "dpkg", "-iGROEB", "."; - unlink <*>; - chdir ".."; - - if ($?) { - print "\nThe dpkg run produced errors. Please state whether to\n", - "continue with the next media disc. [Y/n]: "; - my $answer = <STDIN>; - exit 1 if $answer =~ /^n/i; - $ouch = $?; - } - } - - exit $ouch; - -' "$vardir" "$p_mountpoint" "$p_hierbase" "$(do_mount)" "$(do_umount)" - -echo -n 'Installation OK. Hit RETURN. ' -read response - -xit=0 -- Dpkg.Org's dpkg
