chiark / gitweb /
changelog: start 9.10
[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-2019  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 use File::Path qw(:DEFAULT make_path);
33 use File::Basename;
34 use Dpkg::Control::Hash;
35 use Debian::Dgit::ExitStatus;
36 use Debian::Dgit::I18n;
37
38 BEGIN {
39     use Exporter   ();
40     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
41
42     $VERSION     = 1.00;
43     @ISA         = qw(Exporter);
44     @EXPORT      = qw(setup_sigwarn forkcheck_setup forkcheck_mainprocess
45                       dep14_version_mangle
46                       debiantags debiantag_new
47                       debiantag_maintview
48                       upstreamversion
49                       upstream_commitish_search resolve_upstream_version
50                       stripepoch source_file_leafname is_orig_file_of_p_v
51                       server_branch server_ref
52                       stat_exists link_ltarget rename_link_xf
53                       hashfile
54                       fail failmsg ensuredir ensurepath
55                       must_getcwd executable_on_path
56                       waitstatusmsg failedcmd_waitstatus
57                       failedcmd_report_cmd failedcmd
58                       runcmd shell_cmd cmdoutput cmdoutput_errok
59                       @git
60                       git_rev_parse changedir_git_toplevel git_cat_file
61                       git_get_ref git_get_symref git_for_each_ref
62                       git_for_each_tag_referring is_fast_fwd
63                       git_check_unmodified
64                       git_reflog_action_msg  git_update_ref_cmd
65                       rm_subdir_cached read_tree_subdir
66                       read_tree_debian read_tree_upstream
67                       make_commit hash_commit hash_commit_text
68                       reflog_cache_insert reflog_cache_lookup
69                       $package_re $component_re $suite_re $deliberately_re
70                       $distro_re $versiontag_re $series_filename_re
71                       $orig_f_comp_re $orig_f_sig_re
72                       $tarball_f_ext_re $orig_f_tail_re
73                       $extra_orig_namepart_re
74                       $git_null_obj
75                       $branchprefix
76                       $ffq_refprefix $gdrlast_refprefix
77                       initdebug enabledebug enabledebuglevel
78                       printdebug debugcmd
79                       $printdebug_when_debuglevel $debugcmd_when_debuglevel
80                       $debugprefix *debuglevel *DEBUG
81                       shellquote printcmd messagequote
82                       $negate_harmful_gitattrs
83                       changedir git_slurp_config_src
84                       gdr_ffq_prev_branchinfo
85                       parsecontrolfh parsecontrol parsechangelog
86                       getfield parsechangelog_loop
87                       playtree_setup);
88     # implicitly uses $main::us
89     %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)],
90                      playground => [qw(record_maindir $maindir $local_git_cfg
91                                        $maindir_gitdir $maindir_gitcommon
92                                        fresh_playground
93                                        ensure_a_playground)]);
94     @EXPORT_OK   = ( @{ $EXPORT_TAGS{policyflags} },
95                      @{ $EXPORT_TAGS{playground} } );
96 }
97
98 our @EXPORT_OK;
99
100 our $package_re = '[0-9a-z][-+.0-9a-z]*';
101 our $component_re = '[0-9a-zA-Z][-+.0-9a-zA-Z]*';
102 our $suite_re = '[-+.0-9a-z]+';
103 our $deliberately_re = "(?:TEST-)?$package_re";
104 our $distro_re = $component_re;
105 our $versiontag_re = qr{[-+.\%_0-9a-zA-Z/]+};
106 our $branchprefix = 'dgit';
107 our $series_filename_re = qr{(?:^|\.)series(?!\n)$}s;
108 our $extra_orig_namepart_re = qr{[-0-9a-zA-Z]+};
109 our $orig_f_comp_re = qr{orig(?:-$extra_orig_namepart_re)?};
110 our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)';
111 our $tarball_f_ext_re = "\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?";
112 our $orig_f_tail_re = "$orig_f_comp_re$tarball_f_ext_re";
113 our $git_null_obj = '0' x 40;
114 our $ffq_refprefix = 'ffq-prev';
115 our $gdrlast_refprefix = 'debrebase-last';
116 our $printdebug_when_debuglevel = 1;
117 our $debugcmd_when_debuglevel = 1;
118
119 our (@git) = qw(git);
120
121 # these three all go together, only valid after record_maindir
122 our $maindir;
123 our $maindir_gitdir;
124 our $maindir_gitcommon;
125
126 # policy hook exit status bits
127 # see dgit-repos-server head comment for documentation
128 # 1 is reserved in case something fails with `exit 1' and to spot
129 # dynamic loader, runtime, etc., failures, which report 127 or 255
130 sub NOFFCHECK () { return 0x2; }
131 sub FRESHREPO () { return 0x4; }
132 sub NOCOMMITCHECK () { return 0x8; }
133
134 our $debugprefix;
135 our $debuglevel = 0;
136
137 our $negate_harmful_gitattrs =
138     "-text -eol -crlf -ident -filter -working-tree-encoding";
139     # ^ when updating this, alter the regexp in dgit:is_gitattrs_setup
140
141 our $forkcheck_mainprocess;
142
143 sub forkcheck_setup () {
144     $forkcheck_mainprocess = $$;
145 }
146
147 sub forkcheck_mainprocess () {
148     # You must have called forkcheck_setup or setup_sigwarn already
149     getppid != $forkcheck_mainprocess;
150 }
151
152 sub setup_sigwarn () {
153     forkcheck_setup();
154     $SIG{__WARN__} = sub { 
155         confess $_[0] if forkcheck_mainprocess;
156     };
157 }
158
159 sub initdebug ($) { 
160     ($debugprefix) = @_;
161     open DEBUG, ">/dev/null" or confess "$!";
162 }
163
164 sub enabledebug () {
165     open DEBUG, ">&STDERR" or confess "$!";
166     DEBUG->autoflush(1);
167     $debuglevel ||= 1;
168 }
169     
170 sub enabledebuglevel ($) {
171     my ($newlevel) = @_; # may be undef (eg from env var)
172     confess if $debuglevel;
173     $newlevel //= 0;
174     $newlevel += 0;
175     return unless $newlevel;
176     $debuglevel = $newlevel;
177     enabledebug();
178 }
179     
180 sub printdebug {
181     # Prints a prefix, and @_, to DEBUG.  @_ should normally contain
182     # a trailing \n.
183
184     # With no (or only empty) arguments just prints the prefix and
185     # leaves the caller to do more with DEBUG.  The caller should make
186     # sure then to call printdebug with something ending in "\n" to
187     # get the prefix right in subsequent calls.
188
189     return unless $debuglevel >= $printdebug_when_debuglevel;
190     our $printdebug_noprefix;
191     print DEBUG $debugprefix unless $printdebug_noprefix;
192     pop @_ while @_ and !length $_[-1];
193     return unless @_;
194     print DEBUG @_ or confess "$!";
195     $printdebug_noprefix = $_[-1] !~ m{\n$};
196 }
197
198 sub messagequote ($) {
199     local ($_) = @_;
200     s{\\}{\\\\}g;
201     s{\n}{\\n}g;
202     s{\x08}{\\b}g;
203     s{\t}{\\t}g;
204     s{[\000-\037\177]}{ sprintf "\\x%02x", ord $& }ge;
205     $_;
206 }
207
208 sub shellquote {
209     my @out;
210     local $_;
211     defined or confess __ 'internal error' foreach @_;
212     foreach my $a (@_) {
213         $_ = $a;
214         if (!length || m{[^-=_./:0-9a-z]}i) {
215             s{['\\]}{'\\$&'}g;
216             push @out, "'$_'";
217         } else {
218             push @out, $_;
219         }
220     }
221     return join ' ', @out;
222 }
223
224 sub printcmd {
225     my $fh = shift @_;
226     my $intro = shift @_;
227     print $fh $intro." ".(join '', shellquote @_)."\n" or confess "$!";
228 }
229
230 sub debugcmd {
231     my $extraprefix = shift @_;
232     printcmd(\*DEBUG,$debugprefix.$extraprefix,@_)
233         if $debuglevel >= $debugcmd_when_debuglevel;
234 }
235
236 sub dep14_version_mangle ($) {
237     my ($v) = @_;
238     # DEP-14 patch proposed 2016-11-09  "Version Mangling"
239     $v =~ y/~:/_%/;
240     $v =~ s/\.(?=\.|$|lock$)/.#/g;
241     return $v;
242 }
243
244 sub debiantag_new ($$) { 
245     my ($v,$distro) = @_;
246     return "archive/$distro/".dep14_version_mangle $v;
247 }
248
249 sub debiantag_maintview ($$) { 
250     my ($v,$distro) = @_;
251     return "$distro/".dep14_version_mangle $v;
252 }
253
254 sub debiantags ($$) {
255     my ($version,$distro) = @_;
256     map { $_->($version, $distro) } (\&debiantag_new, \&debiantag_maintview);
257 }
258
259 sub stripepoch ($) {
260     my ($vsn) = @_;
261     $vsn =~ s/^\d+\://;
262     return $vsn;
263 }
264
265 sub upstreamversion ($) {
266     my ($vsn) = @_;
267     $vsn =~ s/-[^-]+$//;
268     return $vsn;
269 }
270
271 sub source_file_leafname ($$$) {
272     my ($package,$vsn,$sfx) = @_;
273     return "${package}_".(stripepoch $vsn).$sfx
274 }
275
276 sub is_orig_file_of_p_v ($$$) {
277     my ($f, $package, $upstreamvsn) = @_;
278     my $base = source_file_leafname $package, $upstreamvsn, '';
279     return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/;
280     return 1;
281 }
282
283 sub server_branch ($) { return "$branchprefix/$_[0]"; }
284 sub server_ref ($) { return "refs/".server_branch($_[0]); }
285
286 sub stat_exists ($) {
287     my ($f) = @_;
288     return 1 if stat $f;
289     return 0 if $!==&ENOENT;
290     confess "stat $f: $!";
291 }
292
293 sub _us () {
294     $::us // ($0 =~ m#[^/]*$#, $&);
295 }
296
297 sub failmsg {
298     my $s = f_ "error: %s\n", "@_";
299     $s =~ s/\n\n$/\n/g;
300     my $prefix = _us().": ";
301     $s =~ s/^/$prefix/gm;
302     return "\n".$s;
303 }
304
305 sub fail {
306     die failmsg @_;
307 }
308
309 sub ensuredir ($) {
310     my ($dir) = @_; # does not create parents
311     return if mkdir $dir;
312     return if $! == EEXIST;
313     confess "mkdir $dir: $!";
314 }
315
316 sub ensurepath ($$) {
317     my ($firsttocreate, $subdir) = @_; # creates necessary bits of $subidr
318     ensuredir $firsttocreate;
319     make_path "$firsttocreate/$subdir";
320 }
321
322 sub must_getcwd () {
323     my $d = getcwd();
324     defined $d or fail f_ "getcwd failed: %s\n", $!;
325     return $d;
326 }
327
328 sub executable_on_path ($) {
329     my ($program) = @_;
330     return 1 if $program =~ m{/};
331     my @path = split /:/, ($ENV{PATH} // "/usr/local/bin:/bin:/usr/bin");
332     foreach my $pe (@path) {
333         my $here = "$pe/$program";
334         return $here if stat_exists $here && -x _;
335     }
336     return undef;
337 }
338
339 our @signames = split / /, $Config{sig_name};
340
341 sub waitstatusmsg () {
342     if (!$?) {
343         return __ "terminated, reporting successful completion";
344     } elsif (!($? & 255)) {
345         return f_ "failed with error exit status %s", WEXITSTATUS($?);
346     } elsif (WIFSIGNALED($?)) {
347         my $signum=WTERMSIG($?);
348         return f_ "died due to fatal signal %s",
349             ($signames[$signum] // "number $signum").
350             ($? & 128 ? " (core dumped)" : ""); # POSIX(3pm) has no WCOREDUMP
351     } else {
352         return f_ "failed with unknown wait status %s", $?;
353     }
354 }
355
356 sub failedcmd_report_cmd {
357     my $intro = shift @_;
358     $intro //= __ "failed command";
359     { local ($!); printcmd \*STDERR, _us().": $intro:", @_ or confess "$!"; };
360 }
361
362 sub failedcmd_waitstatus {
363     if ($? < 0) {
364         return f_ "failed to fork/exec: %s", $!;
365     } elsif ($?) {
366         return f_ "subprocess %s", waitstatusmsg();
367     } else {
368         return __ "subprocess produced invalid output";
369     }
370 }
371
372 sub failedcmd {
373     # Expects $!,$? as set by close - see below.
374     # To use with system(), set $?=-1 first.
375     #
376     # Actual behaviour of perl operations:
377     #   success              $!==0       $?==0       close of piped open
378     #   program failed       $!==0       $? >0       close of piped open
379     #   syscall failure      $! >0       $?=-1       close of piped open
380     #   failure              $! >0       unchanged   close of something else
381     #   success              trashed     $?==0       system
382     #   program failed       trashed     $? >0       system
383     #   syscall failure      $! >0       unchanged   system
384     failedcmd_report_cmd undef, @_;
385     fail failedcmd_waitstatus();
386 }
387
388 sub runcmd {
389     debugcmd "+",@_;
390     $!=0; $?=-1;
391     failedcmd @_ if system @_;
392 }
393
394 sub shell_cmd {
395     my ($first_shell, @cmd) = @_;
396     return qw(sh -ec), $first_shell.'; exec "$@"', 'x', @cmd;
397 }
398
399 sub cmdoutput_errok {
400     confess Dumper(\@_)." ?" if grep { !defined } @_;
401     local $printdebug_when_debuglevel = $debugcmd_when_debuglevel;
402     debugcmd "|",@_;
403     open P, "-|", @_ or confess "$_[0] $!";
404     my $d;
405     $!=0; $?=0;
406     { local $/ = undef; $d = <P>; }
407     confess "$!" if P->error;
408     if (!close P) { printdebug "=>!$?\n"; return undef; }
409     chomp $d;
410     if ($debuglevel > 0) {
411         $d =~ m/^.*/;
412         my $dd = $&;
413         my $more = (length $' ? '...' : ''); #');
414         $dd =~ s{[^\n -~]|\\}{ sprintf "\\x%02x", ord $& }ge;
415         printdebug "=> \`$dd'",$more,"\n";
416     }
417     return $d;
418 }
419
420 sub cmdoutput {
421     my $d = cmdoutput_errok @_;
422     defined $d or failedcmd @_;
423     return $d;
424 }
425
426 sub link_ltarget ($$) {
427     my ($old,$new) = @_;
428     lstat $old or return undef;
429     if (-l _) {
430         $old = cmdoutput qw(realpath  --), $old;
431     }
432     my $r = link $old, $new;
433     $r = symlink $old, $new if !$r && $!==EXDEV;
434     $r or fail "(sym)link $old $new: $!\n";
435 }
436
437 sub rename_link_xf ($$$) {
438     # renames/moves or links/copies $src to $dst,
439     # even if $dst is on a different fs
440     # (May use the filename "$dst.tmp".);
441     # On success, returns true.
442     # On failure, returns false and sets
443     #    $@ to a reason message
444     #    $! to an errno value, or -1 if not known
445     # having possibly printed something about mv to stderr.
446     # Not safe to use without $keeporig if $dst might be a symlink
447     # to $src, as it might delete $src leaving $dst invalid.
448     my ($keeporig,$src,$dst) = @_;
449     if ($keeporig
450         ? link   $src, $dst
451         : rename $src, $dst) {
452         return 1;
453     }
454     if ($! != EXDEV) {
455         $@ = "$!";
456         return 0;
457     }
458     if (!stat $src) {
459         $@ = f_ "stat source file: %S", $!;
460         return 0;
461     }
462     my @src_stat = (stat _)[0..1];
463
464     my @dst_stat;
465     if (stat $dst) {
466         @dst_stat = (stat _)[0..1];
467     } elsif ($! == ENOENT) {
468     } else {
469         $@ = f_ "stat destination file: %S", $!;
470         return 0;
471     }
472
473     if ("@src_stat" eq "@dst_stat") {
474         # (Symlinks to) the same file.  No need for a copy but
475         # we may need to delete the original.
476         printdebug "rename_link_xf $keeporig $src $dst EXDEV but same\n";
477     } else {
478         $!=0; $?=0;
479         my @cmd = (qw(cp --), $src, "$dst.tmp");
480         debugcmd '+',@cmd;
481         if (system @cmd) {
482             failedcmd_report_cmd undef, @cmd;
483             $@ = failedcmd_waitstatus();
484             $! = -1;
485             return 0;
486         }
487         if (!rename "$dst.tmp", $dst) {
488             $@ = f_ "finally install file after cp: %S", $!;
489             return 0;
490         }
491     }
492     if (!$keeporig) {
493         if (!unlink $src) {
494             $@ = f_ "delete old file after cp: %S", $!;
495             return 0;
496         }
497     }
498     return 1;
499 }
500
501 sub hashfile ($) {
502     my ($fn) = @_;
503     my $h = Digest::SHA->new(256);
504     $h->addfile($fn);
505     return $h->hexdigest();
506 }
507
508 sub git_rev_parse ($) {
509     return cmdoutput qw(git rev-parse), "$_[0]~0";
510 }
511
512 sub changedir_git_toplevel () {
513     my $toplevel = cmdoutput qw(git rev-parse --show-toplevel);
514     length $toplevel or fail __ <<END;
515 not in a git working tree?
516 (git rev-parse --show-toplevel produced no output)
517 END
518     chdir $toplevel or fail f_ "chdir toplevel %s: %s\n", $toplevel, $!;
519 }
520
521 sub git_cat_file ($;$) {
522     my ($objname, $etype) = @_;
523     # => ($type, $data) or ('missing', undef)
524     # in scalar context, just the data
525     # if $etype defined, dies unless type is $etype or in @$etype
526     our ($gcf_pid, $gcf_i, $gcf_o);
527     local $printdebug_when_debuglevel = $debugcmd_when_debuglevel;
528     my $chk = sub {
529         my ($gtype, $data) = @_;
530         if ($etype) {
531             $etype = [$etype] unless ref $etype;
532             confess "$objname expected @$etype but is $gtype"
533                 unless grep { $gtype eq $_ } @$etype;
534         }
535         return ($gtype, $data);
536     };
537     if (!$gcf_pid) {
538         my @cmd = qw(git cat-file --batch);
539         debugcmd "GCF|", @cmd;
540         $gcf_pid = open2 $gcf_o, $gcf_i, @cmd or confess "$!";
541     }
542     printdebug "GCF>| $objname\n";
543     print $gcf_i $objname, "\n" or confess "$!";
544     my $x = <$gcf_o>;
545     printdebug "GCF<| ", $x;
546     if ($x =~ m/ (missing)$/) { return $chk->($1, undef); }
547     my ($type, $size) = $x =~ m/^.* (\w+) (\d+)\n/ or confess "$objname ?";
548     my $data;
549     (read $gcf_o, $data, $size) == $size or confess "$objname $!";
550     $x = <$gcf_o>;
551     $x eq "\n" or confess "$objname ($_) $!";
552     return $chk->($type, $data);
553 }
554
555 sub git_get_symref (;$) {
556     my ($symref) = @_;  $symref //= 'HEAD';
557     # => undef if not a symref, otherwise refs/...
558     my @cmd = (qw(git symbolic-ref -q HEAD));
559     my $branch = cmdoutput_errok @cmd;
560     if (!defined $branch) {
561         $?==256 or failedcmd @cmd;
562     } else {
563         chomp $branch;
564     }
565     return $branch;
566 }
567
568 sub git_for_each_ref ($$;$) {
569     my ($pattern,$func,$gitdir) = @_;
570     # calls $func->($objid,$objtype,$fullrefname,$reftail);
571     # $reftail is RHS of ref after refs/[^/]+/
572     # breaks if $pattern matches any ref `refs/blah' where blah has no `/'
573     # $pattern may be an array ref to mean multiple patterns
574     $pattern = [ $pattern ] unless ref $pattern;
575     my @cmd = (qw(git for-each-ref), @$pattern);
576     if (defined $gitdir) {
577         @cmd = ('sh','-ec','cd "$1"; shift; exec "$@"','x', $gitdir, @cmd);
578     }
579     open GFER, "-|", @cmd or confess "$!";
580     debugcmd "|", @cmd;
581     while (<GFER>) {
582         chomp or confess "$_ ?";
583         printdebug "|> ", $_, "\n";
584         m#^(\w+)\s+(\w+)\s+(refs/[^/]+/(\S+))$# or confess "$_ ?";
585         $func->($1,$2,$3,$4);
586     }
587     $!=0; $?=0; close GFER or confess "$pattern $? $!";
588 }
589
590 sub git_get_ref ($) {
591     # => '' if no such ref
592     my ($refname) = @_;
593     local $_ = $refname;
594     s{^refs/}{[r]efs/} or confess "$refname $_ ?";
595     return cmdoutput qw(git for-each-ref --format=%(objectname)), $_;
596 }
597
598 sub git_for_each_tag_referring ($$) {
599     my ($objreferring, $func) = @_;
600     # calls $func->($tagobjid,$refobjid,$fullrefname,$tagname);
601     printdebug "git_for_each_tag_referring ",
602         ($objreferring // 'UNDEF'),"\n";
603     git_for_each_ref('refs/tags', sub {
604         my ($tagobjid,$objtype,$fullrefname,$tagname) = @_;
605         return unless $objtype eq 'tag';
606         my $refobjid = git_rev_parse $tagobjid;
607         return unless
608             !defined $objreferring # caller wants them all
609             or $tagobjid eq $objreferring
610             or $refobjid eq $objreferring;
611         $func->($tagobjid,$refobjid,$fullrefname,$tagname);
612     });
613 }
614
615 sub git_check_unmodified () {
616     foreach my $cached (qw(0 1)) {
617         my @cmd = qw(git diff --quiet);
618         push @cmd, qw(--cached) if $cached;
619         push @cmd, qw(HEAD);
620         debugcmd "+",@cmd;
621         $!=0; $?=-1; system @cmd;
622         return if !$?;
623         if ($?==256) {
624             fail
625                 $cached
626                 ? __ "git index contains changes (does not match HEAD)"
627                 : __ "working tree is dirty (does not match HEAD)";
628         } else {
629             failedcmd @cmd;
630         }
631     }
632 }
633
634 sub upstream_commitish_search ($$) {
635     my ($upstream_version, $tried) = @_;
636     # todo: at some point maybe use git-deborig to do this
637     foreach my $tagpfx ('', 'v', 'upstream/') {
638         my $tag = $tagpfx.(dep14_version_mangle $upstream_version);
639         my $new_upstream = git_get_ref "refs/tags/$tag";
640         push @$tried, $tag;
641         return $new_upstream if length $new_upstream;
642     }
643 }
644
645 sub resolve_upstream_version ($$) {
646     my ($new_upstream, $upstream_version) = @_;
647
648     my $used = $new_upstream;
649     my $message = __ 'using specified upstream commitish';
650     if (!defined $new_upstream) {
651         my @tried;
652         $new_upstream = upstream_commitish_search $upstream_version, \@tried;
653         if (!length $new_upstream) {
654             fail f_
655                 "Could not determine appropriate upstream commitish.\n".
656                 " (Tried these tags: %s)\n".
657                 " Check version, and specify upstream commitish explicitly.",
658                 "@tried";
659         }
660         $used = $tried[-1];
661         $message = f_ 'using upstream from git tag %s', $used;
662     } elsif ($new_upstream =~ m{^refs/tags/($versiontag_re)$}s) {
663         $message = f_ 'using upstream from git tag %s', $1;
664         $used = $1;
665     }   
666     $new_upstream = git_rev_parse $new_upstream;
667
668     return ($new_upstream, $used, $message);
669     # used is a human-readable idea of what we found
670 }
671
672 sub is_fast_fwd ($$) {
673     my ($ancestor,$child) = @_;
674     my @cmd = (qw(git merge-base), $ancestor, $child);
675     my $mb = cmdoutput_errok @cmd;
676     if (defined $mb) {
677         return git_rev_parse($mb) eq git_rev_parse($ancestor);
678     } else {
679         $?==256 or failedcmd @cmd;
680         return 0;
681     }
682 }
683
684 sub git_reflog_action_msg ($) {
685     my ($msg) = @_;
686     my $rla = $ENV{GIT_REFLOG_ACTION};
687     $msg = "$rla: $msg" if length $rla;
688     return $msg;
689 }
690
691 sub git_update_ref_cmd {
692     # returns  qw(git update-ref), qw(-m), @_
693     # except that message may be modified to honour GIT_REFLOG_ACTION
694     my $msg = shift @_;
695     $msg = git_reflog_action_msg $msg;
696     return qw(git update-ref -m), $msg, @_;
697 }
698
699 sub rm_subdir_cached ($) {
700     my ($subdir) = @_;
701     runcmd qw(git rm --quiet -rf --cached --ignore-unmatch), $subdir;
702 }
703
704 sub read_tree_subdir ($$) {
705     my ($subdir, $new_tree_object) = @_;
706     # If $new_tree_object is '', the subtree is deleted.
707     confess unless defined $new_tree_object;
708     rm_subdir_cached $subdir;
709     runcmd qw(git read-tree), "--prefix=$subdir/", $new_tree_object
710         if length $new_tree_object;
711 }
712
713 sub read_tree_debian ($) {
714     my ($treeish) = @_;
715     read_tree_subdir 'debian', "$treeish:debian";
716     rm_subdir_cached 'debian/patches';
717 }
718
719 sub read_tree_upstream ($;$$) {
720     my ($treeish, $keep_patches, $tree_with_debian) = @_;
721     # if $tree_with_debian is supplied, will use that for debian/
722     # otherwise will save and restore it.  If $tree_with_debian
723     # is '' then debian/ is deleted.
724     my $debian =
725         defined $tree_with_debian ? "$tree_with_debian:debian"
726         : cmdoutput qw(git write-tree --prefix=debian/);
727     runcmd qw(git read-tree), $treeish;
728     read_tree_subdir 'debian', $debian;
729     rm_subdir_cached 'debian/patches' unless $keep_patches;
730 }
731
732 sub changedir ($) {
733     my ($newdir) = @_;
734     printdebug "CD $newdir\n";
735     chdir $newdir or confess "chdir: $newdir: $!";
736 }
737
738 sub git_slurp_config_src ($) {
739     my ($src) = @_;
740     # returns $r such that $r->{KEY}[] = VALUE
741     my @cmd = (qw(git config -z --get-regexp), "--$src", qw(.*));
742     debugcmd "|",@cmd;
743
744     local ($debuglevel) = $debuglevel-2;
745     local $/="\0";
746
747     my $r = { };
748     open GITS, "-|", @cmd or confess "$!";
749     while (<GITS>) {
750         chomp or confess;
751         printdebug "=> ", (messagequote $_), "\n";
752         m/\n/ or confess "$_ ?";
753         push @{ $r->{$`} }, $'; #';
754     }
755     $!=0; $?=0;
756     close GITS
757         or ($!==0 && $?==256)
758         or failedcmd @cmd;
759     return $r;
760 }
761
762 sub gdr_ffq_prev_branchinfo ($) {
763     my ($symref) = @_;
764     # => ('status', "message", [$symref, $ffq_prev, $gdrlast])
765     # 'status' may be
766     #    branch         message is undef
767     #    weird-symref   } no $symref,
768     #    notbranch      }  no $ffq_prev
769     return ('detached', __ 'detached HEAD') unless defined $symref;
770     return ('weird-symref', __ 'HEAD symref is not to refs/')
771         unless $symref =~ m{^refs/};
772     my $ffq_prev = "refs/$ffq_refprefix/$'";
773     my $gdrlast = "refs/$gdrlast_refprefix/$'";
774     printdebug "ffq_prev_branchinfo branch current $symref\n";
775     return ('branch', undef, $symref, $ffq_prev, $gdrlast);
776 }
777
778 sub parsecontrolfh ($$;$) {
779     my ($fh, $desc, $allowsigned) = @_;
780     our $dpkgcontrolhash_noissigned;
781     my $c;
782     for (;;) {
783         my %opts = ('name' => $desc);
784         $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned;
785         $c = Dpkg::Control::Hash->new(%opts);
786         $c->parse($fh,$desc) or fail f_ "parsing of %s failed", $desc;
787         last if $allowsigned;
788         last if $dpkgcontrolhash_noissigned;
789         my $issigned= $c->get_option('is_pgp_signed');
790         if (!defined $issigned) {
791             $dpkgcontrolhash_noissigned= 1;
792             seek $fh, 0,0 or confess "seek $desc: $!";
793         } elsif ($issigned) {
794             fail f_
795                 "control file %s is (already) PGP-signed. ".
796                 " Note that dgit push needs to modify the .dsc and then".
797                 " do the signature itself",
798                 $desc;
799         } else {
800             last;
801         }
802     }
803     return $c;
804 }
805
806 sub parsecontrol {
807     my ($file, $desc, $allowsigned) = @_;
808     my $fh = new IO::Handle;
809     open $fh, '<', $file or fail f_ "open %s (%s): %s", $file, $desc, $!;
810     my $c = parsecontrolfh($fh,$desc,$allowsigned);
811     $fh->error and confess "$!";
812     close $fh;
813     return $c;
814 }
815
816 sub parsechangelog {
817     my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
818     my $p = new IO::Handle;
819     my @cmd = (qw(dpkg-parsechangelog), @_);
820     open $p, '-|', @cmd or confess "$!";
821     $c->parse($p);
822     $?=0; $!=0; close $p or failedcmd @cmd;
823     return $c;
824 }
825
826 sub getfield ($$) {
827     my ($dctrl,$field) = @_;
828     my $v = $dctrl->{$field};
829     return $v if defined $v;
830     fail f_ "missing field %s in %s", $field, $dctrl->get_option('name');
831 }
832
833 sub parsechangelog_loop ($$$) {
834     my ($clogcmd, $descbase, $fn) = @_;
835     # @$clogcmd is qw(dpkg-parsechangelog ...some...options...)
836     # calls $fn->($thisstanza, $desc);
837     debugcmd "|",@$clogcmd;
838     open CLOGS, "-|", @$clogcmd or confess "$!";
839     for (;;) {
840         my $stanzatext = do { local $/=""; <CLOGS>; };
841         printdebug "clogp stanza ".Dumper($stanzatext) if $debuglevel>1;
842         last if !defined $stanzatext;
843
844         my $desc = "$descbase, entry no.$.";
845         open my $stanzafh, "<", \$stanzatext or confess;
846         my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
847
848         $fn->($thisstanza, $desc);
849     }
850     confess "$!" if CLOGS->error;
851     close CLOGS or $?==SIGPIPE or failedcmd @$clogcmd;
852 }       
853
854 sub make_commit ($$) {
855     my ($parents, $message_paras) = @_;
856     my $tree = cmdoutput qw(git write-tree);
857     my @cmd = (qw(git commit-tree), $tree);
858     push @cmd, qw(-p), $_ foreach @$parents;
859     push @cmd, qw(-m), $_ foreach @$message_paras;
860     return cmdoutput @cmd;
861 }
862
863 sub hash_commit ($) {
864     my ($file) = @_;
865     return cmdoutput qw(git hash-object -w -t commit), $file;
866 }
867
868 sub hash_commit_text ($) {
869     my ($text) = @_;
870     my ($out, $in);
871     my @cmd = (qw(git hash-object -w -t commit --stdin));
872     debugcmd "|",@cmd;
873     print Dumper($text) if $debuglevel > 1;
874     my $child = open2($out, $in, @cmd) or confess "$!";
875     my $h;
876     eval {
877         print $in $text or confess "$!";
878         close $in or confess "$!";
879         $h = <$out>;
880         $h =~ m/^\w+$/ or confess;
881         $h = $&;
882         printdebug "=> $h\n";
883     };
884     close $out;
885     waitpid $child, 0 == $child or confess "$child $!";
886     $? and failedcmd @cmd;
887     return $h;
888 }
889
890 sub reflog_cache_insert ($$$) {
891     my ($ref, $cachekey, $value) = @_;
892     # you must call this in $maindir
893     # you must have called record_maindir
894
895     # When we no longer need to support squeeze, use --create-reflog
896     # instead of this:
897     my $parent = $ref; $parent =~ s{/[^/]+$}{};
898     ensurepath "$maindir_gitcommon/logs", "$parent";
899     my $makelogfh = new IO::File "$maindir_gitcommon/logs/$ref", '>>'
900       or confess "$!";
901
902     my $oldcache = git_get_ref $ref;
903
904     if ($oldcache eq $value) {
905         my $tree = cmdoutput qw(git rev-parse), "$value:";
906         # git update-ref doesn't always update, in this case.  *sigh*
907         my $authline = (ucfirst _us()).
908             ' <'._us().'@example.com> 1000000000 +0000';
909         my $dummy = hash_commit_text <<ENDU.(__ <<END);
910 tree $tree
911 parent $value
912 author $authline
913 committer $authline
914
915 ENDU
916 Dummy commit - do not use
917 END
918         runcmd qw(git update-ref -m), _us()." - dummy", $ref, $dummy;
919     }
920     runcmd qw(git update-ref -m), $cachekey, $ref, $value;
921 }
922
923 sub reflog_cache_lookup ($$) {
924     my ($ref, $cachekey) = @_;
925     # you may call this in $maindir or in a playtree
926     # you must have called record_maindir
927     my @cmd = (qw(git log -g), '--pretty=format:%H %gs', $ref);
928     debugcmd "|(probably)",@cmd;
929     my $child = open GC, "-|";  defined $child or confess "$!";
930     if (!$child) {
931         chdir $maindir or confess "$!";
932         if (!stat "$maindir_gitcommon/logs/$ref") {
933             $! == ENOENT or confess "$!";
934             printdebug ">(no reflog)\n";
935             finish 0;
936         }
937         exec @cmd; die f_ "exec %s: %s\n", $cmd[0], $!;
938     }
939     while (<GC>) {
940         chomp;
941         printdebug ">| ", $_, "\n" if $debuglevel > 1;
942         next unless m/^(\w+) (\S.*\S)$/ && $2 eq $cachekey;
943         close GC;
944         return $1;
945     }
946     confess "$!" if GC->error;
947     failedcmd unless close GC;
948     return undef;
949 }
950
951 # ========== playground handling ==========
952
953 # terminology:
954 #
955 #   $maindir      user's git working tree
956 #   playground    area in .git/ where we can make files, unpack, etc. etc.
957 #   playtree      git working tree sharing object store with the user's
958 #                 inside playground, or identical to it
959 #
960 # other globals
961 #
962 #   $local_git_cfg    hash of arrays of values: git config from $maindir
963 #
964 # expected calling pattern
965 #
966 #  firstly
967 #
968 #    [record_maindir]
969 #      must be run in directory containing .git
970 #      assigns to $maindir if not already set
971 #      also calls git_slurp_config_src to record git config
972 #        in $local_git_cfg, unless it's already set
973 #
974 #    fresh_playground SUBDIR_PATH_COMPONENTS
975 #      e.g fresh_playground 'dgit/unpack' ('.git/' is implied)
976 #      default SUBDIR_PATH_COMPONENTS is playground_subdir
977 #      calls record_maindir
978 #      sets up a new playground (destroying any old one)
979 #      returns playground pathname
980 #      caller may call multiple times with different subdir paths
981 #       createing different playgrounds
982 #
983 #    ensure_a_playground SUBDIR_PATH_COMPONENTS
984 #      like fresh_playground except:
985 #      merely ensures the directory exists; does not delete an existing one
986 #
987 #  then can use
988 #
989 #    changedir playground
990 #    changedir $maindir
991 #
992 #    playtree_setup
993 #            # ^ call in some (perhaps trivial) subdir of playground
994 #
995 #    rmtree playground
996
997 # ----- maindir -----
998
999 our $local_git_cfg;
1000
1001 sub record_maindir () {
1002     if (!defined $maindir) {
1003         $maindir = must_getcwd();
1004         if (!stat "$maindir/.git") {
1005             fail f_ "cannot stat %s/.git: %s", $maindir, $!;
1006         }
1007         if (-d _) {
1008             # we fall back to this in case we have a pre-worktree
1009             # git, which may not know git rev-parse --git-common-dir
1010             $maindir_gitdir    = "$maindir/.git";
1011             $maindir_gitcommon = "$maindir/.git";
1012         } else {
1013             $maindir_gitdir    = cmdoutput qw(git rev-parse --git-dir);
1014             $maindir_gitcommon = cmdoutput qw(git rev-parse --git-common-dir);
1015         }
1016     }
1017     $local_git_cfg //= git_slurp_config_src 'local';
1018 }
1019
1020 # ----- playgrounds -----
1021
1022 sub ensure_a_playground_parent ($) {
1023     my ($spc) = @_;
1024     record_maindir();
1025     $spc = "$maindir_gitdir/$spc";
1026     my $parent = dirname $spc;
1027     mkdir $parent or $!==EEXIST or fail f_
1028         "failed to mkdir playground parent %s: %s", $parent, $!;
1029     return $spc;
1030 }    
1031
1032 sub ensure_a_playground ($) {
1033     my ($spc) = @_;
1034     $spc = ensure_a_playground_parent $spc;
1035     mkdir $spc or $!==EEXIST or fail f_
1036         "failed to mkdir a playground %s: %s", $spc, $!;
1037     return $spc;
1038 }    
1039
1040 sub fresh_playground ($) {
1041     my ($spc) = @_;
1042     $spc = ensure_a_playground_parent $spc;
1043     rmtree $spc;
1044     mkdir $spc or fail f_
1045         "failed to mkdir the playground %s: %s", $spc, $!;
1046     return $spc;
1047 }
1048
1049 # ----- playtrees -----
1050
1051 sub playtree_setup () {
1052     # for use in the playtree
1053     # $maindir must be set, eg by calling record_maindir or fresh_playground
1054     # this is confusing: we have
1055     #   .                   playtree, not a worktree, has .git/, our cwd
1056     #   $maindir            might be a worktree so
1057     #   $maindir_gitdir     contains our main working "dgit", HEAD, etc.
1058     #   $maindir_gitcommon  the shared stuff, including .objects
1059
1060     # we need to invoke git-playtree-setup via git because
1061     # there may be config options it needs which are only available
1062     # to us, sensibly, in @git
1063
1064     # And, we look for it in @INC too.  This is a bit perverse.
1065     # We do this because in the Debian packages we want to have
1066     # a copy of this script in each binary package, rather than
1067     # making yet another .deb or tangling the dependencies.
1068     # @INC is conveniently available.
1069     my $newpath = join ':', +(grep { !m/:/ } @INC),
1070                   '/usr/share/dgit', $ENV{PATH};
1071     runcmd qw(env), "PATH=$newpath", @git, qw(playtree-setup .);
1072
1073     ensuredir '.git/info';
1074     open GA, "> .git/info/attributes" or confess "$!";
1075     print GA "* $negate_harmful_gitattrs\n" or confess "$!";
1076     close GA or confess "$!";
1077 }
1078
1079 1;