SVN: toys/stbr/queue_parser.pl

[sparky]

Author: sparky
Date: Thu Oct 29 22:27:42 2009
New Revision: 10879

Added:
   toys/stbr/queue_parser.pl
Log:
- new, queue.gz parser


Added: toys/stbr/queue_parser.pl
==============================================================================
--- (empty file)
+++ toys/stbr/queue_parser.pl	Thu Oct 29 22:27:42 2009
@@ -0,0 +1,143 @@
+#!/usr/bin/perl
+#
+# 2009 (c) Przemysław Iskra <sparky at pld-linux.org>
+# It's GPL v2+ !
+#
+use strict;
+use warnings;
+use WWW::Curl::Easy;
+use Compress::Zlib ();
+use Data::Dumper;
+
+my $data_dir = $ENV{PWD};
+
+my $line = shift @ARGV;
+$line ||= "th";
+$line = ucfirst lc $line;
+
+my %queue_uri = (
+	Th => 'http://ep09.pld-linux.org/~builderth/queue.gz',
+	Ti => 'http://ep09.pld-linux.org/~builderti/queue.gz',
+);
+
+my $uri = $queue_uri{ $line } || die "Line $line not supported\n";
+
+my $data_file = "$data_dir/saved-vars-$line.pl";
+my $data = do $data_file;
+$data ||= { last_time => time - 60, printed => {} };
+my %printed;
+
+
+my %status_to_color = (
+	'?' => "bold",
+	OK => "green",
+	FAIL => "red",
+	SKIP => "blue",
+	UNSUPP => "magenta",
+);
+
+my %color_to_code = (
+	red => 5,
+	green => 3,
+	yellow => 7,
+	blue => 2,
+	magenta => 6,
+	"" => 0,
+);
+sub color
+{
+	my $color = shift || "";
+	return "\002" if $color eq "bold";
+	return "\003" . $color_to_code{$color};
+}
+
+sub get
+{
+	my $uri = shift;
+
+	my $curl = new WWW::Curl::Easy;
+	$curl->setopt( CURLOPT_URL, $uri );
+
+	my $body;
+	open my $body_f, ">", \$body;
+
+	$curl->setopt( CURLOPT_WRITEDATA, $body_f );
+
+	my $retcode = $curl->perform;
+
+	if ( $retcode ) {
+		die "$line queue download error: " . $curl->strerror( $retcode ) . " ($retcode)\n";
+	}
+	return Compress::Zlib::memGunzip( $body );
+}
+
+
+my $xml = get( $uri );
+$xml =~ s{</queue>.*}{}s;
+
+my $now = time;
+
+my $printed_something = 0;
+my $done_so_far = 1;
+my @group = $xml =~ m{(<group.*?</group>)}gs;
+foreach my $grp ( @group ) {
+	my ($time) = $grp =~ m{<time>(\d+)</time>};
+	next if $time <= $data->{last_time};
+
+	my @pkg = $grp =~ m{(<batch.*?</batch>)}gs;
+	foreach my $p ( @pkg ) {
+		my ($id) = $p =~ m{<batch id='(.*?)'};
+
+		if ( $data->{printed}->{$id} ) {
+			$printed{$id} = 1;
+			next;
+		}
+
+		my ($rpm) = $p =~ m{<src-rpm>(.*?)</src-rpm>};
+		if ( $rpm ) {
+			$rpm =~ s/\.src\.rpm$//;
+		} else {
+			($rpm) = $p =~ m{<command flags="">(.*?)</command>};
+		}
+
+		my $all_done = 1;
+		my $some_done = 0;
+		my @status;
+		my @builders = $p =~ m{(<builder.*?</builder>)}g;
+		foreach my $b ( @builders ) {
+			my ( $status, $builder ) = $b =~ m{status='(.*?)'.*?>(.*?)</builder>};
+			my $color = $status_to_color{ $status } || "red";
+			push @status, "$builder: " . color($color) . "$status\017";
+			if ( $status eq "?" ) {
+				$all_done = 0;
+			} else {
+				$some_done = 1;
+			}
+		}
+
+		my $print = undef;
+		if ( $all_done ) {
+			$print = 1;
+		} elsif ( $some_done ) {
+			$print = 0 if $time + 120 < $now;
+		}
+		if ( not $all_done ) {
+			$done_so_far = 0;
+			$printed{$id} = 0 if $some_done;
+			next if exists $data->{printed}->{$id};
+		}
+
+		if ( defined $print ) {
+			$printed{$id} = $print;
+			$printed_something++;
+			print color( "yellow" ) ."$line\017: $rpm\002:\017 " . ( join ", ", @status ) . "\n";
+		}
+	}
+	$data->{last_time} = $time if $done_so_far;
+	last if $printed_something > 4;
+}
+
+$data->{printed} = \%printed;
+open F_OUT, ">", $data_file;
+print F_OUT Dumper( $data );
+close F_OUT;