chiark / gitweb /
dgit-badcommit-fixup: Ship
[dgit.git] / Debian / Dgit.pm
1 # -*- perl -*-
2 # dgit
3 # Debian::Dgit: functions common to dgit and its helpers and servers
4 #
5 # Copyright (C) 2015-2016  Ian Jackson
6 #
7 #    This program is free software; you can redistribute it and/or modify
8 #    it under the terms of the GNU General Public License as published by
9 #    the Free Software Foundation; either version 3 of the License, or
10 #    (at your option) any later version.
11 #
12 #    This program is distributed in the hope that it will be useful,
13 #    but WITHOUT ANY WARRANTY; without even the implied warranty of
14 #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 #    GNU General Public License for more details.
16 #
17 #    You should have received a copy of the GNU General Public License
18 #    along with this program.  If not, see <http://www.gnu.org/licenses/>.
19
20 package Debian::Dgit;
21
22 use strict;
23 use warnings;
24
25 use Carp;
26 use POSIX;
27 use IO::Handle;
28 use Config;
29 use Digest::SHA;
30 use Data::Dumper;
31
32 BEGIN {
33     use Exporter   ();
34     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
35
36     $VERSION     = 1.00;
37     @ISA         = qw(Exporter);
38     @EXPORT      = qw(setup_sigwarn
39                       dep14_version_mangle
40                       debiantags debiantag_old debiantag_new
41                       server_branch server_ref
42                       stat_exists link_ltarget
43                       hashfile
44                       fail ensuredir executable_on_path
45                       waitstatusmsg failedcmd_waitstatus
46                       failedcmd_report_cmd failedcmd
47                       cmdoutput cmdoutput_errok
48                       git_rev_parse git_get_ref git_for_each_ref
49                       git_for_each_tag_referring is_fast_fwd
50                       $package_re $component_re $deliberately_re
51                       $branchprefix
52                       initdebug enabledebug enabledebuglevel
53                       printdebug debugcmd
54                       $debugprefix *debuglevel *DEBUG
55                       shellquote printcmd messagequote);
56     # implicitly uses $main::us
57     %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)] );
58     @EXPORT_OK   = @{ $EXPORT_TAGS{policyflags} };
59 }
60
61 our @EXPORT_OK;
62
63 our $package_re = '[0-9a-z][-+.0-9a-z]*';
64 our $component_re = '[0-9a-zA-Z][-+.0-9a-zA-Z]*';
65 our $deliberately_re = "(?:TEST-)?$package_re";
66 our $branchprefix = 'dgit';
67
68 # policy hook exit status bits
69 # see dgit-repos-server head comment for documentation
70 # 1 is reserved in case something fails with `exit 1' and to spot
71 # dynamic loader, runtime, etc., failures, which report 127 or 255
72 sub NOFFCHECK () { return 0x2; }
73 sub FRESHREPO () { return 0x4; }
74 sub NOCOMMITCHECK () { return 0x8; }
75
76 our $debugprefix;
77 our $debuglevel = 0;
78
79 sub setup_sigwarn () {
80     our $sigwarn_mainprocess = $$;
81     $SIG{__WARN__} = sub { 
82         die $_[0] unless getppid == $sigwarn_mainprocess;
83     };
84 }
85
86 sub initdebug ($) { 
87     ($debugprefix) = @_;
88     open DEBUG, ">/dev/null" or die $!;
89 }
90
91 sub enabledebug () {
92     open DEBUG, ">&STDERR" or die $!;
93     DEBUG->autoflush(1);
94     $debuglevel ||= 1;
95 }
96     
97 sub enabledebuglevel ($) {
98     my ($newlevel) = @_; # may be undef (eg from env var)
99     die if $debuglevel;
100     $newlevel //= 0;
101     $newlevel += 0;
102     return unless $newlevel;
103     $debuglevel = $newlevel;
104     enabledebug();
105 }
106     
107 sub printdebug {
108     print DEBUG $debugprefix, @_ or die $! if $debuglevel>0;
109 }
110
111 sub messagequote ($) {
112     local ($_) = @_;
113     s{\\}{\\\\}g;
114     s{\n}{\\n}g;
115     s{\x08}{\\b}g;
116     s{\t}{\\t}g;
117     s{[\000-\037\177]}{ sprintf "\\x%02x", ord $& }ge;
118     $_;
119 }
120
121 sub shellquote {
122     my @out;
123     local $_;
124     foreach my $a (@_) {
125         $_ = $a;
126         if (!length || m{[^-=_./:0-9a-z]}i) {
127             s{['\\]}{'\\$&'}g;
128             push @out, "'$_'";
129         } else {
130             push @out, $_;
131         }
132     }
133     return join ' ', @out;
134 }
135
136 sub printcmd {
137     my $fh = shift @_;
138     my $intro = shift @_;
139     print $fh $intro," " or die $!;
140     print $fh shellquote @_ or die $!;
141     print $fh "\n" or die $!;
142 }
143
144 sub debugcmd {
145     my $extraprefix = shift @_;
146     printcmd(\*DEBUG,$debugprefix.$extraprefix,@_) if $debuglevel>0;
147 }
148
149 sub dep14_version_mangle ($) {
150     my ($v) = @_;
151     # DEP-14 patch proposed 2016-11-09  "Version Mangling"
152     $v =~ y/~:/_%/;
153     $v =~ s/\.(?=\.|$|lock$)/.#/g;
154     return $v;
155 }
156
157 sub debiantag_old ($$) { 
158     my ($v,$distro) = @_;
159     return "$distro/". dep14_version_mangle $v;
160 }
161
162 sub debiantag_new ($$) { 
163     my ($v,$distro) = @_;
164     return "archive/$distro/".dep14_version_mangle $v;
165 }
166
167 sub debiantags ($$) {
168     my ($version,$distro) = @_;
169     map { $_->($version, $distro) } (\&debiantag_new, \&debiantag_old);
170 }
171
172 sub server_branch ($) { return "$branchprefix/$_[0]"; }
173 sub server_ref ($) { return "refs/".server_branch($_[0]); }
174
175 sub stat_exists ($) {
176     my ($f) = @_;
177     return 1 if stat $f;
178     return 0 if $!==&ENOENT;
179     die "stat $f: $!";
180 }
181
182 sub _us () {
183     $::us // ($0 =~ m#[^/]*$#, $&);
184 }
185
186 sub fail { 
187     my $s = "@_\n";
188     $s =~ s/\n\n$/\n/;
189     my $prefix = _us().": ";
190     $s =~ s/^/$prefix/gm;
191     die $s;
192 }
193
194 sub ensuredir ($) {
195     my ($dir) = @_; # does not create parents
196     return if mkdir $dir;
197     return if $! == EEXIST;
198     die "mkdir $dir: $!";
199 }
200
201 sub executable_on_path ($) {
202     my ($program) = @_;
203     return 1 if $program =~ m{/};
204     my @path = split /:/, ($ENV{PATH} // "/usr/local/bin:/bin:/usr/bin");
205     foreach my $pe (@path) {
206         my $here = "$pe/$program";
207         return $here if stat_exists $here && -x _;
208     }
209     return undef;
210 }
211
212 our @signames = split / /, $Config{sig_name};
213
214 sub waitstatusmsg () {
215     if (!$?) {
216         return "terminated, reporting successful completion";
217     } elsif (!($? & 255)) {
218         return "failed with error exit status ".WEXITSTATUS($?);
219     } elsif (WIFSIGNALED($?)) {
220         my $signum=WTERMSIG($?);
221         return "died due to fatal signal ".
222             ($signames[$signum] // "number $signum").
223             ($? & 128 ? " (core dumped)" : ""); # POSIX(3pm) has no WCOREDUMP
224     } else {
225         return "failed with unknown wait status ".$?;
226     }
227 }
228
229 sub failedcmd_report_cmd {
230     my $intro = shift @_;
231     $intro //= "failed command";
232     { local ($!); printcmd \*STDERR, _us().": $intro:", @_ or die $!; };
233 }
234
235 sub failedcmd_waitstatus {
236     if ($? < 0) {
237         return "failed to fork/exec: $!";
238     } elsif ($?) {
239         return "subprocess ".waitstatusmsg();
240     } else {
241         return "subprocess produced invalid output";
242     }
243 }
244
245 sub failedcmd {
246     # Expects $!,$? as set by close - see below.
247     # To use with system(), set $?=-1 first.
248     #
249     # Actual behaviour of perl operations:
250     #   success              $!==0       $?==0       close of piped open
251     #   program failed       $!==0       $? >0       close of piped open
252     #   syscall failure      $! >0       $?=-1       close of piped open
253     #   failure              $! >0       unchanged   close of something else
254     #   success              trashed     $?==0       system
255     #   program failed       trashed     $? >0       system
256     #   syscall failure      $! >0       unchanged   system
257     failedcmd_report_cmd undef, @_;
258     fail failedcmd_waitstatus();
259 }
260
261 sub cmdoutput_errok {
262     confess Dumper(\@_)." ?" if grep { !defined } @_;
263     debugcmd "|",@_;
264     open P, "-|", @_ or die "$_[0] $!";
265     my $d;
266     $!=0; $?=0;
267     { local $/ = undef; $d = <P>; }
268     die $! if P->error;
269     if (!close P) { printdebug "=>!$?\n"; return undef; }
270     chomp $d;
271     if ($debuglevel > 0) {
272         $d =~ m/^.*/;
273         my $dd = $&;
274         my $more = (length $' ? '...' : ''); #');
275         $dd =~ s{[^\n -~]|\\}{ sprintf "\\x%02x", ord $& }ge;
276         printdebug "=> \`$dd'",$more,"\n";
277     }
278     return $d;
279 }
280
281 sub cmdoutput {
282     my $d = cmdoutput_errok @_;
283     defined $d or failedcmd @_;
284     return $d;
285 }
286
287 sub link_ltarget ($$) {
288     my ($old,$new) = @_;
289     lstat $old or return undef;
290     if (-l _) {
291         $old = cmdoutput qw(realpath  --), $old;
292     }
293     my $r = link $old, $new;
294     $r = symlink $old, $new if !$r && $!==EXDEV;
295     $r or die "(sym)link $old $new: $!";
296 }
297
298 sub hashfile ($) {
299     my ($fn) = @_;
300     my $h = Digest::SHA->new(256);
301     $h->addfile($fn);
302     return $h->hexdigest();
303 }
304
305 sub git_rev_parse ($) {
306     return cmdoutput qw(git rev-parse), "$_[0]~0";
307 }
308
309 sub git_for_each_ref ($$;$) {
310     my ($pattern,$func,$gitdir) = @_;
311     # calls $func->($objid,$objtype,$fullrefname,$reftail);
312     # $reftail is RHS of ref after refs/[^/]+/
313     # breaks if $pattern matches any ref `refs/blah' where blah has no `/'
314     # $pattern may be an array ref to mean multiple patterns
315     $pattern = [ $pattern ] unless ref $pattern;
316     my @cmd = (qw(git for-each-ref), @$pattern);
317     if (defined $gitdir) {
318         @cmd = ('sh','-ec','cd "$1"; shift; exec "$@"','x', $gitdir, @cmd);
319     }
320     open GFER, "-|", @cmd or die $!;
321     debugcmd "|", @cmd;
322     while (<GFER>) {
323         chomp or die "$_ ?";
324         printdebug "|> ", $_, "\n";
325         m#^(\w+)\s+(\w+)\s+(refs/[^/]+/(\S+))$# or die "$_ ?";
326         $func->($1,$2,$3,$4);
327     }
328     $!=0; $?=0; close GFER or die "$pattern $? $!";
329 }
330
331 sub git_get_ref ($) {
332     # => '' if no such ref
333     my ($refname) = @_;
334     local $_ = $refname;
335     s{^refs/}{[r]efs/} or die "$refname $_ ?";
336     return cmdoutput qw(git for-each-ref --format=%(objectname)), $_;
337 }
338
339 sub git_for_each_tag_referring ($$) {
340     my ($objreferring, $func) = @_;
341     # calls $func->($tagobjid,$refobjid,$fullrefname,$tagname);
342     printdebug "git_for_each_tag_referring ",
343         ($objreferring // 'UNDEF'),"\n";
344     git_for_each_ref('refs/tags', sub {
345         my ($tagobjid,$objtype,$fullrefname,$tagname) = @_;
346         return unless $objtype eq 'tag';
347         my $refobjid = git_rev_parse $tagobjid;
348         return unless
349             !defined $objreferring # caller wants them all
350             or $tagobjid eq $objreferring
351             or $refobjid eq $objreferring;
352         $func->($tagobjid,$refobjid,$fullrefname,$tagname);
353     });
354 }
355
356 sub is_fast_fwd ($$) {
357     my ($ancestor,$child) = @_;
358     my @cmd = (qw(git merge-base), $ancestor, $child);
359     my $mb = cmdoutput_errok @cmd;
360     if (defined $mb) {
361         return git_rev_parse($mb) eq git_rev_parse($ancestor);
362     } else {
363         $?==256 or failedcmd @cmd;
364         return 0;
365     }
366 }
367
368 1;