2 # dgit repos policy admin script for Debian
4 # Copyright (C) 2015-2016 Ian Jackson
6 # This program is free software; you can redistribute it and/or modify
7 # it under the terms of the GNU General Public License as published by
8 # the Free Software Foundation; either version 3 of the License, or
9 # (at your option) any later version.
11 # This program is distributed in the hope that it will be useful,
12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 # GNU General Public License for more details.
16 # You should have received a copy of the GNU General Public License
17 # along with this program. If not, see <http://www.gnu.org/licenses/>.
21 use Debian::Dgit::Infra; # must precede Debian::Dgit; - can change @INC!
27 dgit-repos-admin-debian [<options>] operation...
29 --git-dir /path/to/git/repo/or/working/tree
30 --repos /path/to/dgit/repos/directory } alternatives
31 --db /path/to/dgit/repos/policy.sqlite3 }
32 (at least one of above required; if only one, cwd is used for other)
36 taint [--global|<package>] <gitobjid> '<comment>'
37 untaint [--global|<package>] <gitobjid>
43 use Debian::Dgit::Policy::Debian;
45 sub badusage ($) { die "bad usage: $_[0]\n$usage"; }
47 use Getopt::Long qw(:config posix_default gnu_compat bundling);
49 our ($git_dir,$repos_dir,$db_path);
51 GetOptions("git-dir=s" => \$git_dir,
52 "repos=s" => \$repos_dir,
56 $db_path //= poldb_path($repos_dir) if defined $repos_dir;
57 $db_path // $repos_dir ||
59 Must supply --git-dir and/or --repos (or --db instead of --repos).
60 If only one of --git-dir and --repos is supplied, other is taken to
61 be current working directory.
71 sub get_package_objid () {
72 $p = shift @ARGV; $p // badusage "operation needs package or --global";
73 if ($p eq '--global') {
76 $p =~ m/^$package_re$/ or badusage 'package name or --global needed';
78 $gitobjid = shift @ARGV;
79 $gitobjid // badusage "operation needs git object id";
80 $gitobjid =~ m/\W/ && badusage "invalid git object id";
83 sub sort_out_git_dir () {
84 foreach my $sfx ('/.git', '') {
85 my $path = "$git_dir/$sfx";
86 if (stat_exists "$path/objects") {
87 $ENV{GIT_DIR} = $git_dir = $path;
91 die "git directory $git_dir doesn't seem valid\n";
94 sub show_taints ($$@) {
95 my ($m, $cond, @condargs) = @_;
96 my $q = $poldbh->prepare
97 ("SELECT package,gitobjid,gitobjtype,time,comment, ".
98 " (gitobjdata IS NOT NULL) hasdata".
99 " FROM taints WHERE $cond".
100 " ORDER BY package, gitobjid, time");
101 $q->execute(@condargs);
102 print "$m:\n" or die $!;
104 while (my $row = $q->fetchrow_hashref) {
105 my $t = strftime "%Y-%m-%dT%H:%M:%S", gmtime $row->{time};
106 my $objinfo = $row->{gitobjtype}. ($row->{hasdata} ? '+' : ' ');
107 my $comment = $row->{comment};
108 $comment =~ s/\\/\\\\/g; $comment =~ s/\n/\\n/g;
109 printf(" %s %-30s %s %7s %s\n",
110 $t, $row->{package}, $row->{gitobjid},
111 $objinfo, $row->{comment})
118 sub cmd_list_taints ($) {
119 badusage "no args/options" if @ARGV;
120 my $count = show_taints("all taints","1");
121 printf "%d taints listed\n", $count or die $!;
124 sub cmd_create_db ($) {
125 badusage "no args/options" if @ARGV;
128 CREATE TABLE IF NOT EXISTS taints (
129 taint_id INTEGER NOT NULL PRIMARY KEY ASC AUTOINCREMENT,
130 package TEXT NOT NULL,
131 gitobjid TEXT NOT NULL,
132 comment TEXT NOT NULL,
139 CREATE INDEX IF NOT EXISTS taints_by_gitobjid
140 ON taints (gitobjid, package)
142 # any one of of the listed deliberatelies will override its taint
143 # the field `deliberately' contains `--deliberately-blah-blah',
144 # not just `blah blah'.
146 CREATE TABLE IF NOT EXISTS taintoverrides (
147 taint_id INTEGER NOT NULL
148 REFERENCES taints (taint_id)
151 DEFERRABLE INITIALLY DEFERRED,
152 deliberately TEXT NOT NULL,
153 PRIMARY KEY (taint_id, deliberately)
160 sub show_taints_bypackage ($) {
162 show_taints($m, "package = ?", $p);
165 sub show_taints_bygitobjid ($) {
167 show_taints($m, "gitobjid = ?", $gitobjid);
170 sub show_relevant_taints ($) {
172 show_taints_bypackage($p ? "$what taints for package $p"
173 : "$what global taints");
174 show_taints_bygitobjid("$what taints for object $gitobjid");
179 my $comment = shift @ARGV;
180 $comment // badusage "operation needs comment";
181 @ARGV && badusage "too many arguments to taint";
184 $!=0; $?=0; my $objtype = `git cat-file -t $gitobjid`;
185 chomp $objtype or die "$? $!";
187 $poldbh->do("INSERT INTO taints".
188 " (package, gitobjid, gitobjtype, time, comment)".
189 " VALUES (?,?,?,?,?)", {},
190 $p, $gitobjid, $objtype, time, $comment);
192 print "taint added\n" or die $!;
193 show_relevant_taints("resulting");
198 @ARGV && badusage "too many arguments to untaint";
200 show_relevant_taints("existing");
202 $poldbh->do("DELETE FROM taints".
203 " WHERE package = ? AND gitobjid = ?",
206 printf "%d taints removed\n", $affected or die $!;
207 exit $affected ? 0 : 1;
211 my $cmd = shift @ARGV;
212 $cmd // badusage "need operation";
215 my $fn = ${*::}{"cmd_$cmd"};
216 $fn or badusage "unknown operation $cmd";
218 poldb_setup($db_path);