SVN: toys/stbr/clean-unfilled.pl

[sparky]

Author: sparky
Date: Tue Nov 17 02:46:42 2009
New Revision: 10974

Added:
   toys/stbr/clean-unfilled.pl   (contents, props changed)
Log:
- new
- requires perl-DBD-SQLite2
- run as: ./clean-unfilled.pl th ti


Added: toys/stbr/clean-unfilled.pl
==============================================================================
--- (empty file)
+++ toys/stbr/clean-unfilled.pl	Tue Nov 17 02:46:42 2009
@@ -0,0 +1,89 @@
+#!/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;
+use DBI;
+
+my $dbh = DBI->connect("dbi:SQLite2:dbname=unfilled.db","","");
+my $sth = $dbh->prepare( "DELETE FROM unfilled WHERE line = ? and spec = ? and branch = ? and date < ?" );
+
+my %queue_uri = (
+	aidath => 'http://ep09.pld-linux.org/~builderaidath/queue.gz',
+	ac => 'http://ep09.pld-linux.org/~buildsrc/queue.gz',
+	th => 'http://ep09.pld-linux.org/~builderth/queue.gz',
+	ti => 'http://ep09.pld-linux.org/~builderti/queue.gz',
+);
+
+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 "$uri queue download error: " . $curl->strerror( $retcode ) . " ($retcode)\n";
+	}
+	return Compress::Zlib::memGunzip( $body );
+}
+
+
+my $removed = 0;
+
+sub parse
+{
+	my $line = shift;
+	my $xml = shift;
+	$xml =~ s{</queue>.*}{}s;
+
+	my @group = $xml =~ m{(<group.*?</group>)}gs;
+	GROUP: foreach my $grp ( @group ) {
+		my ($time) = $grp =~ m{<time>(\d+)</time>};
+	
+		next if $grp =~ m{<group.*?flags="test-build">};
+	
+		my @pkg = $grp =~ m{(<batch.*?</batch>)}gs;
+		foreach my $p ( @pkg ) {
+			my ($spec) = $p =~ m{<spec>(.*?)</spec>};
+			next unless $spec;
+	
+			my ($branch) = $p =~ m{<branch>(.+?)</branch>};
+	
+			my $e = $sth->execute( $line, $spec, $branch, $time );
+			print "$line: removed $spec @ $branch\n" if $e > 0;
+			$removed += $e;
+		}
+	}
+}
+
+while ( my $line = shift @ARGV ) {
+	$line = lc $line;
+
+	my $uri = $queue_uri{ $line };
+	unless ( $uri ) {
+		warn "$line not supported\n";
+		next;
+	}
+
+	my $xml = get( $uri );
+
+	parse( $line, $xml );
+}
+
+if ( $removed ) {
+	warn "Cleaning database\n";
+	$dbh->do( "vacuum" );
+}