+ return $c;
+}
+
+sub parsecontrol {
+ my ($file, $desc, $allowsigned) = @_;
+ my $fh = new IO::Handle;
+ open $fh, '<', $file or fail f_ "open %s (%s): %s", $file, $desc, $!;
+ my $c = parsecontrolfh($fh,$desc,$allowsigned);
+ $fh->error and confess "$!";
+ close $fh;
+ return $c;
+}
+
+sub parsechangelog {
+ my $c = Dpkg::Control::Hash->new(name => 'parsed changelog');
+ my $p = new IO::Handle;
+ my @cmd = (qw(dpkg-parsechangelog), @_);
+ open $p, '-|', @cmd or confess "$!";
+ $c->parse($p);
+ $?=0; $!=0; close $p or failedcmd @cmd;
+ return $c;
+}
+
+sub getfield ($$) {
+ my ($dctrl,$field) = @_;
+ my $v = $dctrl->{$field};
+ return $v if defined $v;
+ fail f_ "missing field %s in %s", $field, $dctrl->get_option('name');
+}
+
+sub parsechangelog_loop ($$$) {
+ my ($clogcmd, $descbase, $fn) = @_;
+ # @$clogcmd is qw(dpkg-parsechangelog ...some...options...)
+ # calls $fn->($thisstanza, $desc);
+ debugcmd "|",@$clogcmd;
+ open CLOGS, "-|", @$clogcmd or confess "$!";
+ for (;;) {
+ my $stanzatext = do { local $/=""; <CLOGS>; };
+ printdebug "clogp stanza ".Dumper($stanzatext) if $debuglevel>1;
+ last if !defined $stanzatext;
+
+ my $desc = "$descbase, entry no.$.";
+ open my $stanzafh, "<", \$stanzatext or confess;
+ my $thisstanza = parsecontrolfh $stanzafh, $desc, 1;
+
+ $fn->($thisstanza, $desc);
+ }
+ confess "$!" if CLOGS->error;
+ close CLOGS or $?==SIGPIPE or failedcmd @$clogcmd;
+}
+
+sub make_commit ($$) {
+ my ($parents, $message_paras) = @_;
+ my $tree = cmdoutput qw(git write-tree);
+ my @cmd = (qw(git commit-tree), $tree);
+ push @cmd, qw(-p), $_ foreach @$parents;
+ push @cmd, qw(-m), $_ foreach @$message_paras;
+ return cmdoutput @cmd;
+}
+
+sub hash_commit ($) {
+ my ($file) = @_;
+ return cmdoutput qw(git hash-object -w -t commit), $file;
+}
+
+sub hash_commit_text ($) {
+ my ($text) = @_;
+ my ($out, $in);
+ my @cmd = (qw(git hash-object -w -t commit --stdin));
+ debugcmd "|",@cmd;
+ print Dumper($text) if $debuglevel > 1;
+ my $child = open2($out, $in, @cmd) or confess "$!";
+ my $h;
+ eval {
+ print $in $text or confess "$!";
+ close $in or confess "$!";
+ $h = <$out>;
+ $h =~ m/^\w+$/ or confess;
+ $h = $&;
+ printdebug "=> $h\n";
+ };
+ close $out;
+ waitpid $child, 0 == $child or confess "$child $!";
+ $? and failedcmd @cmd;
+ return $h;
+}
+
+sub reflog_cache_insert ($$$) {
+ my ($ref, $cachekey, $value) = @_;
+ # you must call this in $maindir
+ # you must have called record_maindir
+
+ # When we no longer need to support squeeze, use --create-reflog
+ # instead of this:
+ my $parent = $ref; $parent =~ s{/[^/]+$}{};
+ ensurepath "$maindir_gitcommon/logs", "$parent";
+ my $makelogfh = new IO::File "$maindir_gitcommon/logs/$ref", '>>'
+ or confess "$!";
+
+ my $oldcache = git_get_ref $ref;
+
+ if ($oldcache eq $value) {
+ my $tree = cmdoutput qw(git rev-parse), "$value:";
+ # git update-ref doesn't always update, in this case. *sigh*
+ my $authline = (ucfirst _us()).
+ ' <'._us().'@example.com> 1000000000 +0000';
+ my $dummy = hash_commit_text <<ENDU.(__ <<END);
+tree $tree
+parent $value
+author $authline
+committer $authline
+
+ENDU
+Dummy commit - do not use
+END
+ runcmd qw(git update-ref -m), _us()." - dummy", $ref, $dummy;
+ }
+ runcmd qw(git update-ref -m), $cachekey, $ref, $value;
+}
+
+sub reflog_cache_lookup ($$) {
+ my ($ref, $cachekey) = @_;
+ # you may call this in $maindir or in a playtree
+ # you must have called record_maindir
+ my @cmd = (qw(git log -g), '--pretty=format:%H %gs', $ref);
+ debugcmd "|(probably)",@cmd;
+ my $child = open GC, "-|"; defined $child or confess "$!";
+ if (!$child) {
+ chdir $maindir or confess "$!";
+ if (!stat "$maindir_gitcommon/logs/$ref") {
+ $! == ENOENT or confess "$!";
+ printdebug ">(no reflog)\n";
+ finish 0;
+ }
+ exec @cmd; die f_ "exec %s: %s\n", $cmd[0], $!;
+ }
+ while (<GC>) {
+ chomp;
+ printdebug ">| ", $_, "\n" if $debuglevel > 1;
+ next unless m/^(\w+) (\S.*\S)$/ && $2 eq $cachekey;
+ close GC;
+ return $1;
+ }
+ confess "$!" if GC->error;
+ failedcmd unless close GC;
+ return undef;
+}
+
+# ========== playground handling ==========
+
+# terminology:
+#
+# $maindir user's git working tree
+# playground area in .git/ where we can make files, unpack, etc. etc.
+# playtree git working tree sharing object store with the user's
+# inside playground, or identical to it
+#
+# other globals
+#
+# $local_git_cfg hash of arrays of values: git config from $maindir
+#
+# expected calling pattern
+#
+# firstly
+#
+# [record_maindir]
+# must be run in directory containing .git
+# assigns to $maindir if not already set
+# also calls git_slurp_config_src to record git config
+# in $local_git_cfg, unless it's already set
+#
+# fresh_playground SUBDIR_PATH_COMPONENTS
+# e.g fresh_playground 'dgit/unpack' ('.git/' is implied)
+# default SUBDIR_PATH_COMPONENTS is playground_subdir
+# calls record_maindir
+# sets up a new playground (destroying any old one)
+# returns playground pathname
+# caller may call multiple times with different subdir paths
+# createing different playgrounds
+#
+# ensure_a_playground SUBDIR_PATH_COMPONENTS
+# like fresh_playground except:
+# merely ensures the directory exists; does not delete an existing one
+#
+# then can use
+#
+# changedir playground
+# changedir $maindir
+#
+# playtree_setup
+# # ^ call in some (perhaps trivial) subdir of playground
+#
+# rmtree playground
+
+# ----- maindir -----
+
+our $local_git_cfg;
+
+sub record_maindir () {
+ if (!defined $maindir) {
+ $maindir = must_getcwd();
+ if (!stat "$maindir/.git") {
+ fail f_ "cannot stat %s/.git: %s", $maindir, $!;
+ }
+ if (-d _) {
+ # we fall back to this in case we have a pre-worktree
+ # git, which may not know git rev-parse --git-common-dir
+ $maindir_gitdir = "$maindir/.git";
+ $maindir_gitcommon = "$maindir/.git";
+ } else {
+ $maindir_gitdir = cmdoutput qw(git rev-parse --git-dir);
+ $maindir_gitcommon = cmdoutput qw(git rev-parse --git-common-dir);
+ }
+ }
+ $local_git_cfg //= git_slurp_config_src 'local';
+}
+
+# ----- playgrounds -----
+
+sub ensure_a_playground_parent ($) {
+ my ($spc) = @_;
+ record_maindir();
+ $spc = "$maindir_gitdir/$spc";
+ my $parent = dirname $spc;
+ mkdir $parent or $!==EEXIST or fail f_
+ "failed to mkdir playground parent %s: %s", $parent, $!;
+ return $spc;
+}
+
+sub ensure_a_playground ($) {
+ my ($spc) = @_;
+ $spc = ensure_a_playground_parent $spc;
+ mkdir $spc or $!==EEXIST or fail f_
+ "failed to mkdir a playground %s: %s", $spc, $!;
+ return $spc;
+}
+
+sub fresh_playground ($) {
+ my ($spc) = @_;
+ $spc = ensure_a_playground_parent $spc;
+ rmtree $spc;
+ mkdir $spc or fail f_
+ "failed to mkdir the playground %s: %s", $spc, $!;
+ return $spc;
+}
+
+# ----- playtrees -----
+
+sub playtree_setup () {
+ # for use in the playtree
+ # $maindir must be set, eg by calling record_maindir or fresh_playground
+ # this is confusing: we have
+ # . playtree, not a worktree, has .git/, our cwd
+ # $maindir might be a worktree so
+ # $maindir_gitdir contains our main working "dgit", HEAD, etc.
+ # $maindir_gitcommon the shared stuff, including .objects
+
+ # we need to invoke git-playtree-setup via git because
+ # there may be config options it needs which are only available
+ # to us, sensibly, in @git
+
+ # And, we look for it in @INC too. This is a bit perverse.
+ # We do this because in the Debian packages we want to have
+ # a copy of this script in each binary package, rather than
+ # making yet another .deb or tangling the dependencies.
+ # @INC is conveniently available.
+ my $newpath = join ':', +(grep { !m/:/ } @INC),
+ '/usr/share/dgit', $ENV{PATH};
+ runcmd qw(env), "PATH=$newpath", @git, qw(playtree-setup .);
+