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/>.
26 dgit-repos-admin-debian [<options>] operation...
28 --git-dir /path/to/git/repo/or/working/tree
29 --repos /path/to/dgit/repos/directory } alternatives
30 --db /path/to/dgit/repos/policy.sqlite3 }
31 (at least one of above required; if only one, cwd is used for other)
35 taint [--global|<package>] <gitobjid> '<comment>'
36 untaint [--global|<package>] <gitobjid>
42 use Debian::Dgit::Policy::Debian;
44 sub badusage ($) { die "bad usage: $_[0]\n$usage"; }
46 use Getopt::Long qw(:config posix_default gnu_compat bundling);
48 our ($git_dir,$repos_dir,$db_path);
50 GetOptions("git-dir=s" => \$git_dir,
51 "repos=s" => \$repos_dir,
55 $db_path //= poldb_path($repos_dir) if defined $repos_dir;
56 $db_path // $repos_dir ||
58 Must supply --git-dir and/or --repos (or --db instead of --repos).
59 If only one of --git-dir and --repos is supplied, other is taken to
60 be current working directory.
70 sub get_package_objid () {
71 $p = shift @ARGV; $p // badusage "operation needs package or --global";
72 if ($p eq '--global') {
75 $p =~ m/^$package_re$/ or badusage 'package name or --global needed';
77 $gitobjid = shift @ARGV;
78 $gitobjid // badusage "operation needs git object id";
79 $gitobjid =~ m/\W/ && badusage "invalid git object id";
82 sub sort_out_git_dir () {
83 foreach my $sfx ('/.git', '') {
84 my $path = "$git_dir/$sfx";
85 if (stat_exists "$path/objects") {
86 $ENV{GIT_DIR} = $git_dir = $path;
90 die "git directory $git_dir doesn't seem valid\n";
93 sub show_taints ($$@) {
94 my ($m, $cond, @condargs) = @_;
95 my $q = $poldbh->prepare
96 ("SELECT package,gitobjid,gitobjtype,time,comment, ".
97 " (gitobjdata IS NOT NULL) hasdata".
98 " FROM taints WHERE $cond".
99 " ORDER BY package, gitobjid, time");
100 $q->execute(@condargs);
101 print "$m:\n" or die $!;
103 while (my $row = $q->fetchrow_hashref) {
104 my $t = strftime "%Y-%m-%dT%H:%M:%S", gmtime $row->{time};
105 my $objinfo = $row->{gitobjtype}. ($row->{hasdata} ? '+' : ' ');
106 my $comment = $row->{comment};
107 $comment =~ s/\\/\\\\/g; $comment =~ s/\n/\\n/g;
108 printf(" %s %-30s %s %7s %s\n",
109 $t, $row->{package}, $row->{gitobjid},
110 $objinfo, $row->{comment})
117 sub cmd_list_taints ($) {
118 badusage "no args/options" if @ARGV;
119 my $count = show_taints("all taints","1");
120 printf "%d taints listed\n", $count or die $!;
123 sub cmd_create_db ($) {
124 badusage "no args/options" if @ARGV;
127 CREATE TABLE IF NOT EXISTS taints (
128 taint_id INTEGER NOT NULL PRIMARY KEY ASC AUTOINCREMENT,
129 package TEXT NOT NULL,
130 gitobjid TEXT NOT NULL,
131 comment TEXT NOT NULL,
138 CREATE INDEX IF NOT EXISTS taints_by_gitobjid
139 ON taints (gitobjid, package)
141 # any one of of the listed deliberatelies will override its taint
142 # the field `deliberately' contains `--deliberately-blah-blah',
143 # not just `blah blah'.
145 CREATE TABLE IF NOT EXISTS taintoverrides (
146 taint_id INTEGER NOT NULL
147 REFERENCES taints (taint_id)
150 DEFERRABLE INITIALLY DEFERRED,
151 deliberately TEXT NOT NULL,
152 PRIMARY KEY (taint_id, deliberately)
159 sub show_taints_bypackage ($) {
161 show_taints($m, "package = ?", $p);
164 sub show_taints_bygitobjid ($) {
166 show_taints($m, "gitobjid = ?", $gitobjid);
169 sub show_relevant_taints ($) {
171 show_taints_bypackage($p ? "$what taints for package $p"
172 : "$what global taints");
173 show_taints_bygitobjid("$what taints for object $gitobjid");
178 my $comment = shift @ARGV;
179 $comment // badusage "operation needs comment";
180 @ARGV && badusage "too many arguments to taint";
183 $!=0; $?=0; my $objtype = `git cat-file -t $gitobjid`;
184 chomp $objtype or die "$? $!";
186 $poldbh->do("INSERT INTO taints".
187 " (package, gitobjid, gitobjtype, time, comment)".
188 " VALUES (?,?,?,?,?)", {},
189 $p, $gitobjid, $objtype, time, $comment);
191 print "taint added\n" or die $!;
192 show_relevant_taints("resulting");
197 @ARGV && badusage "too many arguments to untaint";
199 show_relevant_taints("existing");
201 $poldbh->do("DELETE FROM taints".
202 " WHERE package = ? AND gitobjid = ?",
205 printf "%d taints removed\n", $affected or die $!;
206 exit $affected ? 0 : 1;
210 my $cmd = shift @ARGV;
211 $cmd // badusage "need operation";
214 my $fn = ${*::}{"cmd_$cmd"};
215 $fn or badusage "unknown operation $cmd";
217 poldb_setup($db_path);