#!/usr/bin/perl
# Grep debian testing excuses file.
# 
# Copyright 2002 Joey Hess <joeyh@debian.org>
# Small mods Copyright 2002 Julian Gilbey <jdg@debian.org>

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

use vars qw($excuses_gz);

BEGIN {
    eval { require LWP::UserAgent; };
    if ($@ =~ /^Can\'t locate LWP\/UserAgent\.pm/) {
	die "You must have the libwww-perl package installed to use this script\n";
    }
    $excuses_gz='';
}

END {
    if ($excuses_gz) { unlink $excuses_gz; }
}

use IO::File;
use POSIX qw(tmpnam);

(my $progname = $0) =~ s|.*/||;

my $usage = <<"EOF";
Usage: $progname [options] [<maintainer>|<email>|<package>]
  Grep the Debian update_excuses file to find out about the packages
  of <maintainer>, <email> or <package>.
Options:
  --help              Show this help
  --version           Give version information
EOF

my $version = <<"EOF";
This is $progname, from the Debian devscripts package, version ###VERSION###
This code is copyright 2002 by Joey Hess <joeyh\@debian.org>,
and modifications are copyright 2002 by Julian Gilbey <jdg\@debian.org>
This program comes with ABSOLUTELY NO WARRANTY.
You are free to redistribute this code under the terms of the
GNU General Public License, version 2 or later.
EOF


# Now start by reading configuration files and then command line
# The next stuff is boilerplate

my @config_files = ('/etc/devscripts.conf', '~/.devscripts');
my %config_vars = (
		   'GREP_EXCUSES_MAINTAINER' => '',
		   );

my $shell_cmd;
# Set defaults
foreach my $var (keys %config_vars) {
    $shell_cmd .= "$var='$config_vars{$var}';\n";
}
$shell_cmd .= 'for file in ' . join(" ",@config_files) . "; do\n";
$shell_cmd .= '[ -f $file ] && . $file; done;' . "\n";
# Read back values
foreach my $var (keys %config_vars) { $shell_cmd .= "echo \$$var;\n" }
my $shell_out = `/bin/sh -c '$shell_cmd'`;
@config_vars{keys %config_vars} = split /\n/, $shell_out, -1;

my $string = $config_vars{'GREP_EXCUSES_MAINTAINER'};

if (exists $ENV{'DEBFULLNAME'}) { $string = $ENV{'DEBFULLNAME'}; }
elsif (exists $ENV{'DEBEMAIL'}) { $string = $ENV{'DEBEMAIL'}; }

while (@ARGV and $ARGV[0] =~ /^-/) {
    if ($ARGV[0] eq '--help') { print $usage; exit 0; }
    if ($ARGV[0] eq '--version') { print $version; exit 0; }
    die "Unrecognised option: $ARGV[0]; try $progname --help for help\n";
}

if (@ARGV) {
    $string=shift;
}
if (@ARGV or $string eq '') { print STDERR $usage; exit 1; }

my $hostname = `hostname --fqdn`;
chomp $hostname;

if ($hostname =~ /^(auric|ftp-master)\.debian\.org$/) {
    open EXCUSES, '/org/ftp.debian.org/web/testing/update_excuses.html'
	or die "Cannot open update_excuses: $!\n";
} else {
    my $user_agent = LWP::UserAgent->new(env_proxy => 1);
    my ($request, $response);
    my $url='http://ftp-master.debian.org/testing/update_excuses.html.gz';
    $excuses_gz = tmpfile();

    $request = HTTP::Request->new('GET', $url);
    $response = $user_agent->request($request, $excuses_gz);
    if (! $response->is_success) {
	die "Cannot download excuses file: " . $response->status_line . "\n";
    }

    open (EXCUSES, qq[zcat "$excuses_gz" |]) or die "Cannot fork zcat: $!\n";
}

my $item='';
my $mainlist=0;
my $sublist=0;
while (<EXCUSES>) {
    if (! $mainlist) {
	# Have we found the start of the actual content?
	next unless /^\s*<ul>\s*$/;
	$mainlist=1;
	next;
    }
    # Have we reached the end?
    if (! $sublist and m%\s*</ul>\s*$%) {
	$mainlist=0;
	next;
    }
    # Strip hyperlinks
    my $saveline=$_;
    s%<a\s[^>]*>%%g;
    s%</a>%%g;
    s%&gt;%>%g;
    s%&lt;%<%g;
    # New item?
    if (! $sublist and /^\s*<li>/) {
	s%^\s*<li>%%;
	$item = $_;
    }
    elsif (! $sublist and /^\s*<ul>/) {
	$sublist=1;
    }
    elsif ($sublist and m%^\s*</ul>%) {
	$sublist=0;
	# Did the last item match?
	if ($item=~/^-?$string\s/ or
	    $item=~/^\s*Maintainer:\s[^\n]*$string[^\n]*$/m) {
	    # In case there are embedded <li> tags
	    $item =~ s%<li>%\n    %g;
	    print $item;
	}
    }
    elsif ($sublist and /^\s*<li>/) {
	s%^\s*<li>%    %;
	$item .= $_;
    }
    else {
	warn "Unrecognised line in update_excuses (line $.):\n$saveline";
    }
}
close EXCUSES or die "zcat failed: $!\n";

exit 0;

# Safely get a temporary file.
sub tmpfile {
    do { 
	$name=tmpnam();
    } until $fh=IO::File->new($name,O_RDWR|O_CREAT|O_EXCL);
    return $name;
}