--- /dev/null
+#!/usr/bin/perl -w
+# dgit repos policy admin script for Debian
+
+our $usage = <<'END';
+usage:
+ dgit-repos-admin-debian [<options>] 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|<package>] <gitobjid> '<comment>'
+ untaint [--global|<package>] <gitobjid>
+END
+
+use strict;
+use POSIX;
+use DBI;
+
+use Debian::Dgit;
+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(<<END);
+ CREATE TABLE IF NOT EXISTS taints (
+ taint_id INTEGER NOT NULL PRIMARY KEY ASC AUTOINCREMENT,
+ package TEXT NOT NULL,
+ gitobjid TEXT NOT NULL,
+ comment TEXT NOT NULL,
+ time INTEGER,
+ gitobjtype TEXT,
+ gitobjdata TEXT
+ )
+END
+ $poldbh->do(<<END);
+ CREATE INDEX IF NOT EXISTS taints_by_gitobjid
+ ON taints (gitobjid, package)
+END
+ # any one of of the listed deliberatelies will override its taint
+ $poldbh->do(<<END);
+ CREATE TABLE IF NOT EXISTS taintoverrides (
+ taint_id INTEGER NOT NULL
+ REFERENCES taints (taint_id)
+ ON UPDATE RESTRICT
+ ON DELETE CASCADE
+ DEFERRABLE INITIALLY DEFERRED,
+ deliberately TEXT NOT NULL,
+ PRIMARY KEY (taint_id, deliberately)
+ )
+END
+
+ $poldbh->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->();
~ianmdlvl / dgit.git / blobdiff