lib/App/Rgit/Repository.pm

   1 package App::Rgit::Repository;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Cwd        (); # cwd
   7 use File::Spec (); # canonpath, catdir, splitdir, abs2rel
   8 use POSIX      (); # WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG SIGINT SIGQUIT
   9
  10 use App::Rgit::Utils (); # abs_path
  11
  12 my ($WIFEXITED, $WEXITSTATUS, $WIFSIGNALED, $WTERMSIG);
  13
  14 BEGIN {
  15  $WIFEXITED   = eval { POSIX::WIFEXITED(0);   1 } ? \&POSIX::WIFEXITED
  16                                                   : sub { 1 };
  17  $WEXITSTATUS = eval { POSIX::WEXITSTATUS(0); 1 } ? \&POSIX::WEXITSTATUS
  18                                                   : sub { shift() >> 8 };
  19  $WIFSIGNALED = eval { POSIX::WIFSIGNALED(0); 1 } ? \&POSIX::WIFSIGNALED
  20                                                   : sub { shift() & 127 };
  21  $WTERMSIG    = eval { POSIX::WTERMSIG(0);    1 } ? \&POSIX::WTERMSIG
  22                                                   : sub { shift() & 127 };
  23 }
  24
  25 =head1 NAME
  26
  27 App::Rgit::Repository - Class representing a Git repository.
  28
  29 =head1 VERSION
  30
  31 Version 0.08
  32
  33 =cut
  34
  35 our $VERSION = '0.08';
  36
  37 =head1 DESCRIPTION
  38
  39 Class representing a Git repository.
  40
  41 This is an internal class to L<rgit>.
  42
  43 =head1 METHODS
  44
  45 =head2 C<new>
  46
  47     my $arr = App::Rgit::Repository->new(
  48      dir  => $dir,
  49      fake => $bool,
  50     );
  51
  52 Creates a new repository starting from C<$dir>.
  53 If the C<fake> option is passed, C<$dir> isn't checked to be a valid C<git> repository.
  54
  55 =cut
  56
  57 sub new {
  58  my $class = shift;
  59  $class = ref $class || $class;
  60
  61  my %args = @_;
  62
  63  my $dir = $args{dir};
  64  if (defined $dir) {
  65   $dir = App::Rgit::Utils::abs_path($dir);
  66  } else {
  67   $dir = Cwd::cwd;
  68  }
  69  $dir = File::Spec->canonpath($dir);
  70
  71  my ($repo, $bare, $name, $work);
  72  if ($args{fake}) {
  73   $repo = $work = $dir;
  74  } else {
  75   return unless -d $dir
  76             and -d "$dir/refs"
  77             and -d "$dir/objects"
  78             and -e "$dir/HEAD";
  79
  80   my @chunks = File::Spec->splitdir($dir);
  81   my $last   = pop @chunks;
  82   return unless defined $last;
  83
  84   if (@chunks and $last eq '.git') {
  85    $bare = 0;
  86    $name = $chunks[-1];
  87    $work = File::Spec->catdir(@chunks);
  88   } elsif ($last =~ /(.+)\.git$/) {
  89    $bare = 1;
  90    $name = $1;
  91    $work = File::Spec->catdir(@chunks, $last);
  92   } else {
  93    return;
  94   }
  95
  96   $repo = $dir;
  97  }
  98
  99  bless {
 100   fake => !!$args{fake},
 101   repo => $repo,
 102   bare => $bare,
 103   name => $name,
 104   work => $work,
 105  }, $class;
 106 }
 107
 108 =head2 C<chdir>
 109
 110 C<chdir> into the repository's directory.
 111
 112 =cut
 113
 114 sub chdir {
 115  my $self = shift;
 116  my $dir = $self->work;
 117  chdir $dir or do {
 118   warn "Couldn't chdir into $dir: $!";
 119   return;
 120  };
 121  return 1;
 122 }
 123
 124 =head2 C<run>
 125
 126     my $code = $arr->run($conf, @args);
 127
 128 Runs C<git @args> on the repository for the L<App::Rgit::Config> configuration C<$conf>.
 129 When the repository isn't fake, the format substitutions applies to C<@args> elements.
 130 Returns the exit code.
 131
 132 =cut
 133
 134 my $abs2rel = sub {
 135  my $a = File::Spec->abs2rel(@_);
 136  $a = $_[0] unless defined $a;
 137  $a;
 138 };
 139
 140 my %escapes = (
 141  '%' => sub { '%' },
 142  'n' => sub { shift->name },
 143  'g' => sub { $abs2rel->(shift->repo, shift->root) },
 144  'G' => sub { shift->repo },
 145  'w' => sub { $abs2rel->(shift->work, shift->root) },
 146  'W' => sub { shift->work },
 147  'b' => sub {
 148   my ($self, $conf) = @_;
 149   $abs2rel->(
 150    $self->bare ? $self->repo : $self->work . '.git',
 151    $conf->root
 152   );
 153  },
 154  'B' => sub { $_[0]->bare ? $_[0]->repo : $_[0]->work . '.git' },
 155  'R' => sub { $_[1]->root },
 156 );
 157 my $e = quotemeta join '', keys %escapes;
 158 $e = "[$e]";
 159
 160 sub run {
 161  my $self = shift;
 162  my $conf = shift;
 163  return unless $conf->isa('App::Rgit::Config');
 164
 165  my @args = @_;
 166
 167  unless ($self->fake) {
 168   s/%($e)/$escapes{$1}->($self, $conf)/eg for @args;
 169  }
 170
 171  unshift @args, $conf->git;
 172  $conf->info('Executing "', join(' ', @args), '" into ', $self->work, "\n");
 173
 174  {
 175   local $ENV{GIT_DIR} = $self->repo if exists $ENV{GIT_DIR};
 176   local $ENV{GIT_EXEC_PATH} = $conf->git if exists $ENV{GIT_EXEC_PATH};
 177   system { $args[0] } @args;
 178  }
 179
 180  if ($? == -1) {
 181   $conf->crit("Failed to execute git: $!\n");
 182   return;
 183  }
 184
 185  my $ret;
 186  $ret = $WEXITSTATUS->($?) if $WIFEXITED->($?);
 187  my $sig;
 188  if ($WIFSIGNALED->($?)) {
 189   $sig = $WTERMSIG->($?);
 190   $conf->warn("git died with signal $sig\n");
 191   if ($sig == POSIX::SIGINT() || $sig == POSIX::SIGQUIT()) {
 192    $conf->err("Aborting\n");
 193    exit $sig;
 194   }
 195  } elsif ($ret) {
 196   $conf->info("git returned $ret\n");
 197  }
 198
 199  return wantarray ? ($ret, $sig) : $ret;
 200 }
 201
 202 =head2 C<fake>
 203
 204 =head2 C<repo>
 205
 206 =head2 C<bare>
 207
 208 =head2 C<name>
 209
 210 =head2 C<work>
 211
 212 Read-only accessors.
 213
 214 =cut
 215
 216 BEGIN {
 217  eval "sub $_ { \$_[0]->{$_} }" for qw/fake repo bare name work/;
 218 }
 219
 220 =head1 SEE ALSO
 221
 222 L<rgit>.
 223
 224 =head1 AUTHOR
 225
 226 Vincent Pit, C<< <perl at profvince.com> >>, L<http://profvince.com>.
 227
 228 You can contact me by mail or on C<irc.perl.org> (vincent).
 229
 230 =head1 BUGS
 231
 232 Please report any bugs or feature requests to C<bug-rgit at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=rgit>.
 233 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 234
 235 =head1 SUPPORT
 236
 237 You can find documentation for this module with the perldoc command.
 238
 239     perldoc App::Rgit::Repository
 240
 241 =head1 COPYRIGHT & LICENSE
 242
 243 Copyright 2008,2009,2010 Vincent Pit, all rights reserved.
 244
 245 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 246
 247 =cut
 248
 249 1; # End of App::Rgit::Repository