← Back to branch summary

~diwic/dpkg/original-maintainer

« back to all changes in this revision

Viewing changes to dselect/methods/ftp/update

  • Committer: James Westby
  • Author(s): Raphael Hertzog
  • Date: 2009-12-07 09:24:31 UTC
  • mto: (1.2.2 experimental)
  • mto: This revision was merged to the branch mainline in revision 71.
  • Revision ID: james.westby@canonical.com-20091207092431-julffpexyz8z8d26
http://bugs.debian.org/558595
http://bugs.debian.org/557667
* Fix Dpkg::Index::get() and remove(). Thanks to Roderich Schupp
  <roderich.schupp@googlemail.com> for the patch. Closes: #558595
* Modify implementation of "3.0 (quilt)" source format to not be
  behave differently depending on whether quilt is installed or not.
  The option --without-quilt is thus gone and dpkg-source creates
  and relies on the .pc directory to know whether patches are applied
  or not. Closes: #557667
* Add new dpkg-source option --single-debian-patch supported by the source
  format "3.0 (quilt)" so that it behaves more like 1.0 and its single diff
  that is constantly updated with all upstream changes. Useful if the
  workflow is VCS based and can't generate a full patch set.
* dpkg-source now uses debian/source/patch-header as header of the automatic
  Debian patch in format "3.0 (quilt)".
* Fix Debian changelog parser so that the trailer line is again checked.

Show diffs side-by-side

added added

removed removed

Lines of Context:
dselect/methods/ftp/update
 
1
#!/usr/bin/perl
 
2
# -*-perl-*-
 
3
#
 
4
# Copyright © 1996 Andy Guy <awpguy@acs.ucalgary.ca>
 
5
# Copyright © 1998 Martin Schulze <joey@infodrom.north.de>
 
6
# Copyright © 1999, 2009 Raphaël Hertzog <hertzog@debian.org>
 
7
#
 
8
# This program has been distributed under the terms of the GNU GPL.
 
9
 
 
10
use strict;
 
11
use warnings;
 
12
 
 
13
#use diagnostics;
 
14
 
 
15
use lib '/usr/lib/perl5/Debian';
 
16
use lib '/usr/share/perl5/Debian';
 
17
 
 
18
eval 'use Net::FTP;';
 
19
if ($@) {
 
20
    print STDERR "Please install the 'perl' package if you want to use the\n" .
 
21
                 "FTP access method of dselect.\n\n";
 
22
    exit 1;
 
23
}
 
24
 
 
25
use Dselect::Ftp;
 
26
 
 
27
# deal with arguments
 
28
my $vardir = $ARGV[0];
 
29
my $method = $ARGV[1];
 
30
my $option = $ARGV[2];
 
31
 
 
32
if ($option eq "manual") {
 
33
    print "Enter package file names or a blank line to finish\n";
 
34
    while(1) {
 
35
        print "Enter package file name:";
 
36
        my $fn = <STDIN>;
 
37
        chomp $fn;
 
38
        if ( $fn == "") {
 
39
            exit 0;
 
40
        }
 
41
        if ( -f $fn ) {
 
42
            system ("dpkg", "--merge-avail", $fn);
 
43
        } else {
 
44
            print "Could not find $fn, try again\n";
 
45
        }
 
46
    };
 
47
};
 
48
 
 
49
#print "vardir: $vardir, method: $method, option: $option\n";
 
50
 
 
51
my $arch=`dpkg --print-architecture`;
 
52
$arch='i386' if $?;
 
53
chomp $arch;
 
54
my $exit = 0;
 
55
 
 
56
# get info from control file
 
57
read_config("$vardir/methods/ftp/vars");
 
58
 
 
59
chdir "$vardir/methods/ftp";
 
60
 
 
61
print "Getting Packages files...(stop with ^C)\n\n";
 
62
 
 
63
my @pkgfiles;
 
64
my $ftp;
 
65
my $packages_modified = 0;
 
66
 
 
67
sub download {
 
68
foreach (@{$config{'site'}}) {
 
69
 
 
70
   my $site = $_;
 
71
 
 
72
        $ftp = do_connect ($_->[0], # Ftp server
 
73
                           $_->[4], # username
 
74
                           $_->[5], # password
 
75
                           $_->[1], # ftp dir
 
76
                           $_->[3], # passive
 
77
                           $config{'use_auth_proxy'},
 
78
                           $config{'proxyhost'},
 
79
                           $config{'proxylogname'},
 
80
                           $config{'proxypassword'});
 
81
 
 
82
    my @dists = @{$_->[2]};
 
83
    my $dist;
 
84
    PACKAGE:
 
85
    foreach $dist (@dists) {
 
86
        my $dir = "$dist/binary-$arch";
 
87
        my $must_get = 0;
 
88
        my $newest_pack_date;
 
89
 
 
90
        # check existing Packages on remote site
 
91
        print "\nChecking for Packages file... ";
 
92
        $newest_pack_date = do_mdtm ($ftp, "$dir/Packages.gz");
 
93
        if (defined $newest_pack_date) {
 
94
            print "$dir/Packages.gz\n";
 
95
        } else {
 
96
            $dir = "$dist";
 
97
            $newest_pack_date = do_mdtm ($ftp, "$dir/Packages.gz");
 
98
            if (defined $newest_pack_date) {
 
99
                print "$dir/Packages.gz\n";
 
100
            } else {
 
101
                print "Couldn't find Packages.gz in $dist/binary-$arch or $dist; ignoring.\n";
 
102
                print "Your setup is probably wrong, check the distributions directories,\n";
 
103
                print "and try with passive mode enabled/disabled (if you use a proxy/firewall)\n";
 
104
                next PACKAGE;
 
105
            }
 
106
        }
 
107
 
 
108
        # we now have $dir set to point to an existing Packages.gz file
 
109
 
 
110
        # check if we already have a Packages file (and get its date)
 
111
        $dist =~ tr/\//_/;
 
112
        my $file = "Packages.$site->[0].$dist";
 
113
 
 
114
        # if not
 
115
        if (! -f $file) {
 
116
            # must get one
 
117
#           print "No Packages here; must get it.\n";
 
118
            $must_get = 1;
 
119
        } else {
 
120
            # else check last modification date
 
121
            my @pack_stat = stat($file);
 
122
            if($newest_pack_date > $pack_stat[9]) {
 
123
#               print "Packages has changed; must get it.\n";
 
124
                $must_get = 1;
 
125
            } elsif ($newest_pack_date < $pack_stat[9]) {
 
126
                print " Our file is newer than theirs; skipping.\n";
 
127
            } else {
 
128
                print " Already up-to-date; skipping.\n";
 
129
            }
 
130
        }
 
131
 
 
132
        if ($must_get) {
 
133
            -f "Packages.gz" and unlink "Packages.gz";
 
134
            -f "Packages" and unlink "Packages";
 
135
            my $size = 0;
 
136
 
 
137
          TRY_GET_PACKAGES:
 
138
            while (1) {
 
139
                if ($size) {
 
140
                    print " Continuing ";
 
141
                } else {
 
142
                    print " Getting ";
 
143
                }
 
144
                print "Packages file from $dir...\n";
 
145
                eval {
 
146
                    if ($ftp->get("$dir/Packages.gz", "Packages.gz", $size)) {
 
147
                        if (system("gunzip", "Packages.gz")) {
 
148
                            print "  Couldn't gunzip Packages.gz, stopped";
 
149
                            die "error";
 
150
                        }
 
151
                    } else {
 
152
                        print "  Couldn't get Packages.gz from $dir !!! Stopped.";
 
153
                        die "error";
 
154
                    }
 
155
                };
 
156
                if ($@) {
 
157
                    $size = -s "Packages.gz";
 
158
                    if (ref($ftp)) {
 
159
                      $ftp->abort();
 
160
                      $ftp->quit();
 
161
                    };
 
162
                    if (yesno ("y", "Transfer failed at $size: retry at once")) {
 
163
                         $ftp = do_connect ($site->[0], # Ftp server
 
164
                           $site->[4], # username
 
165
                           $site->[5], # password
 
166
                           $site->[1], # ftp dir
 
167
                           $site->[3], # passive
 
168
                           $config{'use_auth_proxy'},
 
169
                           $config{'proxyhost'},
 
170
                           $config{'proxylogname'},
 
171
                           $config{'proxypassword'});
 
172
 
 
173
                        if ($newest_pack_date != do_mdtm ($ftp, "$dir/Packages.gz")) {
 
174
                            print ("Packages file has changed !\n");
 
175
                            $size = 0;
 
176
                        }
 
177
                        next TRY_GET_PACKAGES;
 
178
                    } else {
 
179
                        die "error";
 
180
                    }
 
181
                }
 
182
                last TRY_GET_PACKAGES;
 
183
            }
 
184
 
 
185
            if(!rename "Packages", "Packages.$site->[0].$dist") {
 
186
                print "  Couldn't rename Packages to Packages.$site->[0].$dist";
 
187
                die "error";
 
188
            } else {
 
189
                # set local Packages file to same date as the one it mirrors
 
190
                # to allow comparison to work.
 
191
                utime $newest_pack_date, $newest_pack_date, "Packages.$site->[0].$dist";
 
192
                $packages_modified = 1;
 
193
            }
 
194
        }
 
195
        push @pkgfiles, "Packages.$site->[0].$dist";
 
196
    }
 
197
    $ftp->quit();
 
198
 }
 
199
}
 
200
 
 
201
eval {
 
202
    local $SIG{INT} = sub {
 
203
        die "Interrupted!\n";
 
204
    };
 
205
    download();
 
206
};
 
207
if($@) {
 
208
    $ftp->quit() if (ref($ftp));
 
209
    if($@ =~ /timeout/i) {
 
210
        print "FTP TIMEOUT\n";
 
211
    } else {
 
212
        print "FTP ERROR - $@\n";
 
213
    }
 
214
    $exit = 1;
 
215
};
 
216
 
 
217
my $ans;
 
218
 
 
219
if ($packages_modified) {       # don't clear if nothing changed
 
220
    print <<EOM;
 
221
 
 
222
It is a good idea to clear the available list of old packages.
 
223
However if you have only downloaded a Package files from non-main
 
224
distributions you might not want to do this.
 
225
 
 
226
EOM
 
227
    if (yesno ("y", "Do you want to clear available list")) {
 
228
        print "Clearing...\n";
 
229
        if(system("dpkg", "--clear-avail")) {
 
230
            print "dpkg --clear-avail failed.";
 
231
            die "error";
 
232
        }
 
233
    }
 
234
}
 
235
 
 
236
if (!$packages_modified) {
 
237
    print "No Packages files was updated.\n";
 
238
} else {
 
239
    my $file;
 
240
 
 
241
    foreach $file (@pkgfiles) {
 
242
        if(system ("dpkg", "--merge-avail", $file)) {
 
243
            print "Dpkg merge available failed on $file";
 
244
            $exit = 1;
 
245
        }
 
246
    }
 
247
}
 
248
exit $exit;