r9240 - in /scripts/qa: qareport-chlog.cgi templates/by_category
dmn at users.alioth.debian.org
dmn at users.alioth.debian.org
Mon Nov 12 21:19:08 UTC 2007
Author: dmn
Date: Mon Nov 12 21:19:08 2007
New Revision: 9240
URL: http://svn.debian.org/wsvn/?sc=1&rev=9240
Log:
Implement ajax-like fetching of (un)released changelogs
Added:
scripts/qa/qareport-chlog.cgi
- copied, changed from r9238, scripts/qa/qareport.cgi
Modified:
scripts/qa/templates/by_category
Copied: scripts/qa/qareport-chlog.cgi (from r9238, scripts/qa/qareport.cgi)
URL: http://svn.debian.org/wsvn/scripts/qa/qareport-chlog.cgi?rev=9240&op=diff
==============================================================================
--- scripts/qa/qareport.cgi (original)
+++ scripts/qa/qareport-chlog.cgi Mon Nov 12 21:19:08 2007
@@ -10,188 +10,105 @@
use strict;
use warnings;
-use DebianQA::Cache;
-use DebianQA::Common;
use DebianQA::Config qw(read_config %CFG);
-use DebianQA::DebVersions;
-use DebianQA::Svn;
-use CGI ();
-use CGI::Carp qw(fatalsToBrowser);
-use POSIX qw(locale_h);
-use Template ();
-use Date::Parse ();
+use DebianQA::Svn qw(get_svn_file);
+use CGI ':fatalsToBrowser';
+use CGI;
read_config();
my $cgi = new CGI;
-my $data = read_cache(consolidated => "");
-my $script_date = '$Date$';
-$script_date = join( ' ', (split(/ /, $script_date))[1..3] );
-my @modified = sort(
- map(
- {
- find_stamp($data, $_)
- } qw(svn watch archive bts pkglist),
- ),
- Date::Parse::str2time($script_date),
-);
-my $last_modified = $modified[-1];
-my $ims;
-my @pkglist = get_pkglist();
-
-my( @for_upload, @for_upgrade, @weird, @waiting, @wip, @with_bugs, @all );
-my %bugs_by_severity;
-
-foreach my $pkg (sort @pkglist)
-{
- next if($pkg =~ /^\//);
- my $svnpath = $data->{svn}{$pkg}{dir};
- my $werr = $data->{watch}{$pkg}{error};
- my $dver = $data->{svn}{$pkg}{version} || 0;
- my $dwerr = $data->{svn}{$pkg}{watch_error};
- my $m_dver = $data->{svn}{$pkg}{mangled_ver} || 0;
- my $m_uver = $data->{svn}{$pkg}{mangled_un_ver} || 0;
- my $undver = $data->{svn}{$pkg}{un_version};
- my $archver = $data->{archive}{$pkg}{most_recent} || 0;
- my $archsuit = $data->{archive}{$pkg}{most_recent_src} || 0;
- my $uver = $data->{watch}{$pkg}{upstream_version};
- my $u_uver = $data->{watch}{$pkg}{upstream_mangled} || 0;
- my $uurl = $data->{watch}{$pkg}{upstream_url};
- my @bugs = sort keys %{$data->{bts}{$pkg}};
-
- my @notes;
- my %todo;
- my $dest; # like "destiny" :)
- my %info = (
- name => $pkg,
- notes => \@notes,
- todo => \%todo,
- watch => $data->{watch}{$pkg},
- archive => $data->{archive}{$pkg},
- svn => $data->{svn}{$pkg},
- bts => $data->{bts}{$pkg},
- );
- if(! $dver) {
- push @notes, 'Needs to be finished';
- $dest = \@wip;
- $todo{repo} = 1;
- }
- if(! $archver) {
- push @notes, 'Never uploaded';
- $dest ||= \@for_upload;
- $todo{archive} = 1;
- }
- if(deb_compare($archver, $dver) > 0) {
- push @notes, "Ancient version in SVN";
- $dest ||= \@weird;
- $todo{repo} = 1;
- }
- if(deb_compare($archver, $dver) != 0) {
- push @notes, "Needs uploading to the archive";
- $dest ||= \@for_upload;
- $todo{archive} = 1;
- }
- if($werr and $werr eq "Native") {
- push @notes, "Native package";
- }
- if($dwerr or (not $m_dver and not $undver) or not $u_uver or not $uver or $werr) {
- push @notes, "Watchfile problem";
- $dest ||= \@wip;
- $todo{upstream} = 1;
- }
- if(deb_compare($m_dver, $u_uver) > 0) {
- push @notes, "Ancient version in upstream?";
- $dest ||= \@weird;
- $todo{upstream} = 1;
- }
- # Use only mangled versions
- if(deb_compare($m_dver, $u_uver) < 0) {
- push @notes, "$m_dver needs upgrading to newer upstream";
- $dest ||= \@for_upgrade;
- $todo{repo} = 1;
- }
- $dest ||= \@with_bugs if(@bugs);
-
- do{
- $dest ||= \@waiting;
- $todo{archive} = 1;
- } if($archsuit =~ /new|incoming/);
-
- if( %todo or @bugs )
- {
- push @$dest, \%info;
- push @all, \%info;
- }
-}
if( $ENV{GATEWAY_INTERFACE} )
{
my $htmlp = $cgi->Accept("text/html");
my $xhtmlp = $cgi->Accept("application/xhtml+xml");
- $ims = $cgi->http('If-Modified-Since');
- $ims = Date::Parse::str2time($ims) if $ims;
+ print $cgi->header(
+ -content_type => (
+ ($xhtmlp and $xhtmlp > $htmlp)
+ ? 'application/xhtml+xml; charset=utf-8'
+ : 'text/html; charset=utf-8'
+ ),
+ );
+}
- if( $ims and $ims >= $last_modified )
- {
- print $cgi->header('text/html', '304 Not modified');
- exit 0;
+my $pkg = $cgi->param('pkg');
+my $rel = $cgi->param('rel');
+
+my $svnpath = $CFG{svn}{repository};
+
+# Sanitise, as SVN::Client is too stupid
+$svnpath =~ s{/+$}{};
+$svnpath .= "/";
+$svnpath .= $CFG{svn}{packages_path} if($CFG{svn}{packages_path});
+$svnpath =~ s{/+$}{};
+my $svnpostpath = $CFG{svn}{post_path} || "";
+# Always has a slash if not empty
+$svnpostpath =~ s{^/*(.*?)/*$}{/$1} if($svnpostpath);
+
+my $pkg_home = "$svnpath/$pkg$svnpostpath";
+my $svn = SVN::Client->new();
+my $chlog = get_svn_file($svn, "$pkg_home/debian/changelog");
+my $parser = Parse::DebianChangelog->init({instring=>$chlog});
+my $error = $parser->get_error() or $parser->get_parse_errors();
+my $text;
+if( $error )
+{
+ $text = "ERROR:\n$error";
+}
+else
+{
+ my($lastchl, $unfinishedchl);
+ foreach($parser->data()) {
+ if($_->Distribution =~ /^(?:unstable|experimental)$/) {
+ $lastchl = $_;
+ last;
+ }
+ if(! $unfinishedchl and $_->Distribution eq "UNRELEASED") {
+ $unfinishedchl = $_;
+ }
}
- my $old_locale = setlocale(LC_TIME);
- setlocale(LC_TIME, "C");
- print $cgi->header(
- -content_type => (
- ($xhtmlp and $xhtmlp > $htmlp)
- ? 'application/xhtml+xml; charset=utf-8'
- : 'text/html; charset=utf-8'
- ),
- -last_modified => POSIX::strftime(
- "%a, %d %b %Y %T %Z",
- gmtime($last_modified),
- ),
- );
- setlocale(LC_TIME, $old_locale);
+ my $entry;
+ if( $rel eq 'rel' )
+ {
+ if( $lastchl )
+ {
+ $entry = $lastchl;
+ }
+ else
+ {
+ $text = "Unable to find released changelog for package '$pkg'";
+ }
+ }
+ else
+ {
+ if( $unfinishedchl )
+ {
+ $entry = $unfinishedchl;
+ }
+ else
+ {
+ $text = "Unable to find unreleased changelog for package '$pkg'";
+ }
+ }
+
+ $text = join(
+ "\n",
+ $entry->Header,
+ $entry->Changes,
+ $entry->Trailer,
+ ) if $entry;
}
-my $template = $cgi->param("template") || $CFG{qareport_cgi}{default_template};
-my $tt = new Template(
- {
- INCLUDE_PATH => $CFG{qareport_cgi}{templates_path},
- INTERPOLATE => 1,
- POST_CHOMP => 1,
- FILTERS => {
- 'quotemeta' => sub { quotemeta(shift) },
- },
- }
-);
+$text =~ s/&/&/g;
+$text =~ s/'/"/g;
+$text =~ s/</</g;
+$text =~ s/>/>/g;
-$tt->process(
- $template,
- {
- data => $data,
- group_name => $CFG{qareport_cgi}{group_name},
- group_url => $CFG{qareport_cgi}{group_url},
- wsvn_url => $CFG{qareport_cgi}{wsvn_url},
- (
- ( ($cgi->param('format')||'') eq 'list' )
- ? (
- all => \@all
- )
- : (
- for_upgrade => \@for_upgrade,
- weird => \@weird,
- for_upload => \@for_upload,
- waiting => \@waiting,
- wip => \@wip,
- with_bugs => \@with_bugs,
- )
- ),
- shown_packages => scalar(@all),
- total_packages => scalar(@pkglist),
- },
-) || die $tt->error;
+print $text;
exit 0;
Modified: scripts/qa/templates/by_category
URL: http://svn.debian.org/wsvn/scripts/qa/templates/by_category?rev=9240&op=diff
==============================================================================
--- scripts/qa/templates/by_category (original)
+++ scripts/qa/templates/by_category Mon Nov 12 21:19:08 2007
@@ -58,7 +58,7 @@
[% chlog_url = BLOCK %][% pkg.name | format("$wsvn_url")
%]/debian/changelog?op=file&rev=0&sc=0[% END %]
<span class="popup"><a href="$chlog_url">$svn_ver</a><span
- id="${pkg}_rel_chlog_baloon" class="balloon"><a
+ id="${pkg.name}_rel_chlog_baloon" class="balloon"><a
href="javascript:more_chlog('$pkg.name','rel')">[%
pkg.svn.changer | html %] — [% pkg.svn.date |
html %]</a>
@@ -67,7 +67,7 @@
[% IF svn_un_ver AND (svn_un_ver != svn_ver) %]
<span class="popup" style="font-size: smaller"><a
href="$chlog_url">($svn_un_ver)</a><span
- id="${pkg}_rel_chlog_baloon" class="balloon"><a
+ id="${pkg.name}_unrel_chlog_baloon" class="balloon"><a
href="javascript:more_chlog('$pkg.name','unrel')">[%
pkg.svn.un_changer | html %] — [% pkg.svn.un_date
| html %]</a></span></span>[% END #IF %]
@@ -209,7 +209,44 @@
}
function more_chlog(pkg,rel)
{
- alert('Sorry, not ready yet.');
+ var xml;
+ if (window.XMLHttpRequest) {
+ xml = new XMLHttpRequest();
+ } else if (window.ActiveXObject) {
+ xml = new ActiveXObject("Microsoft.XMLHTTP");
+ } else {
+ alert("Your browser lacks the needed ability to use Ajax. Sorry.");
+ return false;
+ }
+
+ xml.onreadystatechange = function() {
+ ajaxStateChanged(xml, pkg, rel);
+ };
+
+ xml.open('GET', 'qareport.cgi?format=chlog;rel='+rel);
+ xml.send('');
+ }
+ function ajaxStateChanged(xml, pkg, rel)
+ {
+ if( xml.readyState == 4 )
+ {
+ var el = document.getElementById(pkg+'_'+rel+'_chlog_baloon');
+ if( !el )
+ {
+ alert('Element "'+pkg+'_'+rel+'_chlog_baloon'+'" not found');
+ }
+ else
+ {
+ if( xml.status == 200 )
+ {
+ el.innerHTM = xml.responseText;
+ }
+ else
+ {
+ el.innerHTML = xml.status+': '+xml.StatusText;
+ }
+ }
+ }
}
</script>
</head>
More information about the Pkg-perl-cvs-commits
mailing list