From: Ian Jackson <ijackson@chiark.greenend.org.uk>
Date: Sat, 21 Jan 2012 00:56:15 +0000 (+0000)
Subject: wip tg-create
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ian/git?p=topbloke.git;a=commitdiff_plain;h=54d8cc266fbccdab45a1c6a6d36a57f94849e7df

wip tg-create
---

diff --git a/Topbloke.pm b/Topbloke.pm
new file mode 100644
index 0000000..2ff8913
--- /dev/null
+++ b/Topbloke.pm
@@ -0,0 +1,124 @@
+# -*- perl -*-
+
+use strict;
+use warnings;
+
+package Topbloke;
+
+BEGIN {
+    use Exporter   ();
+    our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
+
+    $VERSION     = 1.00;
+    @ISA         = qw(Exporter);
+    @EXPORT      = qw(parse_branch_spec current_tb_branch run_git_1line);
+    %EXPORT_TAGS = ( );
+    @EXPORT_OK   = qw();
+}
+
+
+sub run_git_1line {
+    my $xopts;
+    $xopts = ref $_[0] ? shift @_ : { };
+    open GIT, "-|", 'git', @_ or die $!;
+    my $l = <GIT>;
+    $?=0;
+    if ($xopts->{ExitStatus}) {
+	if (!close GIT) { 
+	    return ($?, undef);
+	} else {
+	    chomp $l or die "@_ ?";
+	    return (0, $l);
+	}
+    }
+    close GIT or die "git @_ failed ($?)\n";
+    chomp $l or die "@_ ?";
+    return $l;
+}
+
+sub current_tb_branch () {
+    my ($estatus,$ref) = 
+	run_git_1line({ ExitStatus=>1 }, qw(symbolic-ref HEAD));
+    if ($estatus == 256) {
+	return {
+	    Kind => 'detached'
+	};
+    }
+    die "$estatus ?" if $estatus;
+    if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
+	return {
+	    Kind => $1,
+	    Email => $2,
+	    Domain => $3,
+	    Date => $4,
+	    Nick => $', #',
+	    Ref => $ref,
+	    DepSpec => "$2\@$3/$4/$'",
+	};
+    } elsif ($ref =~ m#^refs/heads/#) {
+	return {
+	    Kind => 'foreign',
+	    Ref => $ref,
+	    DepSpec => "/$ref",
+	};
+    } else {
+	return {
+	    Kind => 'weird',
+	    Ref => $ref,
+	};
+    }
+}
+
+sub parse_branch_spec ($) {
+    my ($orig) = @_;
+    local $_ = $orig;
+    my $spec = { }; # Email Domain DatePrefix DateNear Nick
+    my $set = sub {
+	my ($key,$val,$whats) = @_;
+	die "multiple $whats in branch spec\n" if exists $spec->{$key};
+	$spec->{$key} = $val;
+    };
+    my $rel_levels;
+    for (;;) {
+	if (s#([^/\@]*)\@([^/\@]*)/##) {
+	    $set->('Email', $1, "email local parts") if length $1;
+	    $set->('Domain', $2, "email domains") if length $1;
+	} elsif (s#([^/]*\~[^/]*)/##) {
+	    my $dspec = $1;
+	    $dspec =~ y/~/ /;
+	    open DATE, "-|", 'date','+%s','-d',$dspec or die $!;
+	    my $l = <DATE>;
+	    close DATE or die "date parsing failed\n";
+	    chomp $l or die;
+	    $set->('DateNear', $l, 'nearby dates');
+	} elsif (s#^([0-9][^/]*)/##) {
+	    my $dspec = $1;
+	    $dspec =~ 
+      m/^\d{4}(?:-\d\d(?:-\d\d(?:T(?:\d\d(?:\d\d(?:\d\d(?:Z)?)?)?)?)?)?)?$/
+		or die "bad date prefix \`$dspec'\n";
+	    $set->('DatePrefix', $dspec, 'date prefixes');
+	} elsif (s#^\./##) {
+	    $rel_levels ||= 1;
+	} elsif (s#^\.\./##) {
+	    $rel_levels ||= 1;
+	    $rel_levels++;
+	} else {
+	    last;
+	}
+    }
+    if (defined $rel_levels) {
+	my $branch = current_tb_branch();
+	if (!defined $branch->{Nick}) {
+	    die "relative branch spec \`$orig',".
+		" but current branch not a topbloke branch\n";
+	}
+	my ($ceaddr,$cdate,@l) = split /\//, $branch->{Nick};
+	@l >= $rel_levels or
+	    die "relative branch spec \`$orig' has too many ../s\n";
+	$_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
+    }
+    $spec->{Nick} = $_;
+    return $spec;
+}
+
+1;
diff --git a/tg-create.pl b/tg-create.pl
new file mode 100755
index 0000000..c205110
--- /dev/null
+++ b/tg-create.pl
@@ -0,0 +1,46 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use Getopt::Long;
+use Topbloke;
+
+Getopt::Long::Configure(qw(bundling));
+
+die "bad usage\n" unless @ARGV==1;
+
+our $spec = parse_branch_spec($ARGV[0]);
+our $current = current_tb_branch();
+
+die "cannot make branch starting at base of another;".
+    " check out a real branch\n" if $current->{Kind} eq 'base';
+
+die "strange branch ref, making new branch with this as dep is unwise\n"
+    if $current->{Kind} eq 'weird';
+
+sub fillin ($$$) {
+    my ($key, $newval, $what) = @_;
+    return if defined $spec->{$key};
+    $spec->{$key} = $newval;
+}
+
+if (!defined $spec->{Email} || !defined $spec->{Domain}) {
+    my $eaddr = run_git_1line(qw(config user.email));
+    $eaddr =~ m/^(.*)\@/ or die "$eaddr ?";
+    fillin('Email',$1,'email domain');
+    fillin('Domain',$','email domain'); #');
+}
+
+if (!defined $spec->{Date}) {
+    $spec->{Date} = `LC_TIME=C date -u +%Y-%m-%dT%H%M%SZ`;
+    chomp $spec->{Date} or die $!;
+}
+
+length($spec->{Date})==18 or die "partial date specified, not supported\n";
+
+my $newbranch = "$spec->{Email}\@$spec->{Domain}/$spec->{Date}/$spec->{Nick}";
+
+$newbranch = run_git_1line(qw(check-ref-format --print), $newbranch);
+
+printf "creating %s\n", $newbranch;