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 git_dir () {
  40     our $git_dir;
  41     if (!defined $git_dir) {
  42         $git_dir = run_git_1line(qw(rev-parse --git-dir));
  43     }
  44     return $git_dir;
  45 }
  46
  47 sub current_tb_branch () {
  48     open R, git_dir().'/HEAD' or die "open HEAD $!";
  49     my $ref = <R>;  defined $ref or die $!;
  50     close R;
  51     chomp $ref or die;
  52     if ($ref !~ s#^ref: ##) {
  53         return {
  54             Kind => 'detached',
  55             Ref => $ref,
  56         };
  57     }
  58     if ($ref =~ m#^refs/topbloke-(tip|base)s/([^/\@]*)\@([^/\@]*)/([^/]*)/#) {
  59         return {
  60             Kind => $1,
  61             Email => $2,
  62             Domain => $3,
  63             Date => $4,
  64             Nick => $', #',
  65             Ref => $ref,
  66             DepSpec => "$2\@$3/$4/$'",
  67         };
  68     } elsif ($ref =~ m#^refs/heads/#) {
  69         return {
  70             Kind => 'foreign',
  71             Ref => $ref,
  72             DepSpec => "/$ref",
  73         };
  74     } else {
  75         return {
  76             Kind => 'weird',
  77             Ref => $ref,
  78         };
  79     }
  80 }
  81
  82 sub parse_branch_spec ($) {
  83     my ($orig) = @_;
  84     local $_ = $orig;
  85     my $spec = { }; # Email Domain DatePrefix DateNear Nick
  86     my $set = sub {
  87         my ($key,$val,$whats) = @_;
  88         die "multiple $whats in branch spec\n" if exists $spec->{$key};
  89         $spec->{$key} = $val;
  90     };
  91     my $rel_levels;
  92     for (;;) {
  93         if (s#([^/\@]*)\@([^/\@]*)/##) {
  94             $set->('Email', $1, "email local parts") if length $1;
  95             $set->('Domain', $2, "email domains") if length $1;
  96         } elsif (s#([^/]*\~[^/]*)/##) {
  97             my $dspec = $1;
  98             $dspec =~ y/~/ /;
  99             open DATE, "-|", 'date','+%s','-d',$dspec or die $!;
 100             my $l = <DATE>;
 101             close DATE or die "date parsing failed\n";
 102             chomp $l or die;
 103             $set->('DateNear', $l, 'nearby dates');
 104         } elsif (s#^([0-9][^/]*)/##) {
 105             my $dspec = $1;
 106             $dspec =~
 107       m/^\d{4}(?:-\d\d(?:-\d\d(?:T(?:\d\d(?:\d\d(?:\d\d(?:Z)?)?)?)?)?)?)?$/
 108                 or die "bad date prefix \`$dspec'\n";
 109             $set->('DatePrefix', $dspec, 'date prefixes');
 110         } elsif (s#^\./##) {
 111             $rel_levels ||= 1;
 112         } elsif (s#^\.\./##) {
 113             $rel_levels ||= 1;
 114             $rel_levels++;
 115         } else {
 116             last;
 117         }
 118     }
 119     if (defined $rel_levels) {
 120         my $branch = current_tb_branch();
 121         if (!defined $branch->{Nick}) {
 122             die "relative branch spec \`$orig',".
 123                 " but current branch not a topbloke branch\n";
 124         }
 125         my ($ceaddr,$cdate,@l) = split /\//, $branch->{Nick};
 126         @l >= $rel_levels or
 127             die "relative branch spec \`$orig' has too many ../s\n";
 128         $_ = (join '/', @l[0..$#l-$rel_levels]).'/'.$_;
 129     }
 130     $spec->{Nick} = $_;
 131     return $spec;
 132 }
 133
 134 1;