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