wip tg-create

diff --git a/Topbloke.pm b/Topbloke.pm
new file mode 100644 (file)
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 (executable)
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;