lib/App/Rgit/Repository.pm

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