r8923 - /scripts/qa/qareport-cgi
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Tue Nov 6 20:26:29 UTC 2007
Author: dmn
Date: Tue Nov 6 20:26:29 2007
New Revision: 8923
URL: http://svn.debian.org/wsvn/?sc=1&rev=8923
Log:
(somewhat) preliminary CGI script
Added:
scripts/qa/qareport-cgi
- copied, changed from r8921, scripts/qa/qareport
Copied: scripts/qa/qareport-cgi (from r8921, scripts/qa/qareport)
URL: http://svn.debian.org/wsvn/scripts/qa/qareport-cgi?rev=8923&op=diff
==============================================================================
--- scripts/qa/qareport (original)
+++ scripts/qa/qareport-cgi Tue Nov 6 20:26:29 2007
@@ -2,9 +2,10 @@
# vim:ts=4:sw=4:et:ai:sts=4
# $Id$
#
-# Draft of a report
+# Report packages version states
#
# Copyright MartÃn Ferrari <martin.ferrari at gmail.com>, 2007
+# Copyright Damyan Ivanov <dmn at debian.org>, 2007
# Released under the terms of the GNU GPL 2
use strict;
use warnings;
@@ -14,29 +15,17 @@
use DebianQA::Config;
use DebianQA::DebVersions;
use DebianQA::Svn;
-use Getopt::Long;
+use CGI ();
+use Template ();
-my $opts = getopt_common(1);
+DebianQA::Config::read_config($ENV{HOME}."/.dpg/qa.conf");
-my $p = new Getopt::Long::Parser;
-$p->configure(qw(no_ignore_case bundling));
-
-my $list_is_packages = 0;
-$p->getoptions('help|h|?' => \&help, 'packages!' => \$list_is_packages,
- ) or die "Error parsing command-line arguments!\n";
-
-my @dirs = @ARGV;
-
-if($list_is_packages) {
- foreach my $dir (@dirs) {
- $dir = svndir2pkgname($dir) || $dir; # Fallback
- }
-}
+my $cgi = new CGI;
my $data = read_cache(consolidated => "");
-my @pkglist = @dirs;
- at pkglist = get_pkglist() unless(@pkglist);
+my @pkglist = get_pkglist();
+my( @for_upload, @for_upgrade, @waiting, @wip, @with_bugs );
foreach my $pkg (sort @pkglist) {
next if($pkg =~ /^\//);
my $svnpath = $data->{svn}{$pkg}{dir};
@@ -52,54 +41,138 @@
my @bugs = @{$data->{bts}{$pkg}};
@bugs = map({ "#$_" } @bugs);
- my $status;
+ my $note;
if(! $dver) {
- $status = "Needs finishing";
+ $note = 'Needs to be finished';
+ push @wip, $pkg;
} elsif(deb_compare($archver, $dver) > 0) {
- $status = "Ancient version in SVN";
+ $note = "Ancient version in SVN";
+ push @for_upgrade, $pkg;
} elsif(deb_compare($archver, $dver) != 0) {
- $status = "Needs uploading";
+ push @for_upload, $pkg;
} elsif($dwerr or not $m_dver or not $m_uver or not $uver) {
- $status = "Watchfile problem";
+ $note = "Watchfile problem";
+ push @wip, $pkg;
} elsif(deb_compare($m_dver, $m_uver) > 0) {
- $status = "Ancient version in upstream?";
+ $note = "Ancient version in upstream?";
+ push @for_upgrade, $pkg;
} elsif(deb_compare($m_dver, $m_uver) != 0) {
- $status = "Needs upgrading to newer upstream";
+ $note = "Needs upgrading to newer upstream";
+ push @for_upgrade, $pkg;
} elsif($werr) {
- $status = "Watchfile problem";
+ $note = "Watchfile problem";
+ push @wip, $pkg;
}
- next unless($status or @bugs);
- print "$pkg:", ( $pkg ne $svnpath ? " (SVN: $svnpath)" : '' ), "\n";
- if($status) {
- print " - Version status: $status\n";
- print " + Watch status: ", $werr || "OK", "\n";
- print " + SVN: ", $dver || "none";
- print " (mangled: ", $m_dver || "none", ")";
- print " (unreleased: $undver)" if($undver);
- print " Archive: ", $archver || "Not uploaded";
- print " ($archsuit)" if($archsuit);
- print " Upstream: ", $uver || "Unknown";
- print " (mangled: ", $m_uver || "Unknown", ")\n";
- }
- print " + Bugs: ", join(", ", @bugs), "\n" if(@bugs);
+ push @with_bugs, $pkg if @bugs;
+# print "$pkg:", ( $pkg ne $svnpath ? " (SVN: $svnpath)" : '' ), "\n";
+# if($status) {
+# print " - Version status: $status\n";
+# print " + Watch status: ", $werr || "OK", "\n";
+# print " + SVN: ", $dver || "none";
+# print " (mangled: ", $m_dver || "none", ")";
+# print " (unreleased: $undver)" if($undver);
+# print " Archive: ", $archver || "Not uploaded";
+# print " ($archsuit)" if($archsuit);
+# print " Upstream: ", $uver || "Unknown";
+# print " (mangled: ", $m_uver || "Unknown", ")\n";
+# }
+# print " + Bugs: ", join(", ", @bugs), "\n" if(@bugs);
}
-#use Data::Dumper; print Dumper $data;
-sub help {
- print <<END;
-Usage:
- $0 [options] [dirname [dirname ...]]
+print $cgi->header(
+ -content_type => 'text/xhtml; charset=utf-8',
+);
- For each named directory, updates the databases with information retrieved
- from the Debian archive, BTS, watchfiles and the Subversion repository.
+my $tt = new Template({INTERPOLATE=>1});
+$tt->process(
+ \*DATA,
+ {
+ data => $data,
+ for_upgrade => \@for_upgrade,
+ for_upload => \@for_upload,
+ waiting => \@waiting,
+ wip => \@wip,
+ with_bugs => \@with_bugs,
+ },
+) || die $tt->error;
-Options:
- --help, -h This help.
- --conf, -c FILE Specifies a configuration file, uses defaults if not
- present.
- --packages Treat the parameters as source package names, instead of
- directories.
+exit 0;
-END
- exit 0;
-}
+__END__
+[% BLOCK package %]
+ [% SET arch_ver = data.archive.$pkg.most_recent %]
+ [% SET svn_ver = data.svn.$pkg.version %]
+ <tr>
+ <td>$pkg</td>
+ <td><a href="http://svn.debian.org/wsvn/pkg-perl/trunk/$pkg/debian/changelog?op=file&rev=0&sc=0">$svn_ver</a></td>
+ <td>[% IF arch_ver %]<a href="http://packages.qa.debian.org/$pkg">$arch_ver[% END #IF %]</a></td>
+ <td>${data.watch.$pkg.upstream_mangled}</td>
+ </tr>
+</tr>
+[% END #BLOCK package %]
+[% BLOCK section %]
+ [% IF list.size %]
+ <tr>
+ <th colspan="4" class="clickable"><a href="javascript:toggle_visibility('$name')">$title ($list.size)</a></th>
+ </tr>
+ <tbody id="$name">
+ <tr>
+ <th>Package</th>
+ <th>Repository</th>
+ <th>Archive</th>
+ <th>Upstream</th>
+ </tr>
+ [% FOREACH pkg IN list %]
+ [% INCLUDE package pkg=pkg data=data %]
+ [% END #FOREACH list %]
+ </tbody>
+ [% END #IF list.size %]
+[% END #BLOCK section %]
+<?xml version="1.0" encoding="UTF-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
+<head>
+ <title>pkg-perl packages overview</title>
+ <style type="text/css">
+ body {
+ background: white;
+ color: black;
+ }
+ table {
+ border: 1px solid black;
+ border-collapse: collapse;
+ empty-cells: show;
+ }
+ td, th {
+ border: 1px solid black;
+ }
+ th.clickable, th.clickable a, th.clickable a:visited {
+ background: #404040;
+ color: white;
+ }
+ .upload {
+ background: lightsalmon;
+ }
+ .upgrade {
+ background: lightblue;
+ }
+ </style>
+ <script type="text/javascript">
+ function toggle_visibility(id)
+ {
+ var el = document.getElementById(id);
+ el.style.display = (el.style.display == 'none' ? 'table-row-group' : 'none');
+ }
+ </script>
+</head>
+<body>
+<table>
+ [% INCLUDE section data=data list=for_upgrade name="for_upgrade" title="Newer upstream available" %]
+ [% INCLUDE section data=data list=for_upload name="for_upload" title="Ready for upload" %]
+ [% INCLUDE section data=data list=waiting name="waiting" title="NEW and incoming" %]
+ [% INCLUDE section data=data list=wip name="wip" title="Work in progress" %]
+ [% INCLUDE section data=data list=with_bugs name="with_bugs" title="With bugs" %]
+</table>
+</body>
+</html>
More information about the Pkg-perl-cvs-commits
mailing list