Topbloke.pm

   1 # -*- perl -*-
   2
   3 use strict;
   4 use warnings;
   5
   6 package Topbloke;
   7
   8 BEGIN {
   9     use Exporter   ();
  10     our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
  11
  12     $VERSION     = 1.00;
  13     @ISA         = qw(Exporter);
  14     @EXPORT      = qw(parse_branch_spec current_tb_branch run_git_1line);
  15     %EXPORT_TAGS = ( );
  16     @EXPORT_OK   = qw();
  17 }
  18
  19
  20 sub run_git_1line {
  21     my $xopts;
  22     $xopts = ref $_[0] ? shift @_ : { };
  23     open GIT, "-|", 'git', @_ or die $!;
  24     my $l = <GIT>;
  25     $?=0;
  26     if ($xopts->{ExitStatus}) {
  27         if (!close GIT) {
  28             return ($?, undef);
  29         } else {
  30             chomp $l or die "@_ ?";
  31             return (0, $l);
  32         }
  33     }
  34     close GIT or die "git @_ failed ($?)\n";
  35     chomp $l or die "@_ ?";
  36     return $l;
  37 }
  38
  39 sub current_tb_branch () {
  40     my ($estatus,$ref) =
  41         run_git_1line({ ExitStatus=>1 }, qw(symbolic-ref HEAD));
  42     if ($estatus == 256) {
  43         return {
  44             Kind => 'detached'
  45         };
  46     }
  47     die "$estatus ?" if $estatus;
  48     if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
  49         return {
  50             Kind => $1,
  51             Email => $2,
  52             Domain => $3,
  53             Date => $4,
  54             Nick => $', #',
  55             Ref => $ref,
  56             DepSpec => "$2\@$3/$4/$'",
  57         };
  58     } elsif ($ref =~ m#^refs/heads/#) {
  59         return {
  60             Kind => 'foreign',
  61             Ref => $ref,
  62             DepSpec => "/$ref",
  63         };
  64     } else {
  65         return {
  66             Kind => 'weird',
  67             Ref => $ref,
  68         };
  69     }
  70 }
  71
  72 sub parse_branch_spec ($) {
  73     my ($orig) = @_;
  74     local $_ = $orig;
  75     my $spec = { }; # Email Domain DatePrefix DateNear Nick
  76     my $set = sub {
  77         my ($key,$val,$whats) = @_;
  78         die "multiple $whats in branch spec\n" if exists $spec->{$key};
  79         $spec->{$key} = $val;
  80     };
  81     my $rel_levels;
  82     for (;;) {
  83         if (s#([^/\@]*)\@([^/\@]*)/##) {
  84             $set->('Email', $1, "email local parts") if length $1;
  85             $set->('Domain', $2, "email domains") if length $1;
  86         } elsif (s#([^/]*\~[^/]*)/##) {
  87             my $dspec = $1;
  88             $dspec =~ y/~/ /;
  89             open DATE, "-|", 'date','+%s','-d',$dspec or die $!;
  90             my $l = <DATE>;
  91             close DATE or die "date parsing failed\n";
  92             chomp $l or die;
  93             $set->('DateNear', $l, 'nearby dates');
  94         } elsif (s#^([0-9][^/]*)/##) {
  95             my $dspec = $1;
  96             $dspec =~
  97       m/^\d{4}(?:-\d\d(?:-\d\d(?:T(?:\d\d(?:\d\d(?:\d\d(?:Z)?)?)?)?)?)?)?$/
  98                 or die "bad date prefix \`$dspec'\n";
  99             $set->('DatePrefix', $dspec, 'date prefixes');
 100         } elsif (s#^\./##) {
 101             $rel_levels ||= 1;
 102         } elsif (s#^\.\./##) {
 103             $rel_levels ||= 1;
 104             $rel_levels++;
 105         } else {
 106             last;
 107         }
 108     }
 109     if (defined $rel_levels) {
 110         my $branch = current_tb_branch();
 111         if (!defined $branch->{Nick}) {
 112             die "relative branch spec \`$orig',".
 113                 " but current branch not a topbloke branch\n";
 114         }
 115         my ($ceaddr,$cdate,@l) = split /\//, $branch->{Nick};
 116         @l >= $rel_levels or
 117             die "relative branch spec \`$orig' has too many ../s\n";
 118         $_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
 119     }
 120     $spec->{Nick} = $_;
 121     return $spec;
 122 }
 123
 124 1;