scripts/uscan.pl

   1 #! /usr/bin/perl -w
   2
   3 # uscan: This program looks for watchfiles and checks upstream ftp sites
   4 # for later versions of the software.
   5 #
   6 # Originally written by Christoph Lameter <clameter@debian.org> (I believe)
   7 # Modified by Julian Gilbey <jdg@debian.org>
   8 # HTTP support added by Piotr Roszatycki <dexter@debian.org>
   9 # Rewritten in Perl, Copyright 2002-2006, Julian Gilbey
  10 #
  11 # This program is free software; you can redistribute it and/or modify
  12 # it under the terms of the GNU General Public License as published by
  13 # the Free Software Foundation; either version 2 of the License, or
  14 # (at your option) any later version.
  15 #
  16 # This program is distributed in the hope that it will be useful,
  17 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 # GNU General Public License for more details.
  20 #
  21 # You should have received a copy of the GNU General Public License
  22 # along with this program. If not, see <http://www.gnu.org/licenses/>.
  23
  24 use 5.008;  # uses 'our' variables and filetest
  25 use strict;
  26 use Cwd;
  27 use File::Basename;
  28 use File::Copy;
  29 use File::Temp qw/tempdir/;
  30 use filetest 'access';
  31 use Getopt::Long;
  32 use lib '/usr/share/devscripts';
  33 use Devscripts::Versort;
  34 use Text::ParseWords;
  35 BEGIN {
  36     eval { require LWP::UserAgent; };
  37     if ($@) {
  38         my $progname = basename($0);
  39         if ($@ =~ /^Can\'t locate LWP\/UserAgent\.pm/) {
  40             die "$progname: you must have the libwww-perl package installed\nto use this script\n";
  41         } else {
  42             die "$progname: problem loading the LWP::UserAgent module:\n  $@\nHave you installed the libwww-perl package?\n";
  43         }
  44     }
  45 }
  46 my $CURRENT_WATCHFILE_VERSION = 3;
  47
  48 my $progname = basename($0);
  49 my $modified_conf_msg;
  50 my $opwd = cwd();
  51
  52 my $haveSSL = 1;
  53 eval { require Crypt::SSLeay; };
  54 if ($@) {
  55     $haveSSL = 0;
  56 }
  57
  58 # Did we find any new upstream versions on our wanderings?
  59 our $found = 0;
  60
  61 sub process_watchline ($$$$$$);
  62 sub process_watchfile ($$$$);
  63 sub recursive_regex_dir ($$$);
  64 sub newest_dir ($$$$$);
  65 sub dehs_msg ($);
  66 sub dehs_warn ($);
  67 sub dehs_die ($);
  68 sub dehs_output ();
  69 sub quoted_regex_replace ($);
  70 sub safe_replace ($$);
  71
  72 sub usage {
  73     print <<"EOF";
  74 Usage: $progname [options] [dir ...]
  75   Process watchfiles in all .../debian/ subdirs of those listed (or the
  76   current directory if none listed) to check for upstream releases.
  77 Options:
  78     --report       Only report on newer or absent versions, do not download
  79     --report-status
  80                    Report status of packages, but do not download
  81     --debug        Dump the downloaded web pages to stdout for debugging
  82                    your watch file.
  83     --destdir      Path of directory to which to download.
  84     --download     Report on newer and absent versions, and download (default)
  85     --force-download
  86                    Always download the upstream release, even if up to date
  87     --no-download  Report on newer and absent versions, but don\'t download
  88     --pasv         Use PASV mode for FTP connections
  89     --no-pasv      Do not use PASV mode for FTP connections (default)
  90     --timeout N    Specifies how much time, in seconds, we give remote
  91                    servers to respond (default 20 seconds)
  92     --symlink      Make an orig.tar.gz symlink to downloaded file (default)
  93     --rename       Rename to orig.tar.gz instead of symlinking
  94                    (Both will use orig.tar.bz2 if appropriate)
  95     --repack       Repack downloaded archives from orig.tar.bz2 or orig.zip to
  96                    orig.tar.gz
  97                    (does nothing if downloaded archive orig.tar.gz)
  98     --no-symlink   Don\'t make symlink or rename
  99     --verbose      Give verbose output
 100     --no-verbose   Don\'t give verbose output (default)
 101     --check-dirname-level N
 102                    How much to check directory names:
 103                    N=0   never
 104                    N=1   only when program changes directory (default)
 105                    N=2   always
 106     --check-dirname-regex REGEX
 107                    What constitutes a matching directory name; REGEX is
 108                    a Perl regular expression; the string \`PACKAGE\' will
 109                    be replaced by the package name; see manpage for details
 110                    (default: 'PACKAGE(-.+)?')
 111     --watchfile FILE
 112                    Specify the watchfile rather than using debian/watch;
 113                    no directory traversing will be done in this case
 114     --upstream-version VERSION
 115                    Specify the current upstream version in use rather than
 116                    parsing debian/changelog to determine this
 117     --download-version VERSION
 118                    Specify the version which the upstream release must
 119                    match in order to be considered, rather than using the
 120                    release with the highest version
 121     --download-current-version
 122                    Download the currently packaged version
 123     --package PACKAGE
 124                    Specify the package name rather than examining
 125                    debian/changelog; must use --upstream-version and
 126                    --watchfile with this option, no directory traversing
 127                    will be performed, no actions (even downloading) will be
 128                    carried out
 129     --no-dehs      Use traditional uscan output format (default)
 130     --dehs         Use DEHS style output (XML-type)
 131     --user-agent, --useragent
 132                    Override the default user agent
 133     --no-conf, --noconf
 134                    Don\'t read devscripts config files;
 135                    must be the first option given
 136     --help         Show this message
 137     --version      Show version information
 138
 139 Default settings modified by devscripts configuration files:
 140 $modified_conf_msg
 141 EOF
 142 }
 143
 144 sub version {
 145     print <<"EOF";
 146 This is $progname, from the Debian devscripts package, version ###VERSION###
 147 This code is copyright 1999-2006 by Julian Gilbey, all rights reserved.
 148 Original code by Christoph Lameter.
 149 This program comes with ABSOLUTELY NO WARRANTY.
 150 You are free to redistribute this code under the terms of the
 151 GNU General Public License, version 2 or later.
 152 EOF
 153 }
 154
 155 # What is the default setting of $ENV{'FTP_PASSIVE'}?
 156 our $passive = 'default';
 157
 158 # Now start by reading configuration files and then command line
 159 # The next stuff is boilerplate
 160
 161 my $destdir = "..";
 162 my $download = 1;
 163 my $download_version;
 164 my $force_download = 0;
 165 my $report = 0; # report even on up-to-date packages?
 166 my $repack = 0; # repack .tar.bz2 or .zip to .tar.gz
 167 my $symlink = 'symlink';
 168 my $verbose = 0;
 169 my $check_dirname_level = 1;
 170 my $check_dirname_regex = 'PACKAGE(-.+)?';
 171 my $dehs = 0;
 172 my %dehs_tags;
 173 my $dehs_end_output = 0;
 174 my $dehs_start_output = 0;
 175 my $pkg_report_header = '';
 176 my $timeout = 20;
 177 my $user_agent_string = 'Debian uscan ###VERSION###';
 178
 179 if (@ARGV and $ARGV[0] =~ /^--no-?conf$/) {
 180     $modified_conf_msg = "  (no configuration files read)";
 181     shift;
 182 } else {
 183     my @config_files = ('/etc/devscripts.conf', '~/.devscripts');
 184     my %config_vars = (
 185                        'USCAN_TIMEOUT' => 20,
 186                        'USCAN_DESTDIR' => '..',
 187                        'USCAN_DOWNLOAD' => 'yes',
 188                        'USCAN_PASV' => 'default',
 189                        'USCAN_SYMLINK' => 'symlink',
 190                        'USCAN_VERBOSE' => 'no',
 191                        'USCAN_DEHS_OUTPUT' => 'no',
 192                        'USCAN_USER_AGENT' => '',
 193                        'USCAN_REPACK' => 'no',
 194                        'DEVSCRIPTS_CHECK_DIRNAME_LEVEL' => 1,
 195                        'DEVSCRIPTS_CHECK_DIRNAME_REGEX' => 'PACKAGE(-.+)?',
 196                        );
 197     my %config_default = %config_vars;
 198
 199     my $shell_cmd;
 200     # Set defaults
 201     foreach my $var (keys %config_vars) {
 202         $shell_cmd .= qq[$var="$config_vars{$var}";\n];
 203     }
 204     $shell_cmd .= 'for file in ' . join(" ",@config_files) . "; do\n";
 205     $shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
 206     # Read back values
 207     foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
 208     my $shell_out = `/bin/bash -c '$shell_cmd'`;
 209     @config_vars{keys %config_vars} = split /\n/, $shell_out, -1;
 210
 211     # Check validity
 212     $config_vars{'USCAN_DESTDIR'} =~ /^\s*(\S+)\s*$/
 213         or $config_vars{'USCAN_DESTDIR'}='..';
 214     $config_vars{'USCAN_DOWNLOAD'} =~ /^(yes|no)$/
 215         or $config_vars{'USCAN_DOWNLOAD'}='yes';
 216     $config_vars{'USCAN_PASV'} =~ /^(yes|no|default)$/
 217         or $config_vars{'USCAN_PASV'}='default';
 218     $config_vars{'USCAN_TIMEOUT'} =~ m/^\d+$/
 219         or $config_vars{'USCAN_TIMEOUT'}=20;
 220     $config_vars{'USCAN_SYMLINK'} =~ /^(yes|no|symlinks?|rename)$/
 221         or $config_vars{'USCAN_SYMLINK'}='yes';
 222     $config_vars{'USCAN_SYMLINK'}='symlink'
 223         if $config_vars{'USCAN_SYMLINK'} eq 'yes' or
 224             $config_vars{'USCAN_SYMLINK'} =~ /^symlinks?$/;
 225     $config_vars{'USCAN_VERBOSE'} =~ /^(yes|no)$/
 226         or $config_vars{'USCAN_VERBOSE'}='no';
 227     $config_vars{'USCAN_DEHS_OUTPUT'} =~ /^(yes|no)$/
 228         or $config_vars{'USCAN_DEHS_OUTPUT'}='no';
 229     $config_vars{'USCAN_REPACK'} =~ /^(yes|no)$/
 230         or $config_vars{'USCAN_REPACK'}='no';
 231     $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'} =~ /^[012]$/
 232         or $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'}=1;
 233
 234     foreach my $var (sort keys %config_vars) {
 235         if ($config_vars{$var} ne $config_default{$var}) {
 236             $modified_conf_msg .= "  $var=$config_vars{$var}\n";
 237         }
 238     }
 239     $modified_conf_msg ||= "  (none)\n";
 240     chomp $modified_conf_msg;
 241
 242     $destdir = $config_vars{'USCAN_DESTDIR'}
 243         if defined $config_vars{'USCAN_DESTDIR'};
 244     $download = $config_vars{'USCAN_DOWNLOAD'} eq 'no' ? 0 : 1;
 245     $passive = $config_vars{'USCAN_PASV'} eq 'yes' ? 1 :
 246         $config_vars{'USCAN_PASV'} eq 'no' ? 0 : 'default';
 247     $timeout = $config_vars{'USCAN_TIMEOUT'};
 248     $symlink = $config_vars{'USCAN_SYMLINK'};
 249     $verbose = $config_vars{'USCAN_VERBOSE'} eq 'yes' ? 1 : 0;
 250     $dehs = $config_vars{'USCAN_DEHS_OUTPUT'} eq 'yes' ? 1 : 0;
 251     $check_dirname_level = $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_LEVEL'};
 252     $check_dirname_regex = $config_vars{'DEVSCRIPTS_CHECK_DIRNAME_REGEX'};
 253     $user_agent_string = $config_vars{'USCAN_USER_AGENT'}
 254         if $config_vars{'USCAN_USER_AGENT'};
 255     $repack = $config_vars{'USCAN_REPACK'} eq 'yes' ? 1 : 0;
 256 }
 257
 258 # Now read the command line arguments
 259 my $debug = 0;
 260 my ($opt_h, $opt_v, $opt_destdir, $opt_download, $opt_force_download,
 261     $opt_report, $opt_passive, $opt_symlink, $opt_repack);
 262 my ($opt_verbose, $opt_level, $opt_regex, $opt_noconf);
 263 my ($opt_package, $opt_uversion, $opt_watchfile, $opt_dehs, $opt_timeout);
 264 my $opt_download_version;
 265 my $opt_user_agent;
 266 my $opt_download_current_version;
 267
 268 GetOptions("help" => \$opt_h,
 269            "version" => \$opt_v,
 270            "destdir=s" => \$opt_destdir,
 271            "download!" => \$opt_download,
 272            "download-version=s" => \$opt_download_version,
 273            "force-download" => \$opt_force_download,
 274            "report" => sub { $opt_download = 0; },
 275            "report-status" => sub { $opt_download = 0; $opt_report = 1; },
 276            "passive|pasv!" => \$opt_passive,
 277            "timeout=i" => \$opt_timeout,
 278            "symlink!" => sub { $opt_symlink = $_[1] ? 'symlink' : 'no'; },
 279            "rename" => sub { $opt_symlink = 'rename'; },
 280            "repack" => sub { $opt_repack = 1; },
 281            "package=s" => \$opt_package,
 282            "upstream-version=s" => \$opt_uversion,
 283            "watchfile=s" => \$opt_watchfile,
 284            "dehs!" => \$opt_dehs,
 285            "verbose!" => \$opt_verbose,
 286            "debug" => \$debug,
 287            "check-dirname-level=s" => \$opt_level,
 288            "check-dirname-regex=s" => \$opt_regex,
 289            "user-agent=s" => \$opt_user_agent,
 290            "useragent=s" => \$opt_user_agent,
 291            "noconf" => \$opt_noconf,
 292            "no-conf" => \$opt_noconf,
 293            "download-current-version" => \$opt_download_current_version,
 294            )
 295     or die "Usage: $progname [options] [directories]\nRun $progname --help for more details\n";
 296
 297 if ($opt_noconf) {
 298     die "$progname: --no-conf is only acceptable as the first command-line option!\n";
 299 }
 300 if ($opt_h) { usage(); exit 0; }
 301 if ($opt_v) { version(); exit 0; }
 302
 303 # Now we can set the other variables according to the command line options
 304
 305 $destdir = $opt_destdir if defined $opt_destdir;
 306 $download = $opt_download if defined $opt_download;
 307 $force_download = $opt_force_download if defined $opt_force_download;
 308 $report = $opt_report if defined $opt_report;
 309 $repack = $opt_repack if defined $opt_repack;
 310 $passive = $opt_passive if defined $opt_passive;
 311 $timeout = $opt_timeout if defined $opt_timeout;
 312 $timeout = 20 unless defined $timeout and $timeout > 0;
 313 $symlink = $opt_symlink if defined $opt_symlink;
 314 $verbose = $opt_verbose if defined $opt_verbose;
 315 $dehs = $opt_dehs if defined $opt_dehs;
 316 $user_agent_string = $opt_user_agent if defined $opt_user_agent;
 317 $download_version = $opt_download_version if defined $opt_download_version;
 318 if ($dehs) {
 319     $SIG{'__WARN__'} = \&dehs_warn;
 320     $SIG{'__DIE__'} = \&dehs_die;
 321 }
 322
 323 if (defined $opt_level) {
 324     if ($opt_level =~ /^[012]$/) { $check_dirname_level = $opt_level; }
 325     else {
 326         die "$progname: unrecognised --check-dirname-level value (allowed are 0,1,2)\n";
 327     }
 328 }
 329
 330 $check_dirname_regex = $opt_regex if defined $opt_regex;
 331
 332 if (defined $opt_package) {
 333     die "$progname: --package requires the use of --watchfile\nas well; run $progname --help for more details\n"
 334         unless defined $opt_watchfile;
 335     $download = -$download unless defined $opt_download;
 336 }
 337
 338 die "$progname: Can't use --verbose if you're using --dehs!\n"
 339     if $verbose and $dehs;
 340
 341 die "$progname: Can't use --report-status if you're using --verbose!\n"
 342     if $verbose and $report;
 343
 344 die "$progname: Can't use --report-status if you're using --download!\n"
 345     if $download and $report;
 346
 347 warn "$progname: You're going to get strange (non-XML) output using --debug and --dehs together!\n"
 348     if $debug and $dehs;
 349
 350 # We'd better be verbose if we're debugging
 351 $verbose |= $debug;
 352
 353 # Net::FTP understands this
 354 if ($passive ne 'default') {
 355     $ENV{'FTP_PASSIVE'} = $passive;
 356 }
 357 elsif (exists $ENV{'FTP_PASSIVE'}) {
 358     $passive = $ENV{'FTP_PASSIVE'};
 359 }
 360 else { $passive = undef; }
 361 # Now we can say
 362 #   if (defined $passive) { $ENV{'FTP_PASSIVE'}=$passive; }
 363 #   else { delete $ENV{'FTP_PASSIVE'}; }
 364 # to restore $ENV{'FTP_PASSIVE'} to what it was at this point
 365
 366 # dummy subclass used to store all the redirections for later use
 367 package LWP::UserAgent::UscanCatchRedirections;
 368
 369 use base 'LWP::UserAgent';
 370
 371 my @uscan_redirections;
 372
 373 sub redirect_ok {
 374     my $self = shift;
 375     my ($request) = @_;
 376     if ($self->SUPER::redirect_ok(@_)) {
 377         push @uscan_redirections, $request->uri;
 378         return 1;
 379     }
 380     return 0;
 381 }
 382
 383 sub get_redirections {
 384     return \@uscan_redirections;
 385 }
 386
 387 package main;
 388
 389 my $user_agent = LWP::UserAgent::UscanCatchRedirections->new(env_proxy => 1);
 390 $user_agent->timeout($timeout);
 391 $user_agent->agent($user_agent_string);
 392
 393 if (defined $opt_watchfile) {
 394     die "Can't have directory arguments if using --watchfile" if @ARGV;
 395
 396     # no directory traversing then, and things are very simple
 397     if (defined $opt_package) {
 398         # no need to even look for a changelog!
 399         process_watchfile(undef, $opt_package, $opt_uversion, $opt_watchfile);
 400     } else {
 401         # Check for debian/changelog file
 402         until (-r 'debian/changelog') {
 403             chdir '..' or die "$progname: can't chdir ..: $!\n";
 404             if (cwd() eq '/') {
 405                 die "$progname: cannot find readable debian/changelog anywhere!\nAre you in the source code tree?\n";
 406             }
 407         }
 408
 409         # Figure out package info we need
 410         my $changelog = `dpkg-parsechangelog`;
 411         unless ($? == 0) {
 412             die "$progname: Problems running dpkg-parsechangelog\n";
 413         }
 414
 415         my ($package, $debversion, $uversion);
 416         $changelog =~ /^Source: (.*?)$/m and $package=$1;
 417         $changelog =~ /^Version: (.*?)$/m and $debversion=$1;
 418         if (! defined $package || ! defined $debversion) {
 419             die "$progname: Problems determining package name and/or version from\n  debian/changelog\n";
 420         }
 421
 422         # Check the directory is properly named for safety
 423         my $good_dirname = 1;
 424         if ($check_dirname_level ==  2 or
 425             ($check_dirname_level == 1 and cwd() ne $opwd)) {
 426             my $re = $check_dirname_regex;
 427             $re =~ s/PACKAGE/\Q$package\E/g;
 428             if ($re =~ m%/%) {
 429                 $good_dirname = (cwd() =~ m%^$re$%);
 430             } else {
 431                 $good_dirname = (basename(cwd()) =~ m%^$re$%);
 432             }
 433         }
 434         if (! $good_dirname) {
 435             die "$progname: not processing watchfile because this directory does not match the package name\n" .
 436                 "   or the settings of the--check-dirname-level and --check-dirname-regex options if any.\n";
 437         }
 438
 439         # Get current upstream version number
 440         if (defined $opt_uversion) {
 441             $uversion = $opt_uversion;
 442         } else {
 443             $uversion = $debversion;
 444             $uversion =~ s/-[^-]+$//;  # revision
 445             $uversion =~ s/^\d+://;    # epoch
 446         }
 447
 448         process_watchfile(cwd(), $package, $uversion, $opt_watchfile);
 449     }
 450
 451     # Are there any warnings to give if we're using dehs?
 452     $dehs_end_output=1;
 453     dehs_output if $dehs;
 454     exit ($found ? 0 : 1);
 455 }
 456
 457 # Otherwise we're scanning for watchfiles
 458 push @ARGV, '.' if ! @ARGV;
 459 print "-- Scanning for watchfiles in @ARGV\n" if $verbose;
 460
 461 # Run find to find the directories.  We will handle filenames with spaces
 462 # correctly, which makes this code a little messier than it would be
 463 # otherwise.
 464 my @dirs;
 465 open FIND, '-|', 'find', @ARGV, qw(-follow -type d -name debian -print)
 466     or die "$progname: couldn't exec find: $!\n";
 467
 468 while (<FIND>) {
 469     chomp;
 470     push @dirs, $_;
 471 }
 472 close FIND;
 473
 474 die "$progname: No debian directories found\n" unless @dirs;
 475
 476 my @debdirs = ();
 477
 478 my $origdir = cwd;
 479 for my $dir (@dirs) {
 480     unless (chdir $origdir) {
 481         warn "$progname warning: Couldn't chdir back to $origdir, skipping: $!\n";
 482         next;
 483     }
 484     $dir =~ s%/debian$%%;
 485     unless (chdir $dir) {
 486         warn "$progname warning: Couldn't chdir $dir, skipping: $!\n";
 487         next;
 488     }
 489
 490     # Check for debian/watch file
 491     if (-r 'debian/watch' and -r 'debian/changelog') {
 492         # Figure out package info we need
 493         my $changelog = `dpkg-parsechangelog`;
 494         unless ($? == 0) {
 495             warn "$progname warning: Problems running dpkg-parsechangelog in $dir, skipping\n";
 496             next;
 497         }
 498
 499         my ($package, $debversion, $uversion);
 500         $changelog =~ /^Source: (.*?)$/m and $package=$1;
 501         $changelog =~ /^Version: (.*?)$/m and $debversion=$1;
 502         if (! defined $package || ! defined $debversion) {
 503             warn "$progname warning: Problems determining package name and/or version from\n  $dir/debian/changelog, skipping\n";
 504             next;
 505         }
 506
 507         # Check the directory is properly named for safety
 508         my $good_dirname = 1;
 509         if ($check_dirname_level ==  2 or
 510             ($check_dirname_level == 1 and cwd() ne $opwd)) {
 511             my $re = $check_dirname_regex;
 512             $re =~ s/PACKAGE/\Q$package\E/g;
 513             if ($re =~ m%/%) {
 514                 $good_dirname = (cwd() =~ m%^$re$%);
 515             } else {
 516                 $good_dirname = (basename(cwd()) =~ m%^$re$%);
 517             }
 518         }
 519         if ($good_dirname) {
 520             print "-- Found watchfile in $dir/debian\n" if $verbose;
 521         } else {
 522             print "-- Skip watchfile in $dir/debian since it does not match the package name\n" .
 523                 "   (or the settings of the --check-dirname-level and --check-dirname-regex options if any).\n"
 524                 if $verbose;
 525             next;
 526         }
 527
 528         # Get upstream version number
 529         $uversion = $debversion;
 530         $uversion =~ s/-[^-]+$//;  # revision
 531         $uversion =~ s/^\d+://;    # epoch
 532
 533         push @debdirs, [$debversion, $dir, $package, $uversion];
 534     }
 535     elsif (-r 'debian/watch') {
 536         warn "$progname warning: Found watchfile in $dir,\n  but couldn't find/read changelog; skipping\n";
 537         next;
 538     }
 539     elsif (-f 'debian/watch') {
 540         warn "$progname warning: Found watchfile in $dir,\n  but it is not readable; skipping\n";
 541         next;
 542     }
 543 }
 544
 545 warn "$progname: no watch file found\n" if (@debdirs == 0 and $report);
 546
 547 # Was there a --uversion option?
 548 if (defined $opt_uversion) {
 549     if (@debdirs == 1) {
 550         $debdirs[0][3] = $opt_uversion;
 551     } else {
 552         warn "$progname warning: ignoring --uversion as more than one debian/watch file found\n";
 553     }
 554 }
 555
 556 # Now sort the list of directories, so that we process the most recent
 557 # directories first, as determined by the package version numbers
 558 @debdirs = Devscripts::Versort::deb_versort(@debdirs);
 559
 560 # Now process the watchfiles in order.  If a directory d has subdirectories
 561 # d/sd1/debian and d/sd2/debian, which each contain watchfiles corresponding
 562 # to the same package, then we only process the watchfile in the package with
 563 # the latest version number.
 564 my %donepkgs;
 565 for my $debdir (@debdirs) {
 566     shift @$debdir;  # don't need the Debian version number any longer
 567     my $dir = $$debdir[0];
 568     my $parentdir = dirname($dir);
 569     my $package = $$debdir[1];
 570     my $version = $$debdir[2];
 571
 572     if (exists $donepkgs{$parentdir}{$package}) {
 573         warn "$progname warning: Skipping $dir/debian/watch\n  as this package has already been scanned successfully\n";
 574         next;
 575     }
 576
 577     unless (chdir $origdir) {
 578         warn "$progname warning: Couldn't chdir back to $origdir, skipping: $!\n";
 579         next;
 580     }
 581     unless (chdir $dir) {
 582         warn "$progname warning: Couldn't chdir $dir, skipping: $!\n";
 583         next;
 584     }
 585
 586     if (process_watchfile($dir, $package, $version, "debian/watch")
 587         == 0) {
 588         $donepkgs{$parentdir}{$package} = 1;
 589     }
 590     # Are there any warnings to give if we're using dehs?
 591     dehs_output if $dehs;
 592 }
 593
 594 print "-- Scan finished\n" if $verbose;
 595
 596 $dehs_end_output=1;
 597 dehs_output if $dehs;
 598 exit ($found ? 0 : 1);
 599
 600
 601 # This is the heart of the code: Process a single watch item
 602 #
 603 # watch_version=1: Lines have up to 5 parameters which are:
 604 #
 605 # $1 = Remote site
 606 # $2 = Directory on site
 607 # $3 = Pattern to match, with (...) around version number part
 608 # $4 = Last version we have (or 'debian' for the current Debian version)
 609 # $5 = Actions to take on successful retrieval
 610 #
 611 # watch_version=2:
 612 #
 613 # For ftp sites:
 614 #   ftp://site.name/dir/path/pattern-(.*)\.tar\.gz [version [action]]
 615 #
 616 # For http sites:
 617 #   http://site.name/dir/path/pattern-(.*)\.tar\.gz [version [action]]
 618 # or
 619 #   http://site.name/dir/path/base pattern-(.*)\.tar\.gz [version [action]]
 620 #
 621 # Lines can be prefixed with opts=<opts>.
 622 #
 623 # Then the patterns matched will be checked to find the one with the
 624 # greatest version number (as determined by the (...) group), using the
 625 # Debian version number comparison algorithm described below.
 626 #
 627 # watch_version=3:
 628 #
 629 # Correct handling of regex special characters in the path part:
 630 # ftp://ftp.worldforge.org/pub/worldforge/libs/Atlas-C++/transitional/Atlas-C\+\+-(.*)\.tar\.gz
 631 #
 632 # Directory pattern matching:
 633 # ftp://ftp.nessus.org/pub/nessus/nessus-([\d\.]+)/src/nessus-core-([\d\.]+)\.tar\.gz
 634 #
 635 # The pattern in each part may contain several (...) groups and
 636 # the version number is determined by joining all groups together
 637 # using "." as separator.  For example:
 638 #   ftp://site/dir/path/pattern-(\d+)_(\d+)_(\d+)\.tar\.gz
 639 #
 640 # This is another way of handling site with funny version numbers,
 641 # this time using mangling.  (Note that multiple groups will be
 642 # concatenated before mangling is performed, and that mangling will
 643 # only be performed on the basename version number, not any path version
 644 # numbers.)
 645 # opts=uversionmangle=s/^/0.0./ \
 646 #   ftp://ftp.ibiblio.org/pub/Linux/ALPHA/wine/development/Wine-(.*)\.tar\.gz
 647 #
 648 # Similarly, the upstream part of the Debian version number can be
 649 # mangled:
 650 # opts=dversionmangle=s/\.dfsg\.\d+$// \
 651 #   http://some.site.org/some/path/foobar-(.*)\.tar\.gz
 652 #
 653 # The versionmangle=... option is a shorthand for saying uversionmangle=...
 654 # and dversionmangle=... and applies to both upstream and Debian versions.
 655 #
 656 # The option filenamemangle can be used to mangle the name under which
 657 # the downloaded file will be saved:
 658 #   href="http://foo.bar.org/download/?path=&amp;download=foo-0.1.1.tar.gz"
 659 # could be handled as:
 660 # opts=filenamemangle=s/.*=(.*)/$1/ \
 661 #     http://foo.bar.org/download/\?path=&amp;download=foo-(.*)\.tar\.gz
 662 # and
 663 #   href="http://foo.bar.org/download/?path=&amp;download_version=0.1.1"
 664 # as:
 665 # opts=filenamemangle=s/.*=(.*)/foo-$1\.tar\.gz/ \
 666 #    http://foo.bar.org/download/\?path=&amp;download_version=(.*)
 667 #
 668 # The option downloadurlmangle can be used to mangle the URL of the file
 669 # to download.  This can only be used with http:// URLs.  This may be
 670 # necessary if the link given on the webpage needs to be transformed in
 671 # some way into one which will work automatically, for example:
 672 # opts=downloadurlmangle=s/prdownload/download/ \
 673 #   http://developer.berlios.de/project/showfiles.php?group_id=2051 \
 674 #   http://prdownload.berlios.de/softdevice/vdr-softdevice-(.*).tgz
 675
 676
 677 sub process_watchline ($$$$$$)
 678 {
 679     my ($line, $watch_version, $pkg_dir, $pkg, $pkg_version, $watchfile) = @_;
 680
 681     my $origline = $line;
 682     my ($base, $site, $dir, $filepattern, $pattern, $lastversion, $action);
 683     my $basedir;
 684     my (@patterns, @sites, @redirections, @basedirs);
 685     my %options = ();
 686
 687     my ($request, $response);
 688     my ($newfile, $newversion);
 689     my $style='new';
 690     my $urlbase;
 691     my $headers = HTTP::Headers->new;
 692
 693     # Comma-separated list of features that sites being queried might
 694     # want to be aware of
 695     $headers->header('X-uscan-features' => 'enhanced-matching');
 696     %dehs_tags = ('package' => $pkg);
 697
 698     if ($watch_version == 1) {
 699         ($site, $dir, $pattern, $lastversion, $action) = split ' ', $line, 5;
 700
 701         if (! defined $lastversion or $site =~ /\(.*\)/ or $dir =~ /\(.*\)/) {
 702             warn "$progname warning: there appears to be a version 2 format line in\n  the version 1 watchfile $watchfile;\n  Have you forgotten a 'version=2' line at the start, perhaps?\n  Skipping the line: $line\n";
 703             return 1;
 704         }
 705         if ($site !~ m%\w+://%) {
 706             $site = "ftp://$site";
 707             if ($pattern !~ /\(.*\)/) {
 708                 # watch_version=1 and old style watchfile;
 709                 # pattern uses ? and * shell wildcards; everything from the
 710                 # first to last of these metachars is the pattern to match on
 711                 $pattern =~ s/(\?|\*)/($1/;
 712                 $pattern =~ s/(\?|\*)([^\?\*]*)$/$1)$2/;
 713                 $pattern =~ s/\./\\./g;
 714                 $pattern =~ s/\?/./g;
 715                 $pattern =~ s/\*/.*/g;
 716                 $style='old';
 717                 warn "$progname warning: Using very old style of filename pattern in $watchfile\n  (this might lead to incorrect results): $3\n";
 718             }
 719         }
 720
 721         # Merge site and dir
 722         $base = "$site/$dir/";
 723         $base =~ s%(?<!:)//%/%g;
 724         $base =~ m%^(\w+://[^/]+)%;
 725         $site = $1;
 726     } else {
 727         # version 2/3 watchfile
 728         if ($line =~ s/^opt(?:ion)?s=//) {
 729             my $opts;
 730             if ($line =~ s/^"(.*?)"\s+//) {
 731                 $opts=$1;
 732             } elsif ($line =~ s/^(\S+)\s+//) {
 733                 $opts=$1;
 734             } else {
 735                 warn "$progname warning: malformed opts=... in watchfile, skipping line:\n$origline\n";
 736                 return 1;
 737             }
 738
 739             my @opts = split /,/, $opts;
 740             foreach my $opt (@opts) {
 741                 if ($opt eq 'pasv' or $opt eq 'passive') {
 742                     $options{'pasv'}=1;
 743                 }
 744                 elsif ($opt eq 'active' or $opt eq 'nopasv'
 745                        or $opt eq 'nopassive') {
 746                     $options{'pasv'}=0;
 747                 }
 748                 elsif ($opt =~ /^uversionmangle\s*=\s*(.+)/) {
 749                     @{$options{'uversionmangle'}} = split /;/, $1;
 750                 }
 751                 elsif ($opt =~ /^dversionmangle\s*=\s*(.+)/) {
 752                     @{$options{'dversionmangle'}} = split /;/, $1;
 753                 }
 754                 elsif ($opt =~ /^versionmangle\s*=\s*(.+)/) {
 755                     @{$options{'uversionmangle'}} = split /;/, $1;
 756                     @{$options{'dversionmangle'}} = split /;/, $1;
 757                 }
 758                 elsif ($opt =~ /^filenamemangle\s*=\s*(.+)/) {
 759                     @{$options{'filenamemangle'}} = split /;/, $1;
 760                 }
 761                 elsif ($opt =~ /^downloadurlmangle\s*=\s*(.+)/) {
 762                     @{$options{'downloadurlmangle'}} = split /;/, $1;
 763                 }
 764                 else {
 765                     warn "$progname warning: unrecognised option $opt\n";
 766                 }
 767             }
 768         }
 769
 770         ($base, $filepattern, $lastversion, $action) = split ' ', $line, 4;
 771
 772         if ($base =~ s%/([^/]*\([^/]*\)[^/]*)$%/%) {
 773             # Last component of $base has a pair of parentheses, so no
 774             # separate filepattern field; we remove the filepattern from the
 775             # end of $base and rescan the rest of the line
 776             $filepattern = $1;
 777             (undef, $lastversion, $action) = split ' ', $line, 3;
 778         }
 779
 780         if ((!$lastversion or $lastversion eq 'debian') and not defined $pkg_version) {
 781             warn "$progname warning: Unable to determine current version\n  in $watchfile, skipping:\n  $line\n";
 782             return 1;
 783         }
 784
 785         # Check all's OK
 786         if ($filepattern !~ /\(.*\)/) {
 787             warn "$progname warning: Filename pattern missing version delimiters ()\n  in $watchfile, skipping:\n  $line\n";
 788             return 1;
 789         }
 790
 791         # Check validity of options
 792         if ($base =~ /^ftp:/ and exists $options{'downloadurlmangle'}) {
 793             warn "$progname warning: downloadurlmangle option invalid for ftp sites,\n  ignoring in $watchfile:\n  $line\n";
 794         }
 795
 796         # Handle sf.net addresses specially
 797         if ($base =~ m%^http://sf\.net/%) {
 798             $base =~ s%^http://sf\.net/%http://qa.debian.org/watch/sf.php/%;
 799             $filepattern .= '(?:\?.*)?';
 800         }
 801         if ($base =~ m%^(\w+://[^/]+)%) {
 802             $site = $1;
 803         } else {
 804             warn "$progname warning: Can't determine protocol and site in\n  $watchfile, skipping:\n  $line\n";
 805             return 1;
 806         }
 807
 808         # Find the path with the greatest version number matching the regex
 809         $base = recursive_regex_dir($base, \%options, $watchfile);
 810         if ($base eq '') { return 1; }
 811
 812         # We're going to make the pattern
 813         # (?:(?:http://site.name)?/dir/path/)?base_pattern
 814         # It's fine even for ftp sites
 815         $basedir = $base;
 816         $basedir =~ s%^\w+://[^/]+/%/%;
 817         $pattern = "(?:(?:$site)?" . quotemeta($basedir) . ")?$filepattern";
 818     }
 819
 820     if (! $lastversion or $lastversion eq 'debian') {
 821         if (defined $pkg_version) {
 822             $lastversion=$pkg_version;
 823         } else {
 824             warn "$progname warning: Unable to determine current version\n  in $watchfile, skipping:\n  $line\n";
 825             return 1;
 826         }
 827     }
 828     # And mangle it if requested
 829     my $mangled_lastversion;
 830     $mangled_lastversion = $lastversion;
 831     foreach my $pat (@{$options{'dversionmangle'}}) {
 832         if (! safe_replace(\$mangled_lastversion, $pat)) {
 833             warn "$progname: In $watchfile, potentially"
 834               . " unsafe or malformed dversionmangle"
 835               . " pattern:\n  '$pat'"
 836               . " found. Skipping watchline\n"
 837               . "  $line\n";
 838             return 1;
 839         }
 840     }
 841     if($opt_download_current_version) {
 842         $download_version = $mangled_lastversion;
 843         $force_download = 1;
 844     }
 845
 846     # Check all's OK
 847     if ($pattern !~ /\(.*\)/) {
 848         warn "$progname warning: Filename pattern missing version delimiters ()\n  in $watchfile, skipping:\n  $line\n";
 849         return 1;
 850     }
 851
 852     push @patterns, $pattern;
 853     push @sites, $site;
 854     push @basedirs, $basedir;
 855
 856     # What is the most recent file, based on the filenames?
 857     # We first have to find the candidates, then we sort them using
 858     # Devscripts::Versort::versort
 859     if ($site =~ m%^http(s)?://%) {
 860         if (defined($1) and !$haveSSL) {
 861             die "$progname: you must have the libcrypt-ssleay-perl package installed\nto use https URLs\n";
 862         }
 863         print STDERR "$progname debug: requesting URL $base\n" if $debug;
 864         $request = HTTP::Request->new('GET', $base, $headers);
 865         $response = $user_agent->request($request);
 866         if (! $response->is_success) {
 867             warn "$progname warning: In watchfile $watchfile, reading webpage\n  $base failed: " . $response->status_line . "\n";
 868             return 1;
 869         }
 870
 871         @redirections = @{$user_agent->get_redirections};
 872
 873         print STDERR "$progname debug: redirections: @redirections\n"
 874             if $debug;
 875
 876         foreach my $_redir (@redirections) {
 877             my $base_dir = $_redir;
 878
 879             $base_dir =~ s%^\w+://[^/]+/%/%;
 880             if ($_redir =~ m%^(\w+://[^/]+)%) {
 881                 my $base_site = $1;
 882
 883                 push @patterns, "(?:(?:$base_site)?" . quotemeta($base_dir) . ")?$filepattern";
 884                 push @sites, $base_site;
 885                 push @basedirs, $base_dir;
 886
 887                 # remove the filename, if any
 888                 my $base_dir_orig = $base_dir;
 889                 $base_dir =~ s%/[^/]*$%/%;
 890                 if ($base_dir ne $base_dir_orig) {
 891                     push @patterns, "(?:(?:$base_site)?" . quotemeta($base_dir) . ")?$filepattern";
 892                     push @sites, $base_site;
 893                     push @basedirs, $base_dir;
 894                 }
 895             }
 896         }
 897
 898         my $content = $response->content;
 899         print STDERR "$progname debug: received content:\n$content\[End of received content]\n"
 900             if $debug;
 901         # We need this horrid stuff to handle href=foo type
 902         # links.  OK, bad HTML, but we have to handle it nonetheless.
 903         # It's bug #89749.
 904         $content =~ s/href\s*=\s*(?=[^\"\'])([^\s>]+)/href="$1"/ig;
 905         # Strip comments
 906         $content =~ s/<!-- .*?-->//sg;
 907         # Is there a base URL given?
 908         if ($content =~ /<\s*base\s+[^>]*href\s*=\s*([\"\'])(.*?)\1/i) {
 909             # Ensure it ends with /
 910             $urlbase = "$2/";
 911             $urlbase =~ s%//$%/%;
 912         } else {
 913             # May have to strip a base filename
 914             ($urlbase = $base) =~ s%/[^/]*$%/%;
 915         }
 916
 917         print STDERR "$progname debug: matching pattern(s) @patterns\n" if $debug;
 918         my @hrefs;
 919         while ($content =~ m/<\s*a\s+[^>]*href\s*=\s*([\"\'])(.*?)\1/sgi) {
 920             my $href = $2;
 921             $href =~ s/\n//g;
 922             foreach my $_pattern (@patterns) {
 923                 if ($href =~ m&^$_pattern$&) {
 924                     if ($watch_version == 2) {
 925                         # watch_version 2 only recognised one group; the code
 926                         # below will break version 2 watchfiles with a construction
 927                         # such as file-([\d\.]+(-\d+)?) (bug #327258)
 928                         push @hrefs, [$1, $href];
 929                     } else {
 930                         # need the map { ... } here to handle cases of (...)?
 931                         # which may match but then return undef values
 932                         my $mangled_version =
 933                             join(".", map { $_ if defined($_) }
 934                                 $href =~ m&^$_pattern$&);
 935                         foreach my $pat (@{$options{'uversionmangle'}}) {
 936                             if (! safe_replace(\$mangled_version, $pat)) {
 937                                 warn "$progname: In $watchfile, potentially"
 938                                  . " unsafe or malformed uversionmangle"
 939                                   . " pattern:\n  '$pat'"
 940                                   . " found. Skipping watchline\n"
 941                                   . "  $line\n";
 942                                 return 1;
 943                             }
 944                         }
 945                         push @hrefs, [$mangled_version, $href];
 946                     }
 947                 }
 948             }
 949         }
 950         if (@hrefs) {
 951             if ($verbose) {
 952                 print "-- Found the following matching hrefs:\n";
 953                 foreach my $href (@hrefs) { print "     $$href[1]\n"; }
 954             }
 955             if (defined $download_version) {
 956                 my @vhrefs = grep { $$_[0] eq $download_version } @hrefs;
 957                 if (@vhrefs) {
 958                     ($newversion, $newfile) = @{$vhrefs[0]};
 959                 } else {
 960                     warn "$progname warning: In $watchfile no matching hrefs for version $download_version"
 961                         . " in watch line\n  $line\n";
 962                     return 1;
 963                 }
 964             } else {
 965                 @hrefs = Devscripts::Versort::versort(@hrefs);
 966                 ($newversion, $newfile) = @{$hrefs[0]};
 967             }
 968         } else {
 969             warn "$progname warning: In $watchfile,\n  no matching hrefs for watch line\n  $line\n";
 970             return 1;
 971         }
 972     }
 973     else {
 974         # Better be an FTP site
 975         if ($site !~ m%^ftp://%) {
 976             warn "$progname warning: Unknown protocol in $watchfile, skipping:\n  $site\n";
 977             return 1;
 978         }
 979
 980         if (exists $options{'pasv'}) {
 981             $ENV{'FTP_PASSIVE'}=$options{'pasv'};
 982         }
 983         print STDERR "$progname debug: requesting URL $base\n" if $debug;
 984         $request = HTTP::Request->new('GET', $base);
 985         $response = $user_agent->request($request);
 986         if (exists $options{'pasv'}) {
 987             if (defined $passive) { $ENV{'FTP_PASSIVE'}=$passive; }
 988             else { delete $ENV{'FTP_PASSIVE'}; }
 989         }
 990         if (! $response->is_success) {
 991             warn "$progname warning: In watchfile $watchfile, reading FTP directory\n  $base failed: " . $response->status_line . "\n";
 992             return 1;
 993         }
 994
 995         my $content = $response->content;
 996         print STDERR "$progname debug: received content:\n$content\[End of received content]\n"
 997             if $debug;
 998
 999         # FTP directory listings either look like:
1000         # info info ... info filename [ -> linkname]
1001         # or they're HTMLised (if they've been through an HTTP proxy)
1002         # so we may have to look for <a href="filename"> type patterns
1003         print STDERR "$progname debug: matching pattern $pattern\n" if $debug;
1004         my (@files);
1005
1006         # We separate out HTMLised listings from standard listings, so
1007         # that we can target our search correctly
1008         if ($content =~ /<\s*a\s+[^>]*href/i) {
1009             while ($content =~
1010                 m/(?:<\s*a\s+[^>]*href\s*=\s*\")((?-i)$pattern)\"/gi) {
1011                 my $file = $1;
1012                 my $mangled_version = join(".", $file =~ m/^$pattern$/);
1013                 foreach my $pat (@{$options{'uversionmangle'}}) {
1014                     if (! safe_replace(\$mangled_version, $pat)) {
1015                         warn "$progname: In $watchfile, potentially"
1016                           . " unsafe or malformed uversionmangle"
1017                           . " pattern:\n  '$pat'"
1018                           . " found. Skipping watchline\n"
1019                           . "  $line\n";
1020                         return 1;
1021                     }
1022                 }
1023                 push @files, [$mangled_version, $file];
1024             }
1025         } else {
1026             # they all look like:
1027             # info info ... info filename [ -> linkname]
1028             while ($content =~ m/\s($filepattern)(\s+->\s+\S+)?$/mg) {
1029                 my $file = $1;
1030                 my $mangled_version = join(".", $file =~ m/^$filepattern$/);
1031                 foreach my $pat (@{$options{'uversionmangle'}}) {
1032                     if (! safe_replace(\$mangled_version, $pat)) {
1033                         warn "$progname: In $watchfile, potentially"
1034                           . " unsafe or malformed uversionmangle"
1035                           . " pattern:\n  '$pat'"
1036                           . " found. Skipping watchline\n"
1037                           . "  $line\n";
1038                         return 1;
1039                     }
1040                 }
1041                 push @files, [$mangled_version, $file];
1042             }
1043         }
1044
1045         if (@files) {
1046             if ($verbose) {
1047                 print "-- Found the following matching files:\n";
1048                 foreach my $file (@files) { print "     $$file[1]\n"; }
1049             }
1050             if (defined $download_version) {
1051                 my @vfiles = grep { $$_[0] eq $download_version } @files;
1052                 if (@vfiles) {
1053                     ($newversion, $newfile) = @{$vfiles[0]};
1054                 } else {
1055                     warn "$progname warning: In $watchfile no matching files for version $download_version"
1056                         . " in watch line\n  $line\n";
1057                     return 1;
1058                 }
1059             } else {
1060                 @files = Devscripts::Versort::versort(@files);
1061                 ($newversion, $newfile) = @{$files[0]};
1062             }
1063         } else {
1064             warn "$progname warning: In $watchfile no matching files for watch line\n  $line\n";
1065             return 1;
1066         }
1067     }
1068
1069     # The original version of the code didn't use (...) in the watch
1070     # file to delimit the version number; thus if there is no (...)
1071     # in the pattern, we will use the old heuristics, otherwise we
1072     # use the new.
1073
1074     if ($style eq 'old') {
1075         # Old-style heuristics
1076         if ($newversion =~ /^\D*(\d+\.(?:\d+\.)*\d+)\D*$/) {
1077             $newversion = $1;
1078         } else {
1079             warn <<"EOF";
1080 $progname warning: In $watchfile, couldn\'t determine a
1081   pure numeric version number from the file name for watch line
1082   $line
1083   and file name $newfile
1084   Please use a new style watchfile instead!
1085 EOF
1086             return 1;
1087         }
1088     }
1089
1090     my $newfile_base=basename($newfile);
1091     if (exists $options{'filenamemangle'}) {
1092         $newfile_base=$newfile;
1093     }
1094     foreach my $pat (@{$options{'filenamemangle'}}) {
1095         if (! safe_replace(\$newfile_base, $pat)) {
1096             warn "$progname: In $watchfile, potentially"
1097               . " unsafe or malformed filenamemangle"
1098               . " pattern:\n  '$pat'"
1099               . " found. Skipping watchline\n"
1100               . "  $line\n";
1101                 return 1;
1102         }
1103     }
1104     # Remove HTTP header trash
1105     if ($site =~ m%^https?://%) {
1106         $newfile_base =~ s/\?.*$//;
1107         # just in case this leaves us with nothing
1108         if ($newfile_base eq '') {
1109             $newfile_base = "$pkg-$newversion.download";
1110         }
1111     }
1112
1113     # So what have we got to report now?
1114     my $upstream_url;
1115     # Upstream URL?  Copying code from below - ugh.
1116     if ($site =~ m%^https?://%) {
1117         # absolute URL?
1118         if ($newfile =~ m%^\w+://%) {
1119             $upstream_url = $newfile;
1120         }
1121         # absolute filename?
1122         elsif ($newfile =~ m%^/%) {
1123             # Were there any redirections? If so try using those first
1124             if ($#patterns > 0) {
1125                 # replace $site here with the one we were redirected to
1126                 foreach my $index (0 .. $#patterns) {
1127                     if ("$sites[$index]$newfile" =~ m&^$patterns[$index]$&) {
1128                         $upstream_url = "$sites[$index]$newfile";
1129                         last;
1130                     }
1131                 }
1132                 if (!defined($upstream_url)) {
1133                     if ($debug) {
1134                         warn "$progname warning: Unable to determine upstream url from redirections,\n" .
1135                             "defaulting to using site specified in watchfile\n";
1136                     }
1137                     $upstream_url = "$sites[0]$newfile";
1138                 }
1139             } else {
1140                 $upstream_url = "$sites[0]$newfile";
1141             }
1142         }
1143         # relative filename, we hope
1144         else {
1145             # Were there any redirections? If so try using those first
1146             if ($#patterns > 0) {
1147                 # replace $site here with the one we were redirected to
1148                 foreach my $index (0 .. $#patterns) {
1149                     # skip unless the basedir looks like a directory
1150                     next unless $basedirs[$index] =~ m%/$%;
1151                     my $nf = "$basedirs[$index]$newfile";
1152                     if ("$sites[$index]$nf" =~ m&^$patterns[$index]$&) {
1153                         $upstream_url = "$sites[$index]$nf";
1154                         last;
1155                     }
1156                 }
1157                 if (!defined($upstream_url)) {
1158                     if ($debug) {
1159                         warn "$progname warning: Unable to determine upstream url from redirections,\n" .
1160                             "defaulting to using site specified in watchfile\n";
1161                     }
1162                     $upstream_url = "$urlbase$newfile";
1163                 }
1164             } else {
1165                 $upstream_url = "$urlbase$newfile";
1166             }
1167         }
1168
1169         # mangle if necessary
1170         $upstream_url =~ s/&amp;/&/g;
1171         if (exists $options{'downloadurlmangle'}) {
1172             foreach my $pat (@{$options{'downloadurlmangle'}}) {
1173                 if (! safe_replace(\$upstream_url, $pat)) {
1174                     warn "$progname: In $watchfile, potentially"
1175                       . " unsafe or malformed downloadurlmangle"
1176                       . " pattern:\n  '$pat'"
1177                       . " found. Skipping watchline\n"
1178                       . "  $line\n";
1179                     return 1;
1180                 }
1181             }
1182         }
1183     }
1184     else {
1185         # FTP site
1186         $upstream_url = "$base$newfile";
1187     }
1188
1189     $dehs_tags{'debian-uversion'} = $lastversion;
1190     $dehs_tags{'debian-mangled-uversion'} = $mangled_lastversion;
1191     $dehs_tags{'upstream-version'} = $newversion;
1192     $dehs_tags{'upstream-url'} = $upstream_url;
1193
1194     # Can't just use $lastversion eq $newversion, as then 0.01 and 0.1
1195     # compare different, whereas they are treated as equal by dpkg
1196     if (system("dpkg", "--compare-versions", "$mangled_lastversion", "eq", "$newversion") == 0) {
1197         if ($verbose or ($download == 0 and $report and ! $dehs)) {
1198             print $pkg_report_header;
1199             $pkg_report_header = '';
1200             print "Newest version on remote site is $newversion, local version is $lastversion\n" .
1201                 ($mangled_lastversion eq $lastversion ? "" : " (mangled local version number $mangled_lastversion)\n");
1202             print " => Package is up to date\n";
1203         }
1204         $dehs_tags{'status'} = "up to date";
1205         if (! $force_download) {
1206             return 0;
1207         } else {
1208             $download = 1;
1209         }
1210     }
1211
1212     # In all other cases, we'll want to report information even with --report
1213     if ($verbose or ($download == 0 and ! $dehs)) {
1214         print $pkg_report_header;
1215         $pkg_report_header = '';
1216         print "Newest version on remote site is $newversion, local version is $lastversion\n" .
1217             ($mangled_lastversion eq $lastversion ? "" : " (mangled local version number $mangled_lastversion)\n");
1218     }
1219
1220     # We use dpkg's rules to determine whether our current version
1221     # is newer or older than the remote version.
1222     if (!defined $download_version) {
1223         if (system("dpkg", "--compare-versions", "$mangled_lastversion", "gt", "$newversion") == 0) {
1224             if ($verbose) {
1225                 print " => remote site does not even have current version\n";
1226             } elsif ($dehs) {
1227                 $dehs_tags{'status'} = "Debian version newer than remote site";
1228             } else {
1229                 print "$pkg: remote site does not even have current version\n";
1230             }
1231             return 0;
1232         } else {
1233             # There's a newer upstream version available, which may already
1234             # be on our system or may not be
1235             $found++;
1236         }
1237     } else {
1238         # Flag that we found a newer upstream version, so that the exit status
1239         # is set correctly
1240         $found++;
1241     }
1242
1243     if (defined $pkg_dir) {
1244         if (! -d "$destdir") {
1245             print "Package directory '$destdir to store downloaded file is not existing\n";
1246             return 1;
1247         }
1248         if (-f "$destdir/$newfile_base") {
1249             print " => $newfile_base already in package directory\n"
1250                 if $verbose or ($download == 0 and ! $dehs);
1251             return 0;
1252         }
1253         if (-f "$destdir/${pkg}_${newversion}.orig.tar.gz") {
1254             print " => ${pkg}_${newversion}.orig.tar.gz already in package directory '$destdir'\n"
1255                 if $verbose or ($download == 0 and ! $dehs);
1256             return 0;
1257         }
1258         elsif (-f "$destdir/${pkg}_${newversion}.orig.tar.bz2") {
1259             print " => ${pkg}_${newversion}.orig.tar.bz2 already in package directory '$destdir'\n"
1260                 if $verbose or ($download == 0 and ! $dehs);
1261             return 0;
1262         }
1263     }
1264
1265     if ($force_download and $verbose) {
1266         print " => Forcing download as requested\n";
1267     } elsif ($verbose) {
1268         print " => Newer version available from\n";
1269         print "    $upstream_url\n";
1270     } elsif ($dehs) {
1271         $dehs_tags{'status'} = "Newer version available";
1272     } else {
1273         my $msg_header = "$pkg: ";
1274         $msg_header .= $force_download ? "Version" : "Newer version";
1275         print "$msg_header ($newversion) available on remote site:\n  $upstream_url\n  (local version is $lastversion" .
1276             ($mangled_lastversion eq $lastversion ? "" : ", mangled local version number $mangled_lastversion") .
1277             ")\n";
1278     }
1279
1280     if ($download < 0) {
1281         my $msg = "Not downloading as --package was used.  Use --download to force downloading.";
1282         if ($dehs) {
1283             dehs_msg($msg);
1284         } else {
1285             print "$msg\n";
1286         }
1287         return 0;
1288     }
1289     return 0 unless $download;
1290
1291     print "-- Downloading updated package $newfile_base\n" if $verbose;
1292     if (! -d "$destdir") {
1293         print "Package directory '$destdir to store downloaded file is not existing\n";
1294         return 1;
1295     }
1296     # Download newer package
1297     if ($upstream_url =~ m%^http(s)?://%) {
1298         if (defined($1) and !$haveSSL) {
1299             die "$progname: you must have the libcrypt-ssleay-perl package installed\nto use https URLs\n";
1300         }
1301         # substitute HTML entities
1302         # Is anything else than "&amp;" required?  I doubt it.
1303         print STDERR "$progname debug: requesting URL $upstream_url\n" if $debug;
1304         $request = HTTP::Request->new('GET', $upstream_url);
1305         $response = $user_agent->request($request, "$destdir/$newfile_base");
1306         if (! $response->is_success) {
1307             if (defined $pkg_dir) {
1308                 warn "$progname warning: In directory $pkg_dir, downloading\n  $upstream_url failed: " . $response->status_line . "\n";
1309             } else {
1310                 warn "$progname warning: Downloading\n $upstream_url failed:\n" . $response->status_line . "\n";
1311             }
1312             return 1;
1313         }
1314     }
1315     else {
1316         # FTP site
1317         if (exists $options{'pasv'}) {
1318             $ENV{'FTP_PASSIVE'}=$options{'pasv'};
1319         }
1320         print STDERR "$progname debug: requesting URL $upstream_url\n" if $debug;
1321         $request = HTTP::Request->new('GET', "$upstream_url");
1322         $response = $user_agent->request($request, "$destdir/$newfile_base");
1323         if (exists $options{'pasv'}) {
1324             if (defined $passive) { $ENV{'FTP_PASSIVE'}=$passive; }
1325             else { delete $ENV{'FTP_PASSIVE'}; }
1326         }
1327         if (! $response->is_success) {
1328             if (defined $pkg_dir) {
1329                 warn "$progname warning: In directory $pkg_dir, downloading\n  $upstream_url failed: " . $response->status_line . "\n";
1330             } else {
1331                 warn "$progname warning: Downloading\n $upstream_url failed:\n" . $response->status_line . "\n";
1332             }
1333             return 1;
1334         }
1335     }
1336
1337     if ($repack and $newfile_base =~ /^(.*)\.(tar\.bz2|tbz2?)$/) {
1338         print "-- Repacking from bzip2 to gzip\n" if $verbose;
1339         my $newfile_base_gz = "$1.tar.gz";
1340         system("bunzip2 -c $destdir/$newfile_base | gzip -n -9 > $destdir/$newfile_base_gz") == 0
1341           or die "repacking from bzip2 to gzip failed\n";
1342         unlink "$destdir/$newfile_base";
1343         $newfile_base = $newfile_base_gz;
1344     }
1345
1346     if ($repack and $newfile_base =~ /^(.*)\.(tar\.lzma|tlz(?:ma?)?)$/) {
1347         print "-- Repacking from lzma to gzip\n" if $verbose;
1348         my $newfile_base_gz = "$1.tar.gz";
1349         system("lzma -cd $destdir/$newfile_base | gzip -n -9 > $destdir/$newfile_base_gz") == 0
1350           or die "repacking from lzma to gzip failed\n";
1351         unlink "$destdir/$newfile_base";
1352         $newfile_base = $newfile_base_gz;
1353     }
1354
1355     if ($repack and $newfile_base =~ /^(.*)\.(tar\.xz|txz)$/) {
1356         print "-- Repacking from xz to gzip\n" if $verbose;
1357         my $newfile_base_gz = "$1.tar.gz";
1358         system("xz -cd $destdir/$newfile_base | gzip -n -9 > $destdir/$newfile_base_gz") == 0
1359           or die "repacking from xz to gzip failed\n";
1360         unlink "$destdir/$newfile_base";
1361         $newfile_base = $newfile_base_gz;
1362     }
1363
1364     if ($repack and $newfile_base =~ /^(.*)\.zip$/) {
1365         print "-- Repacking from zip to .tar.gz\n" if $verbose;
1366
1367         system('command -v unzip >/dev/null 2>&1') >> 8 == 0
1368           or die("unzip binary not found. You need to install the package unzip to be able to repack .zip upstream archives.\n");
1369
1370         my $newfile_base_gz = "$1.tar.gz";
1371         my $tempdir = tempdir ( "uscanXXXX", TMPDIR => 1, CLEANUP => 1 );
1372         system("unzip -q -d $tempdir $destdir/$newfile_base; GZIP=-9 tar -C $tempdir -czf $destdir/$newfile_base_gz .") == 0
1373           or die("Repacking from zip to tar.gz failed\n");
1374         unlink "$destdir/$newfile_base";
1375         $newfile_base = $newfile_base_gz;
1376     }
1377
1378     if ($newfile_base =~ /\.(tar\.gz|tgz|tar\.bz2|tbz2?)$/) {
1379         my $filetype = `file $destdir/$newfile_base`;
1380         $filetype =~ s%^\.\./\Q$newfile_base\E: %%;
1381         unless ($filetype =~ /compressed data/) {
1382             warn "$progname warning: $destdir/$newfile_base does not appear to be a compressed file;\nthe file command says: $filetype\nNot processing this file any further!\n";
1383             return 1;
1384         }
1385     }
1386
1387     if ($newfile_base =~ /\.(tar\.gz|tgz)$/) {
1388         if ($symlink eq 'symlink') {
1389             symlink $newfile_base, "$destdir/${pkg}_${newversion}.orig.tar.gz";
1390         } elsif ($symlink eq 'rename') {
1391             move "$destdir/$newfile_base", "$destdir/${pkg}_${newversion}.orig.tar.gz";
1392         }
1393     }
1394     elsif ($newfile_base =~ /\.(tar\.bz2|tbz2?)$/) {
1395         if ($symlink eq 'symlink') {
1396             symlink $newfile_base, "$destdir/${pkg}_${newversion}.orig.tar.bz2";
1397         } elsif ($symlink eq 'rename') {
1398             move "$destdir/$newfile_base", "$destdir/${pkg}_${newversion}.orig.tar.bz2";
1399         }
1400     }
1401
1402     if ($verbose) {
1403         print "-- Successfully downloaded updated package $newfile_base\n";
1404         if ($newfile_base =~ /\.(tar\.gz|tgz)$/) {
1405             if ($symlink eq 'symlink') {
1406                 print "    and symlinked ${pkg}_${newversion}.orig.tar.gz to it\n";
1407             } elsif ($symlink eq 'rename') {
1408                 print "    and renamed it as ${pkg}_${newversion}.orig.tar.gz\n";
1409             }
1410         }
1411         elsif ($newfile_base =~ /\.(tar\.bz2|tbz2?)$/) {
1412             if ($symlink eq 'symlink') {
1413                 print "    and symlinked ${pkg}_${newversion}.orig.tar.bz2 to it\n";
1414             } elsif ($symlink eq 'rename') {
1415                 print "    and renamed it as ${pkg}_${newversion}.orig.tar.bz2\n";
1416             }
1417         }
1418     } elsif ($dehs) {
1419         my $msg = "Successfully downloaded updated package $newfile_base";
1420         if ($newfile_base =~ /\.(tar\.gz|tgz)$/) {
1421             if ($symlink eq 'symlink') {
1422                 $msg .= " and symlinked ${pkg}_${newversion}.orig.tar.gz to it";
1423             } elsif ($symlink eq 'rename') {
1424                 $msg .= " and renamed it as ${pkg}_${newversion}.orig.tar.gz";
1425             }
1426         }
1427         elsif ($newfile_base =~ /\.(tar\.bz2|tbz2?)$/) {
1428             if ($symlink eq 'symlink') {
1429                 $msg .= " and symlinked ${pkg}_${newversion}.orig.tar.bz2 to it";
1430             } elsif ($symlink eq 'rename') {
1431                 $msg .= " and renamed it as ${pkg}_${newversion}.orig.tar.bz2";
1432             }
1433         }
1434         dehs_msg($msg);
1435     } else {
1436         print "$pkg: Successfully downloaded updated package $newfile_base\n";
1437         if ($newfile_base =~ /\.(tar\.gz|tgz)$/) {
1438             if ($symlink eq 'symlink') {
1439                 print "    and symlinked ${pkg}_${newversion}.orig.tar.gz to it\n";
1440             } elsif ($symlink eq 'rename') {
1441                 print "    and renamed it as ${pkg}_${newversion}.orig.tar.gz\n";
1442             }
1443         }
1444         elsif ($newfile_base =~ /\.(tar\.bz2|tbz2?)$/) {
1445             if ($symlink eq 'symlink') {
1446                 print "    and symlinked ${pkg}_${newversion}.orig.tar.bz2 to it\n";
1447             } elsif ($symlink eq 'rename') {
1448                 print "    and renamed it as ${pkg}_${newversion}.orig.tar.bz2\n";
1449             }
1450         }
1451     }
1452
1453     # Do whatever the user wishes to do
1454     if ($action) {
1455         my $usefile = "$destdir/$newfile_base";
1456         my @cmd = shellwords($action);
1457         if ($symlink =~ /^(symlink|rename)$/
1458             and $newfile_base =~ /\.(tar\.gz|tgz)$/) {
1459             $usefile = "$destdir/${pkg}_${newversion}.orig.tar.gz";
1460         }
1461         elsif ($symlink =~ /^(symlink|rename)$/
1462             and $newfile_base =~ /\.(tar\.bz2|tbz2)$/) {
1463             $usefile = "$destdir/${pkg}_${newversion}.orig.tar.bz2";
1464         }
1465
1466         # Any symlink requests are already handled by uscan
1467         if ($action =~ /^uupdate(\s|$)/) {
1468             push @cmd, "--no-symlink";
1469         }
1470
1471         if ($watch_version > 1) {
1472             push @cmd, ("--upstream-version", "$newversion", "$usefile");
1473         } else {
1474             push @cmd, ("$usefile", "$newversion");
1475         }
1476         my $actioncmd = join(" ", @cmd);
1477         print "-- Executing user specified script\n     $actioncmd\n" if $verbose;
1478         if ($dehs) {
1479             my $msg = "Executing user specified script: $actioncmd; output:\n";
1480             $msg .= `$actioncmd 2>&1`;
1481             dehs_msg($msg);
1482         } else {
1483             system(@cmd);
1484         }
1485     }
1486
1487     return 0;
1488 }
1489
1490
1491 sub recursive_regex_dir ($$$) {
1492     my ($base, $optref, $watchfile)=@_;
1493
1494     $base =~ m%^(\w+://[^/]+)/(.*)$%;
1495     my $site = $1;
1496     my @dirs = split /(\/)/, $2;
1497     my $dir = '/';
1498
1499     foreach my $dirpattern (@dirs) {
1500         if ($dirpattern =~ /\(.*\)/) {
1501             print STDERR "$progname debug: dir=>$dir  dirpattern=>$dirpattern\n"
1502                 if $debug;
1503             my $newest_dir =
1504                 newest_dir($site, $dir, $dirpattern, $optref, $watchfile);
1505             print STDERR "$progname debug: newest_dir => '$newest_dir'\n"
1506                 if $debug;
1507             if ($newest_dir ne '') {
1508                 $dir .= "$newest_dir";
1509             }
1510             else {
1511                 return '';
1512             }
1513         } else {
1514             $dir .= "$dirpattern";
1515         }
1516     }
1517     return $site . $dir;
1518 }
1519
1520
1521 # very similar to code above
1522 sub newest_dir ($$$$$) {
1523     my ($site, $dir, $pattern, $optref, $watchfile) = @_;
1524     my $base = $site.$dir;
1525     my ($request, $response);
1526
1527     if ($site =~ m%^http(s)?://%) {
1528         if (defined($1) and !$haveSSL) {
1529             die "$progname: you must have the libcrypt-ssleay-perl package installed\nto use https URLs\n";
1530         }
1531         print STDERR "$progname debug: requesting URL $base\n" if $debug;
1532         $request = HTTP::Request->new('GET', $base);
1533         $response = $user_agent->request($request);
1534         if (! $response->is_success) {
1535             warn "$progname warning: In watchfile $watchfile, reading webpage\n  $base failed: " . $response->status_line . "\n";
1536             return 1;
1537         }
1538
1539         my $content = $response->content;
1540         print STDERR "$progname debug: received content:\n$content\[End of received content\]\n"
1541             if $debug;
1542         # We need this horrid stuff to handle href=foo type
1543         # links.  OK, bad HTML, but we have to handle it nonetheless.
1544         # It's bug #89749.
1545         $content =~ s/href\s*=\s*(?=[^\"\'])([^\s>]+)/href="$1"/ig;
1546         # Strip comments
1547         $content =~ s/<!-- .*?-->//sg;
1548
1549         my $dirpattern = "(?:(?:$site)?" . quotemeta($dir) . ")?$pattern";
1550
1551         print STDERR "$progname debug: matching pattern $dirpattern\n"
1552             if $debug;
1553         my @hrefs;
1554         while ($content =~ m/<\s*a\s+[^>]*href\s*=\s*([\"\'])(.*?)\1/gi) {
1555             my $href = $2;
1556             if ($href =~ m&^$dirpattern/?$&) {
1557                 my $mangled_version = join(".", $href =~ m&^$dirpattern/?$&);
1558                 push @hrefs, [$mangled_version, $href];
1559             }
1560         }
1561         if (@hrefs) {
1562             @hrefs = Devscripts::Versort::versort(@hrefs);
1563             if ($debug) {
1564                 print "-- Found the following matching hrefs (newest first):\n";
1565                 foreach my $href (@hrefs) { print "     $$href[1]\n"; }
1566             }
1567             my $newdir = $hrefs[0][1];
1568             # just give the final directory component
1569             $newdir =~ s%/$%%;
1570             $newdir =~ s%^.*/%%;
1571             return $newdir;
1572         } else {
1573             warn "$progname warning: In $watchfile,\n  no matching hrefs for pattern\n  $site$dir$pattern";
1574             return 1;
1575         }
1576     }
1577     else {
1578         # Better be an FTP site
1579         if ($site !~ m%^ftp://%) {
1580             return 1;
1581         }
1582
1583         if (exists $$optref{'pasv'}) {
1584             $ENV{'FTP_PASSIVE'}=$$optref{'pasv'};
1585         }
1586         print STDERR "$progname debug: requesting URL $base\n" if $debug;
1587         $request = HTTP::Request->new('GET', $base);
1588         $response = $user_agent->request($request);
1589         if (exists $$optref{'pasv'}) {
1590             if (defined $passive) { $ENV{'FTP_PASSIVE'}=$passive; }
1591             else { delete $ENV{'FTP_PASSIVE'}; }
1592         }
1593         if (! $response->is_success) {
1594             warn "$progname warning: In watchfile $watchfile, reading webpage\n  $base failed: " . $response->status_line . "\n";
1595             return '';
1596         }
1597
1598         my $content = $response->content;
1599         print STDERR "$progname debug: received content:\n$content\[End of received content]\n"
1600             if $debug;
1601
1602         # FTP directory listings either look like:
1603         # info info ... info filename [ -> linkname]
1604         # or they're HTMLised (if they've been through an HTTP proxy)
1605         # so we may have to look for <a href="filename"> type patterns
1606         print STDERR "$progname debug: matching pattern $pattern\n" if $debug;
1607         my (@dirs);
1608
1609         # We separate out HTMLised listings from standard listings, so
1610         # that we can target our search correctly
1611         if ($content =~ /<\s*a\s+[^>]*href/i) {
1612             while ($content =~
1613                 m/(?:<\s*a\s+[^>]*href\s*=\s*\")((?-i)$pattern)\"/gi) {
1614                 my $dir = $1;
1615                 my $mangled_version = join(".", $dir =~ m/^$pattern$/);
1616                 push @dirs, [$mangled_version, $dir];
1617             }
1618         } else {
1619             # they all look like:
1620             # info info ... info filename [ -> linkname]
1621             while ($content =~ m/($pattern)(\s+->\s+\S+)?$/mg) {
1622                 my $dir = $1;
1623                 my $mangled_version = join(".", $dir =~ m/^$pattern$/);
1624                 push @dirs, [$mangled_version, $dir];
1625             }
1626         }
1627         if (@dirs) {
1628             if ($debug) {
1629                 print STDERR "-- Found the following matching dirs:\n";
1630                 foreach my $dir (@dirs) { print STDERR "     $$dir[1]\n"; }
1631             }
1632             @dirs = Devscripts::Versort::versort(@dirs);
1633             my ($newversion, $newdir) = @{$dirs[0]};
1634             return $newdir;
1635         } else {
1636             warn "$progname warning: In $watchfile no matching dirs for pattern\n  $base$pattern\n";
1637             return '';
1638         }
1639     }
1640 }
1641
1642
1643 # parameters are dir, package, upstream version, good dirname
1644 sub process_watchfile ($$$$)
1645 {
1646     my ($dir, $package, $version, $watchfile) = @_;
1647     my $watch_version=0;
1648     my $status=0;
1649     %dehs_tags = ();
1650
1651     unless (open WATCH, $watchfile) {
1652         warn "$progname warning: could not open $watchfile: $!\n";
1653         return 1;
1654     }
1655
1656     while (<WATCH>) {
1657         next if /^\s*\#/;
1658         next if /^\s*$/;
1659         s/^\s*//;
1660
1661     CHOMP:
1662         chomp;
1663         if (s/(?<!\\)\\$//) {
1664             if (eof(WATCH)) {
1665                 warn "$progname warning: $watchfile ended with \\; skipping last line\n";
1666                 $status=1;
1667                 last;
1668             }
1669             $_ .= <WATCH>;
1670             goto CHOMP;
1671         }
1672
1673         if (! $watch_version) {
1674             if (/^version\s*=\s*(\d+)(\s|$)/) {
1675                 $watch_version=$1;
1676                 if ($watch_version < 2 or
1677                     $watch_version > $CURRENT_WATCHFILE_VERSION) {
1678                     warn "$progname ERROR: $watchfile version number is unrecognised; skipping watchfile\n";
1679                     last;
1680                 }
1681                 next;
1682             } else {
1683                 warn "$progname warning: $watchfile is an obsolete version 1 watchfile;\n  please upgrade to a higher version\n  (see uscan(1) for details).\n";
1684                 $watch_version=1;
1685             }
1686         }
1687
1688         # Are there any warnings from this part to give if we're using dehs?
1689         dehs_output if $dehs;
1690
1691         # Handle shell \\ -> \
1692         s/\\\\/\\/g if $watch_version==1;
1693         if ($verbose) {
1694             print "-- In $watchfile, processing watchfile line:\n   $_\n";
1695         } elsif ($download == 0 and ! $dehs) {
1696             $pkg_report_header = "Processing watchfile line for package $package...\n";
1697         }
1698
1699         $status +=
1700             process_watchline($_, $watch_version, $dir, $package, $version,
1701                               $watchfile);
1702         dehs_output if $dehs;
1703     }
1704
1705     close WATCH or
1706         $status=1, warn "$progname warning: problems reading $watchfile: $!\n";
1707
1708     return $status;
1709 }
1710
1711
1712 # Collect up messages for dehs output into a tag
1713 sub dehs_msg ($)
1714 {
1715     my $msg = $_[0];
1716     $msg =~ s/\s*$//;
1717     push @{$dehs_tags{'messages'}}, $msg;
1718 }
1719
1720 sub dehs_warn ($)
1721 {
1722     my $warning = $_[0];
1723     $warning =~ s/\s*$//;
1724     push @{$dehs_tags{'warnings'}}, $warning;
1725 }
1726
1727 sub dehs_die ($)
1728 {
1729     my $msg = $_[0];
1730     $msg =~ s/\s*$//;
1731     %dehs_tags = ('errors' => "$msg");
1732     $dehs_end_output=1;
1733     dehs_output;
1734     exit 1;
1735 }
1736
1737 sub dehs_output ()
1738 {
1739     return unless $dehs;
1740
1741     if (! $dehs_start_output) {
1742         print "<dehs>\n";
1743         $dehs_start_output=1;
1744     }
1745
1746     for my $tag (qw(package debian-uversion debian-mangled-uversion
1747                     upstream-version upstream-url
1748                     status messages warnings errors)) {
1749         if (exists $dehs_tags{$tag}) {
1750             if (ref $dehs_tags{$tag} eq "ARRAY") {
1751                 foreach my $entry (@{$dehs_tags{$tag}}) {
1752                     $entry =~ s/</&lt;/g;
1753                     $entry =~ s/>/&gt;/g;
1754                     $entry =~ s/&/&amp;/g;
1755                     print "<$tag>$entry</$tag>\n";
1756                 }
1757             } else {
1758                 $dehs_tags{$tag} =~ s/</&lt;/g;
1759                 $dehs_tags{$tag} =~ s/>/&gt;/g;
1760                 $dehs_tags{$tag} =~ s/&/&amp;/g;
1761                 print "<$tag>$dehs_tags{$tag}</$tag>\n";
1762             }
1763         }
1764     }
1765     if ($dehs_end_output) {
1766         print "</dehs>\n";
1767     }
1768
1769     # Don't repeat output
1770     %dehs_tags = ();
1771 }
1772
1773 sub quoted_regex_parse($) {
1774     my $pattern = shift;
1775     my %closers = ('{', '}', '[', ']', '(', ')', '<', '>');
1776
1777     $pattern =~ /^(s|tr|y)(.)(.*)$/;
1778     my ($sep, $rest) = ($2, $3 || '');
1779     my $closer = $closers{$sep};
1780
1781     my $parsed_ok = 1;
1782     my $regexp = '';
1783     my $replacement = '';
1784     my $flags = '';
1785     my $open = 1;
1786     my $last_was_escape = 0;
1787     my $in_replacement = 0;
1788
1789     for my $char (split //, $rest) {
1790         if ($char eq $sep and ! $last_was_escape) {
1791             $open++;
1792             if ($open == 1) {
1793                 if ($in_replacement) {
1794                     # Separator after end of replacement
1795                     $parsed_ok = 0;
1796                     last;
1797                 } else {
1798                     $in_replacement = 1;
1799                 }
1800             } else {
1801                 if ($open > 1) {
1802                     if ($in_replacement) {
1803                         $replacement .= $char;
1804                     } else {
1805                         $regexp .= $char;
1806                     }
1807                 }
1808             }
1809         } elsif ($char eq $closer and ! $last_was_escape) {
1810             $open--;
1811             if ($open) {
1812                 if ($in_replacement) {
1813                     $replacement .= $char;
1814                 } else {
1815                     $regexp .= $char;
1816                 }
1817             } elsif ($open < 0) {
1818                 $parsed_ok = 0;
1819                 last;
1820             }
1821         } else {
1822             if ($in_replacement) {
1823                 if ($open) {
1824                     $replacement .= $char;
1825                 } else {
1826                     $flags .= $char;
1827                 }
1828             } else {
1829                 $regexp .= $char;
1830             }
1831         }
1832         # Don't treat \\ as an escape
1833         $last_was_escape = ($char eq '\\' and ! $last_was_escape);
1834     }
1835
1836     $parsed_ok = 0 unless $in_replacement and $open == 0;
1837
1838     return ($parsed_ok, $regexp, $replacement, $flags);
1839 }
1840
1841 sub safe_replace($$) {
1842     my ($in, $pat) = @_;
1843     $pat =~ s/^\s*(.*?)\s*$/$1/;
1844
1845     $pat =~ /^(s|tr|y)(.)/;
1846     my ($op, $sep) = ($1, $2 || '');
1847     my $esc = "\Q$sep\E";
1848     my ($parsed_ok, $regexp, $replacement, $flags);
1849
1850     if ($sep eq '{' or $sep eq '(' or $sep eq '[' or $sep eq '<') {
1851         ($parsed_ok, $regexp, $replacement, $flags) = quoted_regex_parse($pat);
1852
1853         return 0 unless $parsed_ok;
1854     } elsif ($pat !~ /^(?:s|tr|y)$esc((?:\\.|[^\\$esc])*)$esc((?:\\.|[^\\$esc])*)$esc([a-z]*)$/) {
1855         return 0;
1856     } else {
1857         ($regexp, $replacement, $flags) = ($1, $2, $3);
1858     }
1859
1860     my $safeflags = $flags;
1861     if ($op eq 'tr' or $op eq 'y') {
1862         $safeflags =~ tr/cds//cd;
1863         return 0 if $safeflags ne $flags;
1864
1865         $regexp =~ s/\\(.)/$1/g;
1866         $replacement =~ s/\\(.)/$1/g;
1867
1868         $regexp =~ s/([^-])/'\\x'  . unpack 'H*', $1/ge;
1869         $replacement =~ s/([^-])/'\\x'  . unpack 'H*', $1/ge;
1870
1871         eval "\$\$in =~ tr<$regexp><$replacement>$flags;";
1872
1873         if ($@) {
1874             return 0;
1875         } else {
1876             return 1;
1877         }
1878     } else {
1879         $safeflags =~ tr/gix//cd;
1880         return 0 if $safeflags ne $flags;
1881
1882         my $global = ($flags =~ s/g//);
1883         $flags = "(?$flags)" if length $flags;
1884
1885         my $slashg;
1886         if ($regexp =~ /(?<!\\)(\\\\)*\\G/) {
1887             $slashg = 1;
1888             # if it's not initial, it is too dangerous
1889             return 0 if $regexp =~ /^.*[^\\](\\\\)*\\G/;
1890         }
1891
1892         # Behave like Perl and treat e.g. "\." in replacement as "."
1893         # We allow the case escape characters to remain and
1894         # process them later
1895         $replacement =~ s/(^|[^\\])\\([^luLUE])/$1$2/g;
1896
1897         # Unescape escaped separator characters
1898         $replacement =~ s/\\\Q$sep\E/$sep/g;
1899         # If bracketing quotes were used, also unescape the
1900         # closing version
1901         $replacement =~ s/\\\Q}\E/}/g if $sep eq '{';
1902         $replacement =~ s/\\\Q]\E/]/g if $sep eq '[';
1903         $replacement =~ s/\\\Q)\E/)/g if $sep eq '(';
1904         $replacement =~ s/\\\Q>\E/>/g if $sep eq '<';
1905
1906         # The replacement below will modify $replacement so keep
1907         # a copy. We'll need to restore it to the current value if
1908         # the global flag was set on the input pattern.
1909         my $orig_replacement = $replacement;
1910
1911         my ($first, $last, $pos, $zerowidth, $matched, @captures) = (0, -1, 0);
1912         while (1) {
1913             eval {
1914                 # handle errors due to unsafe constructs in $regexp
1915                 no re 'eval';
1916
1917                 # restore position
1918                 pos($$in) = $pos if $pos;
1919
1920                 if ($zerowidth) {
1921                     # previous match was a zero-width match, simulate it to set
1922                     # the internal flag that avoids the infinite loop
1923                     $$in =~ /()/g;
1924                 }
1925                 # Need to use /g to make it use and save pos()
1926                 $matched = ($$in =~ /$flags$regexp/g);
1927
1928                 if ($matched) {
1929                     # save position and size of the match
1930                     my $oldpos = $pos;
1931                     $pos = pos($$in);
1932                     ($first, $last) = ($-[0], $+[0]);
1933
1934                     if ($slashg) {
1935                         # \G in the match, weird things can happen
1936                         $zerowidth = ($pos == $oldpos);
1937                         # For example, matching without a match
1938                         $matched = 0 if (not defined $first
1939                             or not defined $last);
1940                     } else {
1941                         $zerowidth = ($last - $first == 0);
1942                     }
1943                     for my $i (0..$#-) {
1944                         $captures[$i] = substr $$in, $-[$i], $+[$i] - $-[$i];
1945                     }
1946                 }
1947             };
1948             return 0 if $@;
1949
1950             # No match; leave the original string  untouched but return
1951             # success as there was nothing wrong with the pattern
1952             return 1 unless $matched;
1953
1954             # Replace $X
1955             $replacement =~ s/[\$\\](\d)/defined $captures[$1] ? $captures[$1] : ''/ge;
1956             $replacement =~ s/\$\{(\d)\}/defined $captures[$1] ? $captures[$1] : ''/ge;
1957             $replacement =~ s/\$&/$captures[0]/g;
1958
1959             # Make \l etc escapes work
1960             $replacement =~ s/\\l(.)/lc $1/e;
1961             $replacement =~ s/\\L(.*?)(\\E|\z)/lc $1/e;
1962             $replacement =~ s/\\u(.)/uc $1/e;
1963             $replacement =~ s/\\U(.*?)(\\E|\z)/uc $1/e;
1964
1965             # Actually do the replacement
1966             substr $$in, $first, $last - $first, $replacement;
1967             # Update position
1968             $pos += length($replacement) - ($last - $first);
1969
1970             if ($global) {
1971                 $replacement = $orig_replacement;
1972             } else {
1973                 last;
1974             }
1975         }
1976
1977         return 1;
1978     }
1979 }