X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~ianmdlvl/git?p=dgit.git;a=blobdiff_plain;f=Debian%2FDgit.pm;h=34e40a3b0ab684327533e868de48e95f7d4d241e;hp=c0ee27fc4d3ca22c2e8735069ee97e440f8fb80e;hb=cb5a33d8508c3b83a2bb776e567d8cd2d1a6e50d;hpb=0effa0aab06b3a56382729f79fbea79ae36531b8 diff --git a/Debian/Dgit.pm b/Debian/Dgit.pm index c0ee27fc..34e40a3b 100644 --- a/Debian/Dgit.pm +++ b/Debian/Dgit.pm @@ -31,6 +31,7 @@ use Data::Dumper; use IPC::Open2; use File::Path; use File::Basename; +use Dpkg::Control::Hash; BEGIN { use Exporter (); @@ -41,6 +42,9 @@ BEGIN { @EXPORT = qw(setup_sigwarn forkcheck_setup forkcheck_mainprocess dep14_version_mangle debiantags debiantag_old debiantag_new + debiantag_maintview + upstreamversion + stripepoch source_file_leafname is_orig_file_of_p_v server_branch server_ref stat_exists link_ltarget hashfile @@ -52,19 +56,24 @@ BEGIN { git_get_ref git_get_symref git_for_each_ref git_for_each_tag_referring is_fast_fwd git_check_unmodified + git_reflog_action_msg git_update_ref_cmd $package_re $component_re $deliberately_re $distro_re $versiontag_re $series_filename_re + $orig_f_comp_re $orig_f_sig_re $orig_f_tail_re $extra_orig_namepart_re $git_null_obj $branchprefix $ffq_refprefix $gdrlast_refprefix initdebug enabledebug enabledebuglevel printdebug debugcmd + $printdebug_when_debuglevel $debugcmd_when_debuglevel $debugprefix *debuglevel *DEBUG shellquote printcmd messagequote $negate_harmful_gitattrs changedir git_slurp_config_src gdr_ffq_prev_branchinfo + parsecontrolfh parsecontrol parsechangelog + getfield parsechangelog_loop playtree_setup); # implicitly uses $main::us %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO NOCOMMITCHECK)], @@ -86,9 +95,14 @@ our $versiontag_re = qr{[-+.\%_0-9a-zA-Z/]+}; our $branchprefix = 'dgit'; our $series_filename_re = qr{(?:^|\.)series(?!\n)$}s; our $extra_orig_namepart_re = qr{[-0-9a-z]+}; +our $orig_f_comp_re = qr{orig(?:-$extra_orig_namepart_re)?}; +our $orig_f_sig_re = '\\.(?:asc|gpg|pgp)'; +our $orig_f_tail_re = "$orig_f_comp_re\\.tar(?:\\.\\w+)?(?:$orig_f_sig_re)?"; our $git_null_obj = '0' x 40; our $ffq_refprefix = 'ffq-prev'; our $gdrlast_refprefix = 'debrebase-last'; +our $printdebug_when_debuglevel = 1; +our $debugcmd_when_debuglevel = 1; # policy hook exit status bits # see dgit-repos-server head comment for documentation @@ -145,7 +159,21 @@ sub enabledebuglevel ($) { } sub printdebug { - print DEBUG $debugprefix, @_ or die $! if $debuglevel>0; + # Prints a prefix, and @_, to DEBUG. @_ should normally contain + # a trailing \n. + + # With no (or only empty) arguments just prints the prefix and + # leaves the caller to do more with DEBUG. The caller should make + # sure then to call printdebug with something ending in "\n" to + # get the prefix right in subsequent calls. + + return unless $debuglevel >= $printdebug_when_debuglevel; + our $printdebug_noprefix; + print DEBUG $debugprefix unless $printdebug_noprefix; + pop @_ while @_ and !length $_[-1]; + return unless @_; + print DEBUG @_ or die $!; + $printdebug_noprefix = $_[-1] !~ m{\n$}; } sub messagequote ($) { @@ -184,7 +212,8 @@ sub printcmd { sub debugcmd { my $extraprefix = shift @_; - printcmd(\*DEBUG,$debugprefix.$extraprefix,@_) if $debuglevel>0; + printcmd(\*DEBUG,$debugprefix.$extraprefix,@_) + if $debuglevel >= $debugcmd_when_debuglevel; } sub dep14_version_mangle ($) { @@ -205,11 +234,40 @@ sub debiantag_new ($$) { return "archive/$distro/".dep14_version_mangle $v; } +sub debiantag_maintview ($$) { + my ($v,$distro) = @_; + return "$distro/".dep14_version_mangle $v; +} + sub debiantags ($$) { my ($version,$distro) = @_; map { $_->($version, $distro) } (\&debiantag_new, \&debiantag_old); } +sub stripepoch ($) { + my ($vsn) = @_; + $vsn =~ s/^\d+\://; + return $vsn; +} + +sub upstreamversion ($) { + my ($vsn) = @_; + $vsn =~ s/-[^-]+$//; + return $vsn; +} + +sub source_file_leafname ($$$) { + my ($package,$vsn,$sfx) = @_; + return "${package}_".(stripepoch $vsn).$sfx +} + +sub is_orig_file_of_p_v ($$$) { + my ($f, $package, $upstreamvsn) = @_; + my $base = source_file_leafname $package, $upstreamvsn, ''; + return 0 unless $f =~ m/^\Q$base\E\.$orig_f_tail_re$/; + return 1; +} + sub server_branch ($) { return "$branchprefix/$_[0]"; } sub server_ref ($) { return "refs/".server_branch($_[0]); } @@ -225,11 +283,11 @@ sub _us () { } sub failmsg { - my $s = "@_\n"; + my $s = "error: @_\n"; $s =~ s/\n\n$/\n/; my $prefix = _us().": "; $s =~ s/^/$prefix/gm; - return $s; + return "\n".$s; } sub fail { @@ -322,6 +380,7 @@ sub shell_cmd { sub cmdoutput_errok { confess Dumper(\@_)." ?" if grep { !defined } @_; + local $printdebug_when_debuglevel = $debugcmd_when_debuglevel; debugcmd "|",@_; open P, "-|", @_ or die "$_[0] $!"; my $d; @@ -374,6 +433,7 @@ sub git_cat_file ($;$) { # in scalar context, just the data # if $etype defined, dies unless type is $etype or in @$etype our ($gcf_pid, $gcf_i, $gcf_o); + local $printdebug_when_debuglevel = $debugcmd_when_debuglevel; my $chk = sub { my ($gtype, $data) = @_; if ($etype) { @@ -492,6 +552,21 @@ sub is_fast_fwd ($$) { } } +sub git_reflog_action_msg ($) { + my ($msg) = @_; + my $rla = $ENV{GIT_REFLOG_ACTION}; + $msg = "$rla: $msg" if length $rla; + return $msg; +} + +sub git_update_ref_cmd { + # returns qw(git update-ref), qw(-m), @_ + # except that message may be modified to honour GIT_REFLOG_ACTION + my $msg = shift @_; + $msg = git_reflog_action_msg $msg; + return qw(git update-ref -m), $msg, @_; +} + sub changedir ($) { my ($newdir) = @_; printdebug "CD $newdir\n"; @@ -538,6 +613,80 @@ sub gdr_ffq_prev_branchinfo ($) { return ('branch', undef, $symref, $ffq_prev, $gdrlast); } +sub parsecontrolfh ($$;$) { + my ($fh, $desc, $allowsigned) = @_; + our $dpkgcontrolhash_noissigned; + my $c; + for (;;) { + my %opts = ('name' => $desc); + $opts{allow_pgp}= $allowsigned || !$dpkgcontrolhash_noissigned; + $c = Dpkg::Control::Hash->new(%opts); + $c->parse($fh,$desc) or die "parsing of $desc failed"; + last if $allowsigned; + last if $dpkgcontrolhash_noissigned; + my $issigned= $c->get_option('is_pgp_signed'); + if (!defined $issigned) { + $dpkgcontrolhash_noissigned= 1; + seek $fh, 0,0 or die "seek $desc: $!"; + } elsif ($issigned) { + fail "control file $desc is (already) PGP-signed. ". + " Note that dgit push needs to modify the .dsc and then". + " do the signature itself"; + } else { + last; + } + } + return $c; +} + +sub parsecontrol { + my ($file, $desc, $allowsigned) = @_; + my $fh = new IO::Handle; + open $fh, '<', $file or die "$file: $!"; + my $c = parsecontrolfh($fh,$desc,$allowsigned); + $fh->error and die $!; + 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 die $!; + $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 "missing field $field in ".$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 die $!; + for (;;) { + my $stanzatext = do { local $/=""; ; }; + printdebug "clogp stanza ".Dumper($stanzatext) if $debuglevel>1; + last if !defined $stanzatext; + + my $desc = "$descbase, entry no.$."; + open my $stanzafh, "<", \$stanzatext or die; + my $thisstanza = parsecontrolfh $stanzafh, $desc, 1; + + $fn->($thisstanza, $desc); + } + die $! if CLOGS->error; + close CLOGS or $?==SIGPIPE or failedcmd @$clogcmd; +} + # ========== playground handling ========== # terminology: