#!/usr/bin/perl -w
# dgit repos policy admin script for Debian
#
# Copyright (C) 2015-2016 Ian Jackson
#
# 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 3 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, see .
use strict;
use Debian::Dgit::Infra; # must precede Debian::Dgit; - can change @INC!
use Debian::Dgit;
setup_sigwarn();
our $usage = <<'END';
usage:
dgit-repos-admin-debian [] operation...
options:
--git-dir /path/to/git/repo/or/working/tree
--repos /path/to/dgit/repos/directory } alternatives
--db /path/to/dgit/repos/policy.sqlite3 }
(at least one of above required; if only one, cwd is used for other)
operations:
create-db
list-taints
taint [--global|] ''
untaint [--global|]
END
use POSIX;
use DBI;
use Debian::Dgit::Policy::Debian;
sub badusage ($) { die "bad usage: $_[0]\n$usage"; }
use Getopt::Long qw(:config posix_default gnu_compat bundling);
our ($git_dir,$repos_dir,$db_path);
GetOptions("git-dir=s" => \$git_dir,
"repos=s" => \$repos_dir,
"db=s" => \$db_path)
or die $usage;
$db_path //= poldb_path($repos_dir) if defined $repos_dir;
$db_path // $repos_dir ||
die <<'END'.$usage;
Must supply --git-dir and/or --repos (or --db instead of --repos).
If only one of --git-dir and --repos is supplied, other is taken to
be current working directory.
END
# /
$git_dir //= '.';
$repos_dir //= '.';
our $p;
our $gitobjid;
sub get_package_objid () {
$p = shift @ARGV; $p // badusage "operation needs package or --global";
if ($p eq '--global') {
$p = '';
} else {
$p =~ m/^$package_re$/ or badusage 'package name or --global needed';
}
$gitobjid = shift @ARGV;
$gitobjid // badusage "operation needs git object id";
$gitobjid =~ m/\W/ && badusage "invalid git object id";
}
sub sort_out_git_dir () {
foreach my $sfx ('/.git', '') {
my $path = "$git_dir/$sfx";
if (stat_exists "$path/objects") {
$ENV{GIT_DIR} = $git_dir = $path;
return;
}
}
die "git directory $git_dir doesn't seem valid\n";
}
sub show_taints ($$@) {
my ($m, $cond, @condargs) = @_;
my $q = $poldbh->prepare
("SELECT package,gitobjid,gitobjtype,time,comment, ".
" (gitobjdata IS NOT NULL) hasdata".
" FROM taints WHERE $cond".
" ORDER BY package, gitobjid, time");
$q->execute(@condargs);
print "$m:\n" or die $!;
my $count = 0;
while (my $row = $q->fetchrow_hashref) {
my $t = strftime "%Y-%m-%dT%H:%M:%S", gmtime $row->{time};
my $objinfo = $row->{gitobjtype}. ($row->{hasdata} ? '+' : ' ');
my $comment = $row->{comment};
$comment =~ s/\\/\\\\/g; $comment =~ s/\n/\\n/g;
printf(" %s %-30s %s %7s %s\n",
$t, $row->{package}, $row->{gitobjid},
$objinfo, $row->{comment})
or die $!;
$count++;
}
return $count;
}
sub cmd_list_taints ($) {
badusage "no args/options" if @ARGV;
my $count = show_taints("all taints","1");
printf "%d taints listed\n", $count or die $!;
}
sub cmd_create_db ($) {
badusage "no args/options" if @ARGV;
$poldbh->do(<do(<do(<commit;
}
sub show_taints_bypackage ($) {
my ($m) = @_;
show_taints($m, "package = ?", $p);
}
sub show_taints_bygitobjid ($) {
my ($m) = @_;
show_taints($m, "gitobjid = ?", $gitobjid);
}
sub show_relevant_taints ($) {
my ($what) = @_;
show_taints_bypackage($p ? "$what taints for package $p"
: "$what global taints");
show_taints_bygitobjid("$what taints for object $gitobjid");
}
sub cmd_taint () {
get_package_objid();
my $comment = shift @ARGV;
$comment // badusage "operation needs comment";
@ARGV && badusage "too many arguments to taint";
sort_out_git_dir();
$!=0; $?=0; my $objtype = `git cat-file -t $gitobjid`;
chomp $objtype or die "$? $!";
$poldbh->do("INSERT INTO taints".
" (package, gitobjid, gitobjtype, time, comment)".
" VALUES (?,?,?,?,?)", {},
$p, $gitobjid, $objtype, time, $comment);
$poldbh->commit;
print "taint added\n" or die $!;
show_relevant_taints("resulting");
}
sub cmd_untaint () {
get_package_objid();
@ARGV && badusage "too many arguments to untaint";
show_relevant_taints("existing");
my $affected =
$poldbh->do("DELETE FROM taints".
" WHERE package = ? AND gitobjid = ?",
{}, $p, $gitobjid);
$poldbh->commit;
printf "%d taints removed\n", $affected or die $!;
exit $affected ? 0 : 1;
}
my $cmd = shift @ARGV;
$cmd // badusage "need operation";
$cmd =~ y/-/_/;
my $fn = ${*::}{"cmd_$cmd"};
$fn or badusage "unknown operation $cmd";
poldb_setup($db_path);
$fn->();