wip

diff --git a/.gitignore b/.gitignore
new file mode 100644 (file)
index 0000000..b25c15b
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+*~

diff --git a/NOTES b/NOTES
index cd29632811784affb47221479cce5a377d92025d..c13ead745e4cdac024c7cecb53658d64b7b4c141 100644 (file)
--- a/NOTES
+++ b/NOTES
@@ -20,7 +20,11 @@ dgit push
   signs tag
   debsign
   push to alioth (perhaps with merge -s ours)
+    to "uploading" tag or branch
+       <suite>
+       uploading/<suite>
   dput
+  push to alioth to main tag or branch
 
 where on alioth upstream
 

diff --git a/TODO b/TODO
new file mode 100644 (file)
index 0000000..8c617a2
--- /dev/null
+++ b/TODO
@@ -0,0 +1,9 @@
+Do not screenscrape p.d.o use rmadison ?
+
+Make it possible to do dgit clone / fetch anonymously
+
+Archive agility.  Archive needs to specify (a) way to get versions
+and paths in archive for dscs (b) unpriv pull location (c) priv
+push location
+
+Support mirrors for source download

diff --git a/dgit b/dgit
new file mode 100755 (executable)
index 0000000..7a9c910
--- /dev/null
+++ b/dgit
@@ -0,0 +1,122 @@
+#!/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 = 'userv';
+
+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"; }
+
+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";
+    mu $dscf = $dscp->{'fields'};
+    die "unsupported format $dscf->{Format}, sorry\n"
+       unless $dscf->{Format} eq '1.0';
+    return $dsc;
+}
+
+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) {
+       
+
+       open P, "-|", qw(git rev-parse --), $dsc_hash;
+       
+}
+
+sub clone () {
+    $dsc = get_archive_dsc();
+    $dsc_hash = $dsc->{Vcs-git-master};
+    if (defined $dsh_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();
+    
+    with_tmpdir($td,{
+       
+    });
+
+print Dumper(get_archive_dsc());