File Coverage

File:blib/lib/App/Rgit/Repository.pm
Coverage:81.6%

linestmtbrancondsubpodtimecode
1package App::Rgit::Repository;
2
3
6
6
6
6
58
17
287
use strict;
4
6
6
6
6
46
17
324
use warnings;
5
6
6
6
6
6
45
14
127
use Cwd (); # cwd
7
6
6
6
6
42
27
141
use File::Spec (); # canonpath, catdir, splitdir, abs2rel
8
6
6
6
6
2079
43732
315
use POSIX (); # WIFEXITED WEXITSTATUS WIFSIGNALED WTERMSIG SIGINT SIGQUIT
9
10
6
6
6
6
387
16
1677
use App::Rgit::Utils (); # abs_path
11
12my ($WIFEXITED, $WEXITSTATUS, $WIFSIGNALED, $WTERMSIG);
13
14BEGIN {
15
6
6
32
69
 $WIFEXITED = eval { POSIX::WIFEXITED(0); 1 } ? \&POSIX::WIFEXITED
16
6
0
50
6
86
0
                                                  : sub { 1 };
17
6
6
21
26
 $WEXITSTATUS = eval { POSIX::WEXITSTATUS(0); 1 } ? \&POSIX::WEXITSTATUS
18
6
0
50
16
0
                                                  : sub { shift() >> 8 };
19
6
6
21
26
 $WIFSIGNALED = eval { POSIX::WIFSIGNALED(0); 1 } ? \&POSIX::WIFSIGNALED
20
6
0
50
18
0
                                                  : sub { shift() & 127 };
21
6
6
29
10100
 $WTERMSIG = eval { POSIX::WTERMSIG(0); 1 } ? \&POSIX::WTERMSIG
22
6
0
50
14
0
                                                  : sub { shift() & 127 };
23}
24
25 - 33
=head1 NAME

App::Rgit::Repository - Class representing a Git repository.

=head1 VERSION

Version 0.08

=cut
34
35our $VERSION = '0.08';
36
37 - 50
=head1 DESCRIPTION

Class representing a Git repository.

This is an internal class to L<rgit>.

=head1 METHODS

=head2 C<< new dir => $dir [, fake => 1 ] >>

Creates a new repository starting from C<$dir>.
If the C<fake> option is passed, C<$dir> isn't checked to be a valid C<git> repository.

=cut
51
52sub new {
53
90
90
1
9279
 my $class = shift;
54
90
33
631
 $class = ref $class || $class;
55
56
90
592
 my %args = @_;
57
58
90
335
 my $dir = $args{dir};
59
90
100
291
 if (defined $dir) {
60
67
913
  $dir = App::Rgit::Utils::abs_path($dir);
61 } else {
62
23
54392
  $dir = Cwd::cwd;
63 }
64
90
2859
 $dir = File::Spec->canonpath($dir);
65
66
90
381
 my ($repo, $bare, $name, $work);
67
90
100
394
 if ($args{fake}) {
68
23
149
  $repo = $work = $dir;
69 } else {
70
67
100
80
8170
  return unless -d $dir
71            and -d "$dir/refs"
72            and -d "$dir/objects"
73            and -e "$dir/HEAD";
74
75
12
153
  my @chunks = File::Spec->splitdir($dir);
76
12
46
  my $last = pop @chunks;
77
12
50
37
  return unless defined $last;
78
79
12
100
50
67
120
  if (@chunks and $last eq '.git') {
80
8
14
   $bare = 0;
81
8
20
   $name = $chunks[-1];
82
8
185
   $work = File::Spec->catdir(@chunks);
83  } elsif ($last =~ /(.+)\.git$/) {
84
4
10
   $bare = 1;
85
4
16
   $name = $1;
86
4
81
   $work = File::Spec->catdir(@chunks, $last);
87  } else {
88
0
0
   return;
89  }
90
91
12
44
  $repo = $dir;
92 }
93
94
35
2656
 bless {
95  fake => !!$args{fake},
96  repo => $repo,
97  bare => $bare,
98  name => $name,
99  work => $work,
100 }, $class;
101}
102
103 - 107
=head2 C<chdir>

C<chdir> into the repository's directory.

=cut
108
109sub chdir {
110
17
17
1
74
 my $self = shift;
111
17
376
 my $dir = $self->work;
112
17
50
262
 chdir $dir or do {
113
0
0
  warn "Couldn't chdir into $dir: $!";
114
0
0
  return;
115 };
116
17
317
 return 1;
117}
118
119 - 125
=head2 C<run $conf, @args>

Runs C<git @args> on the repository for the L<App::Rgit::Config> configuration C<$conf>.
When the repository isn't fake, the format substitutions applies to C<@args> elements.
Returns the exit code.

=cut
126
127my $abs2rel = sub {
128 my $a = File::Spec->abs2rel(@_);
129 $a = $_[0] unless defined $a;
130 $a;
131};
132
133my %escapes = (
134 '%' => sub { '%' },
135 'n' => sub { shift->name },
136 'g' => sub { $abs2rel->(shift->repo, shift->root) },
137 'G' => sub { shift->repo },
138 'w' => sub { $abs2rel->(shift->work, shift->root) },
139 'W' => sub { shift->work },
140 'b' => sub {
141  my ($self, $conf) = @_;
142  $abs2rel->(
143   $self->bare ? $self->repo : $self->work . '.git',
144   $conf->root
145  );
146 },
147 'B' => sub { $_[0]->bare ? $_[0]->repo : $_[0]->work . '.git' },
148 'R' => sub { $_[1]->root },
149);
150my $e = quotemeta join '', keys %escapes;
151$e = "[$e]";
152
153sub run {
154
18
18
1
52
 my $self = shift;
155
18
42
 my $conf = shift;
156
18
50
161
 return unless $conf->isa('App::Rgit::Config');
157
158
18
285
 my @args = @_;
159
160
18
100
444
 unless ($self->fake) {
161
13
13
117
21
297
685
  s/%($e)/$escapes{$1}->($self, $conf)/eg for @args;
162 }
163
164
18
387
 unshift @args, $conf->git;
165
18
431
 $conf->info('Executing "', join(' ', @args), '" into ', $self->work, "\n");
166
167 {
168
18
18
100
42
167
  local $ENV{GIT_DIR} = $self->repo if exists $ENV{GIT_DIR};
169
18
100
154
  local $ENV{GIT_EXEC_PATH} = $conf->git if exists $ENV{GIT_EXEC_PATH};
170
18
18
39
105854
  system { $args[0] } @args;
171 }
172
173
18
50
601
 if ($? == -1) {
174
0
0
  $conf->crit("Failed to execute git: $!\n");
175
0
0
  return;
176 }
177
178
18
81
 my $ret;
179
18
50
319
 $ret = $WEXITSTATUS->($?) if $WIFEXITED->($?);
180
18
44
 my $sig;
181
18
50
100
162
 if ($WIFSIGNALED->($?)) {
182
0
0
  $sig = $WTERMSIG->($?);
183
0
0
  $conf->warn("git died with signal $sig\n");
184
0
0
0
0
  if ($sig == POSIX::SIGINT() || $sig == POSIX::SIGQUIT()) {
185
0
0
   $conf->err("Aborting\n");
186
0
0
   exit $sig;
187  }
188 } elsif ($ret) {
189
10
806
  $conf->info("git returned $ret\n");
190 }
191
192
18
100
1212
 return wantarray ? ($ret, $sig) : $ret;
193}
194
195 - 207
=head2 C<fake>

=head2 C<repo>

=head2 C<bare>

=head2 C<name>

=head2 C<work>

Read-only accessors.

=cut
208
209BEGIN {
210
6
6
26
18
13
87
79
6
26
18
13
87
79
1
1
1
1
1
23
2014
498
310
262
1673
1491
 eval "sub $_ { \$_[0]->{$_} }" for qw/fake repo bare name work/;
211}
212
213 - 240
=head1 SEE ALSO

L<rgit>.

=head1 AUTHOR

Vincent Pit, C<< <perl at profvince.com> >>, L<http://profvince.com>.

You can contact me by mail or on C<irc.perl.org> (vincent).

=head1 BUGS

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.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc App::Rgit::Repository

=head1 COPYRIGHT & LICENSE

Copyright 2008,2009,2010 Vincent Pit, all rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut
241
2421; # End of App::Rgit::Repository