summaryrefslogtreecommitdiff
path: root/Debian/Dgit.pm
blob: f33b173ca9bdac1424757b1d7c3adb022bda57da (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
127
128
129
130
131
132
133
# -*- 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 enabledebuglevel
                      printdebug debugcmd
                      $debugprefix *debuglevel *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 $debuglevel = 0;

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

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

sub shellquote {
    my @out;
    local $_;
    foreach my $a (@_) {
	$_ = $a;
	if (!length || 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 $debuglevel>0;
}

1;