summaryrefslogtreecommitdiff
path: root/Debian/Dgit.pm
blob: 2b9479db58d9b4e5f07c0301033657d449475c75 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
# -*- perl -*-

package Debian::Dgit;

use strict;
use warnings;

use POSIX;
use IO::Handle;

BEGIN {
    use Exporter   ();
    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);

    $VERSION     = 1.00;
    @ISA         = qw(Exporter);
    @EXPORT      = qw(debiantag server_branch server_ref
                      stat_exists git_for_each_ref
                      $package_re $component_re $branchprefix
                      initdebug enabledebug printdebug debugcmd
                      $debugprefix $debug
                      shellquote printcmd);
    %EXPORT_TAGS = ( policyflags => [qw(NOFFCHECK FRESHREPO)] );
    @EXPORT_OK   = @{ $EXPORT_TAGS{policyflags} };
}

our @EXPORT_OK;

our $package_re = '[0-9a-z][-+.0-9a-z]*';
our $component_re = '[0-9a-zA-Z][-+.0-9a-zA-Z]*';
our $branchprefix = 'dgit';

# policy hook exit status bits
# see dgit-repos-server head comment for documentation
# 1 is reserved in case something fails with `exit 1'
sub NOFFCHECK () { return 0x2; }
sub FRESHREPO () { return 0x4; }
# 0x80 is reserved

sub debiantag ($) { 
    my ($v) = @_;
    $v =~ y/~:/_%/;
    return "debian/$v";
}

sub server_branch ($) { return "$branchprefix/$_[0]"; }
sub server_ref ($) { return "refs/".server_branch($_[0]); }

sub stat_exists ($) {
    my ($f) = @_;
    return 1 if stat $f;
    return 0 if $!==&ENOENT;
    die "stat $f: $!";
}

sub git_for_each_ref ($$) {
    my ($pattern,$func) = @_;
    # calls $func->($objid,$objtype,$fullrefname,$reftail);
    # $reftail is RHS of ref after refs/\w+/
    # breaks if $pattern matches any ref `refs/blah' where blah has no `/'
    my $fh = new IO::File "-|", qw(git for-each-ref), $pattern or die $!;
    while (<$fh>) {
	m#^(\w+)\s+(\w+)\s+(refs/\w+/(\S+))\s# or die "$_ ?";
	$func->($1,$2,$3,$4);
    }
    $!=0; $?=0; close $fh or die "$pattern $? $!";
}

sub git_for_each_tag_referring ($$) {
    my ($objreferring, $func) = @_;
    # calls $func->($objid,$fullrefname,$tagname);
    git_for_each_ref('refs/tags', sub {
	my ($objid,$objtype,$fullrefname,$tagname) = @_;
	next unless $objtype eq 'tag';
	next if defined $objreferring and $objid ne $objreferring;
	$func->($objid,$fullrefname,$tagname);
    });
}

our $debugprefix;
our $debug = 0;

sub initdebug ($) { 
    ($debugprefix) = @_;
    open ::DEBUG, ">/dev/null" or die $!;
}

sub enabledebug () {
    open ::DEBUG, ">&STDERR" or die $!;
    ::DEBUG->autoflush(1);
    $debug ||= 1;
}
    
sub printdebug {
    print ::DEBUG $debugprefix, @_ or die $!;
}

sub shellquote {
    my @out;
    local $_;
    foreach my $a (@_) {
	$_ = $a;
	if (m{[^-=_./0-9a-z]}i) {
	    s{['\\]}{'\\$&'}g;
	    push @out, "'$_'";
	} else {
	    push @out, $_;
	}
    }
    return join ' ', @out;
}

sub printcmd {
    my $fh = shift @_;
    my $intro = shift @_;
    print $fh $intro," " or die $!;
    print $fh shellquote @_ or die $!;
    print $fh "\n" or die $!;
}

sub debugcmd {
    my $extraprefix = shift @_;
    printcmd(\*::DEBUG,$debugprefix.$extraprefix,@_) if $debug>0;
}

1;