Gecko [ fernandoquevedodop.com ]

Name	Size	Permission
MkOrigtargz	[ DIR ]	drwxr-xr-x
Salsa	[ DIR ]	drwxr-xr-x
Uscan	[ DIR ]	drwxr-xr-x
Compression.pm	3.1 KB	-rw-r--r--
Config.pm	10.9 KB	-rw-r--r--
DB_File_Lock.pm	10.79 KB	-rw-r--r--
Debbugs.pm	11.57 KB	-rw-r--r--
JSONCache.pm	1.61 KB	-rw-r--r--
MkOrigtargz.pm	20.68 KB	-rw-r--r--
Output.pm	1.49 KB	-rw-r--r--
PackageDeps.pm	9.14 KB	-rw-r--r--
Packages.pm	8.93 KB	-rw-r--r--
Salsa.pm	9.39 KB	-rw-r--r--
Set.pm	2.87 KB	-rw-r--r--
Utils.pm	482 B	-rw-r--r--
Versort.pm	2.05 KB	-rw-r--r--

Code Editor : Debbugs.pm

# This is Debbugs.pm from the Debian devscripts package
#
#   Copyright (C) 2008 Adam D. Barratt
#   select() is Copyright (C) 2007 Don Armstrong
#
# 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.,
# 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

package Devscripts::Debbugs;

=head1 OPTIONS

=over

=item select [key:value  ...]

Uses the SOAP interface to output a list of bugs which match the given
selection requirements.

The following keys are allowed, and may be given multiple times.

=over 8

=item package

Binary package name.

=item source

Source package name.

=item maintainer

E-mail address of the maintainer.

=item submitter

E-mail address of the submitter.

=item severity

Bug severity.

=item status

Status of the bug.

=item tag

Tags applied to the bug. If I<users> is specified, may include
usertags in addition to the standard tags.

=item owner

Bug's owner.

=item correspondent

Address of someone who sent mail to the log.

=item affects

Bugs which affect this package.

=item bugs

List of bugs to search within.

=item users

Users to use when looking up usertags.

=item archive

Whether to search archived bugs or normal bugs; defaults to 0
(i.e. only search normal bugs). As a special case, if archive is
'both', both archived and unarchived bugs are returned.

=back

For example, to select the set of bugs submitted by
jrandomdeveloper@example.com and tagged wontfix, one would use

select("submitter:jrandomdeveloper@example.com", "tag:wontfix")

=back

=cut

use strict;
use warnings;

my $soapurl = 'Debbugs/SOAP/1';
our $btsurl = 'http://bugs.debian.org/';
my @errors;

our $soap_timeout;

sub soap_timeout {
    my $timeout_arg = shift;
    if (defined $timeout_arg and $timeout_arg =~ m{^[1-9]\d*$}) {
        $soap_timeout = $timeout_arg;
    }
}

sub init_soap {
    my $soapproxyurl;
    if ($btsurl =~ m%^https?://(.*)/?$%) {
        $soapproxyurl = $btsurl . '/';
    } else {
        $soapproxyurl = 'http://' . $btsurl . '/';
    }
    $soapproxyurl =~ s%//$%/%;
    $soapproxyurl .= 'cgi-bin/soap.cgi';
    my %options;
    if ($soap_timeout) {
        $options{timeout} = $soap_timeout;
    }
    my $soap = SOAP::Lite->uri($soapurl)->proxy($soapproxyurl, %options);

$soap->transport->env_proxy();
    $soap->on_fault(\&getSOAPError);

return $soap;
}

my $soap_broken;

sub have_soap {
    return ($soap_broken ? 0 : 1) if defined $soap_broken;
    eval { require SOAP::Lite; };

if ($@) {
        if ($@ =~ m%^Can't locate SOAP/%) {
            $soap_broken = "the libsoap-lite-perl package is not installed";
        } else {
            $soap_broken = "couldn't load SOAP::Lite: $@";
        }
    } else {
        $soap_broken = 0;
    }
    return ($soap_broken ? 0 : 1);
}

sub getSOAPError {
    my ($soap, $result) = @_;
    my $err;
    if (ref($result)) {
        $err = $result->faultstring;
    } else {
        $err = $soap->transport->status;
    }
    chomp $err;
    push @errors, $err;

return new SOAP::SOM;
}

sub usertags {
    die "Couldn't run usertags: $soap_broken\n" unless have_soap();

my @args = @_;

my $soap     = init_soap();
    my $usertags = $soap->get_usertag(@_);

if (@errors or not defined $usertags) {
        my $error = join("\n", @errors);
        die "Error retrieving usertags from SOAP server: $error\n";
    }

my $result = $usertags->result();

if (@errors or not defined $result) {
        my $error = join("\n", @errors);
        die "Error retrieving usertags from SOAP server: $error\n";
    }

return $result;
}

sub select {
    die "Couldn't run select: $soap_broken\n" unless have_soap();
    my @args       = @_;
    my %valid_keys = (
        package       => 'package',
        pkg           => 'package',
        src           => 'src',
        source        => 'src',
        maint         => 'maint',
        maintainer    => 'maint',
        submitter     => 'submitter',
        from          => 'submitter',
        status        => 'status',
        tag           => 'tag',
        tags          => 'tag',
        usertag       => 'tag',
        usertags      => 'tag',
        owner         => 'owner',
        dist          => 'dist',
        distribution  => 'dist',
        bugs          => 'bugs',
        archive       => 'archive',
        severity      => 'severity',
        correspondent => 'correspondent',
        affects       => 'affects',
    );
    my %users;
    my %search_parameters;
    my $soap = init_soap();
    for my $arg (@args) {
        my ($key, $value) = split /:/, $arg, 2;
        next unless $key;
        if (exists $valid_keys{$key}) {
            if ($valid_keys{$key} eq 'archive') {
                $search_parameters{ $valid_keys{$key} } = $value
                  if $value;
            } else {
                push @{ $search_parameters{ $valid_keys{$key} } }, $value
                  if $value;
            }
        } elsif ($key =~ /users?$/) {
            $users{$value} = 1 if $value;
        } else {
            warn "select(): Unrecognised key: $key\n";
        }
    }
    my %usertags;
    for my $user (keys %users) {
        my $ut = usertags($user);
        next unless defined $ut and $ut ne "";
        for my $tag (keys %{$ut}) {
            push @{ $usertags{$tag} }, @{ $ut->{$tag} };
        }
    }
    my $bugs = $soap->get_bugs(%search_parameters,
        (keys %usertags) ? (usertags => \%usertags) : ());

if (@errors or not defined $bugs) {
        my $error = join("\n", @errors);
        die "Error while retrieving bugs from SOAP server: $error\n";
    }

my $result = $bugs->result();
    if (@errors or not defined $result) {
        my $error = join("\n", @errors);
        die "Error while retrieving bugs from SOAP server: $error\n";
    }

return $result;
}

sub status {
    die "Couldn't run status: $soap_broken\n" unless have_soap();
    my @args = @_;

my $soap = init_soap();

my $result = {};
    while (my @slice = splice(@args, 0, 500)) {
        my $bugs = $soap->get_status(@slice);

if (@errors or not defined $bugs) {
            my $error = join("\n", @errors);
            die
              "Error while retrieving bug statuses from SOAP server: $error\n";
        }

my $tmp = $bugs->result();

if (@errors or not defined $tmp) {
            my $error = join("\n", @errors);
            die
              "Error while retrieving bug statuses from SOAP server: $error\n";
        }

%$result = (%$result, %$tmp);
    }

return $result;
}

sub versions {
    die "Couldn't run versions: $soap_broken\n" unless have_soap();

my @args       = @_;
    my %valid_keys = (
        package     => 'package',
        pkg         => 'package',
        src         => 'source',
        source      => 'source',
        time        => 'time',
        binary      => 'no_source_arch',
        notsource   => 'no_source_arch',
        archs       => 'return_archs',
        displayarch => 'return_archs',
    );

my %search_parameters;
    my @archs = ();
    my @dists = ();

for my $arg (@args) {
        my ($key, $value) = split /:/, $arg, 2;
        $value ||= "1";
        if ($key =~ /^arch(itecture)?$/) {
            push @archs, $value;
        } elsif ($key =~ /^dist(ribution)?$/) {
            push @dists, $value;
        } elsif (exists $valid_keys{$key}) {
            $search_parameters{ $valid_keys{$key} } = $value;
        }
    }

$search_parameters{arch} = \@archs if @archs;
    $search_parameters{dist} = \@dists if @dists;

my $soap = init_soap();

my $versions = $soap->get_versions(%search_parameters);

if (@errors or not defined $versions) {
        my $error = join("\n", @errors);
        die
          "Error while retrieving package versions from SOAP server: $error\n";
    }

my $result = $versions->result();

if (@errors or not defined $result) {
        my $error = join("\n", @errors);
        die "Error while retrieivng package versions from SOAP server: $error";
    }

return $result;
}

sub versions_with_arch {
    die "Couldn't run versions_with_arch: $soap_broken\n" unless have_soap();
    my @args = @_;

my $versions = versions(@args, 'displayarch:1');

if (not defined $versions) {
        die "Error while retrieivng package versions from SOAP server: $@";
    }

return $versions;
}

sub newest_bugs {
    die "Couldn't run newest_bugs: $soap_broken\n" unless have_soap();
    my $count = shift || '';

return if $count !~ /^\d+$/;

my $soap = init_soap();

my $bugs = $soap->newest_bugs($count);

if (@errors or not defined $bugs) {
        my $error = join("\n", @errors);
        die "Error while retrieving newest bug list from SOAP server: $error";
    }

my $result = $bugs->result();

if (@errors or not defined $result) {
        my $error = join("\n", @errors);
        die "Error while retrieving newest bug list from SOAP server: $error";
    }

return $result;
}

# debbugs currently ignores the $msg_num parameter
# but eventually it might not, so we support passing it

sub bug_log {
    die "Couldn't run bug_log: $soap_broken\n" unless have_soap();

my $bug     = shift || '';
    my $message = shift;

return if $bug !~ /^\d+$/;

my $soap = init_soap();

my $log = $soap->get_bug_log($bug, $message);

if (@errors or not defined $log) {
        my $error = join("\n", @errors);
        die "Error while retrieving bug log from SOAP server: $error\n";
    }

my $result = $log->result();

if (@errors or not defined $result) {
        my $error = join("\n", @errors);
        die "Error while retrieving bug log from SOAP server: $error\n";
    }

return $result;
}

sub binary_to_source {
    die "Couldn't run binary_to_source: $soap_broken\n"
      unless have_soap();

my $soap = init_soap();

my $binpkg = shift;
    my $binver = shift;
    my $arch   = shift;

return if not defined $binpkg or not defined $binver;

my $mapping = $soap->binary_to_source($binpkg, $binver, $arch);

if (@errors or not defined $mapping) {
        my $error = join("\n", @errors);
        die
"Error while retrieving binary to source mapping from SOAP server: $error\n";
    }

my $result = $mapping->result();

if (@errors or not defined $result) {
        my $error = join("\n", @errors);
        die
"Error while retrieving binary to source mapping from SOAP server: $error\n";
    }

return $result;
}

sub source_to_binary {
    die "Couldn't run source_to_binary: $soap_broken\n"
      unless have_soap();

my $soap = init_soap();

my $srcpkg = shift;
    my $srcver = shift;

return if not defined $srcpkg or not defined $srcver;

my $mapping = $soap->source_to_binary($srcpkg, $srcver);

if (@errors or not defined $mapping) {
        my $error = join("\n", @errors);
        die
"Error while retrieving source to binary mapping from SOAP server: $error\n";
    }

my $result = $mapping->result();

if (@errors or not defined $result) {
        my $error = join("\n", @errors);
        die
"Error while retrieving source to binary mapping from SOAP server: $error\n";
    }

return $result;
}

__END__

${this.title}

Code Editor : Debbugs.pm