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