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
|
#!/usr/bin/perl -w
use strict;
use IO::Handle;
use Data::Dumper;
use LWP::UserAgent;
use Dpkg::Control::Hash;
open DEBUG, ">&STDERR" or die $!;
our $pdo = 'http://packages.debian.org/';
#our $mirror = 'http://mirror.relativity.greenend.org.uk/mirror/debian-ftp/';
our $suite = 'sid';
our $package = '2vcard';
our $aliothname = 'iwj@git.debian.org';
our $aliothpath = '/git/dgit-test';
our $alioth_git = 'git+ssh://$aliothname/$aliothpath';
our $alioth_sshtestbodge = [$aliothname,$aliothpath];
sub mainbranch () { return "$suite"; }
sub uploadingbranch () { return "uploading/$suite"; }
our $ua;
sub url_get {
if (!$ua) {
$ua = LWP::UserAgent->new();
$ua->env_proxy;
}
print DEBUG "fetching @_...\n";
my $r = $ua->get(@_) or die $!;
die "$_[0]: ".$r->status_line."; failed.\n" unless $r->is_success;
return $r->decoded_content();
}
sub get_archive_dsc () {
my $pdourl = "$pdo/source/$suite/$package";
my $pdodata = url_get($pdourl);
# FFS. The Debian archive has no sane way to find what
# version is currently the tip in any branch (aka, what
# is the current version in any suite).
$pdodata =~ m{
Download\ \Q$package\E .*
\<a\ href=\"([^"&]+([^"/]+\.dsc))\"\>\2\</a\>
}msx
or die "screenscraping of $pdourl failed :-(\n";
my $dscurl = $1;
print DEBUG Dumper($pdodata, $&, $dscurl);
my $dscdata = url_get($dscurl);
my $dscfh = new IO::File \$dscdata, '<' or die $!;
print DEBUG Dumper($dscdata, $dscfh);
my $dscp = Dpkg::Control::Hash->new(allow_pgp=>1);
$dscp->parse($dscfh, 'dsc') or die "parsing of $dscurl failed\n";
# my $dscf = $dscp->{'fields'};
my $dscf=$dscp;
print DEBUG Dumper($dscp,$dscf);
my $fmt = $dscf->{Format};
die "unsupported format $fmt, sorry\n" unless $fmt eq '1.0';
return $dscf;
}
sub check_for_git () {
# returns 0 or 1
open P, "ssh $alioth_sshtestbodge->[0] '".
"set -e; cd /git/dgit-test;".
"if test -d $package.git; then echo 1; else echo 0; fi".
"' |"
or die $!;
$!=0; $?=0;
my $r = <P>; close P;
die "$r $! $?" unless $r =~ m/^[01]$/;
return !!$r;
}
sub runcmd {
$!=0; $?=0;
die "$! $?" if system @_;
}
our ($dsc,$dsc_hash);
#sub combine () {
# if (!defined $dsc_hash) {
# runcmd qw(mkdir -p .git/dgit/unpack);
# chdir '.git/dgit/unpack' or die $!;
# with_tmpdir($td,{
# });
# }
# open P, "-|", qw(git rev-parse --), $dsc_hash;
#}
sub clone () {
$dsc = get_archive_dsc();
$dsc_hash = $dsc->{'Vcs-git-master'};
if (defined $dsc_hash) {
$dsc_hash =~ m/\w+/ or die "$dsc_hash $?";
$dsc_hash = $&;
}
my $dstdir = "$package";
if (check_for_git()) {
runcmd qw(git clone --origin dgit -b), $suite, '--',
$alioth_git, $dstdir;
chdir "$dstdir" or die "$dstdir $!";
combine();
} else {
mkdir $dstdir or die "$dstdir $!";
chdir "$dstdir" or die "$dstdir $!";
runcmd qw(git init);
open H, "> .git/refs/HEAD" or die $!;
print H "ref: refs/heads/$suite\n" or die $!;
close H or die $!;
runcmd qw(git remote add dgit), $alioth_git;
runcmd "git config branch.$suite.remote dgit";
runcmd "git config branch.$suite.merge refs/heads/$suite";
combine();
}
}
sub fetch () {
my ($archive_or_mirror, $suite, $package) = @_;
my $dsc = get_archive_dsc();
}
print Dumper(get_archive_dsc());
|
