File Coverage

blib/lib/VCS/Which/Plugin/Git.pm
Criterion Covered Total %
statement 46 185 24.8
branch 10 68 14.7
condition 0 27 0.0
subroutine 12 24 50.0
pod 10 10 100.0
total 78 314 24.8


line stmt bran cond sub pod time code
1             package VCS::Which::Plugin::Git;
2              
3             # Created on: 2009-05-16 16:58:22
4             # Create by: ivan
5             # $Id$
6             # $Revision$, $HeadURL$, $Date$
7             # $Revision$, $Source$, $Date$
8              
9 2     2   981 use Moo;
  2         5  
  2         11  
10 2     2   598 use strict;
  2         7  
  2         63  
11 2     2   54 use warnings;
  2         4  
  2         55  
12 2     2   12 use version;
  2         5  
  2         9  
13 2     2   140 use Carp;
  2         25  
  2         130  
14 2     2   21 use Data::Dumper qw/Dumper/;
  2         5  
  2         82  
15 2     2   10 use English qw/ -no_match_vars /;
  2         12  
  2         17  
16 2     2   748 use Path::Tiny;
  2         5  
  2         90  
17 2     2   13 use File::chdir;
  2         5  
  2         172  
18 2     2   17 use Contextual::Return;
  2         4  
  2         10  
19              
20             extends 'VCS::Which::Plugin';
21              
22             our $VERSION = version->new('0.6.7');
23             our $name = 'Git';
24             our $exe = 'git';
25             our $meta = '.git';
26              
27             sub installed {
28 6     6 1 10 my ($self) = @_;
29              
30 6 100       40 return $self->_installed if defined $self->_installed;
31              
32 1         13 for my $path (split /[:;]/, $ENV{PATH}) {
33 6 100       123 next if !-x "$path/$exe";
34              
35 1         13 return $self->_installed( 1 );
36             }
37              
38 0         0 return $self->_installed( 0 );
39             }
40              
41             sub used {
42 21     21 1 49 my ( $self, $dir ) = @_;
43              
44 21 50       181 if (-f $dir) {
45 0         0 $dir = path($dir)->parent;
46             }
47              
48 21 100       244 croak "$dir is not a directory!" if !-d $dir;
49              
50 20         180 my $current_dir = path($dir)->absolute;
51 20         1952 my $level = 1;
52              
53 20         79 while ($current_dir) {
54 111 50       3565 if ( -d "$current_dir/$meta" ) {
55 0         0 $self->_base( $current_dir );
56 0         0 return $level;
57             }
58              
59 111         1629 $level++;
60              
61             # check that we still have a parent directory
62 111 100       315 last if $current_dir eq $current_dir->parent;
63              
64 91         5623 $current_dir = $current_dir->parent;
65             }
66              
67 20         1258 return 0;
68             }
69              
70             sub uptodate {
71 0     0 1   my ( $self, $dir ) = @_;
72              
73 0   0       $dir ||= $self->_base;
74              
75 0 0         croak "'$dir' is not a directory!" if !-d $dir;
76              
77 0           local $CWD = path($dir)->absolute;
78 0           my $ans = `$exe status`;
79              
80 0 0         return $ans =~ /nothing \s to \s commit/xms ? 1 : 0;
81             }
82              
83             sub pull {
84 0     0 1   my ( $self, $dir ) = @_;
85              
86 0   0       $dir ||= $self->_base;
87              
88 0 0         croak "'$dir' is not a directory!" if !-e $dir;
89              
90 0           local $CWD = $dir;
91 0           return !system "$exe pull > /dev/null 2> /dev/null";
92             }
93              
94             sub push {
95 0     0 1   my ( $self, $dir ) = @_;
96              
97 0   0       $dir ||= $self->_base;
98              
99 0 0         croak "'$dir' is not a directory!" if !-e $dir;
100              
101 0           local $CWD = $dir;
102 0           return !system "$exe push origin master > /dev/null 2> /dev/null";
103             }
104              
105             sub cat {
106 0     0 1   my ($self, $file, $revision) = @_;
107              
108             # git expects $file to be relative to the base of the git repo not the
109             # current directory so we change it to being relative to the repo if nessesary
110 0 0         my $repo_dir = path($self->_base) or confess "How did I get here with out a base directory?\n";
111 0           my $cwd = path('.')->absolute;
112 0           local $CWD = $CWD;
113              
114 0 0 0       if ( -f $file && $cwd ne $repo_dir ) {
115             # get relavie directory of $cwd to $repo_dir
116 0           my ($relative) = $cwd =~ m{^ $repo_dir / (.*) $}xms;
117 0           my $old = $file;
118 0           $file = path("$relative/$file");
119 0 0         warn "Using repo absolute file $file from $old\n" if $ENV{VERBOSE};
120 0           $CWD = $repo_dir;
121             }
122              
123 0 0 0       if ( $revision && $revision =~ /^-?\d+$|[^0-9a-fA-F]/xms ) {
    0          
124 0           eval { require Git };
  0            
125 0 0         if ($EVAL_ERROR) {
126 0           die "Git.pm is not installed only propper revision names can be used\n";
127             }
128              
129 0           my $repo = Git->repository(Directory => $self->_base);
130 0           my @revs = reverse $repo->command('log', '--format=format:%H', '--', $file);
131 0 0 0       $revision = $revision =~ /^[-]?\d+$/xms && $revs[$revision] ? $revs[$revision] : $revision;
132             }
133             elsif ( !defined $revision ) {
134 0           $revision = '';
135             }
136 0 0         warn "$exe show $revision\:$file\n" if $ENV{VERBOSE};
137              
138 0           return `$exe show $revision\:$file`;
139             }
140              
141             sub log {
142 0     0 1   my ($self, @args) = @_;
143 0           local $CWD = $CWD;
144              
145 0           my $dir;
146 0 0 0       if ( defined $args[0] && -d $args[0] && $args[0] =~ m{^/} ) {
      0        
147 0           $dir = shift @args;
148 0           $CWD = $dir;
149             }
150 0           my $args = join ' ', grep {defined $_} @args;
  0            
151              
152             return
153 0     0     SCALAR { scalar `$exe log $args` }
154             ARRAYREF {
155 0     0     my @raw_log = `$exe log $args`;
156 0           my @log;
157 0           my $line = '';
158 0           for my $raw (@raw_log) {
159 0 0 0       if ( $raw =~ /^commit / && $line ) {
160 0           CORE::push @log, $line;
161 0           $line = $raw;
162             }
163             else {
164 0           $line .= $raw;
165             }
166              
167             }
168 0           return \@log;
169             }
170             HASHREF {
171 0     0     my $logs = `$exe log $args`;
172 0           my @logs = split /^commit\s*/xms, $logs;
173 0           shift @logs;
174 0           my $num = @logs;
175 0           my %log;
176 0           for my $log (@logs) {
177 0           $log{$num--} = $self->_log_expand($log);
178             }
179 0           return \%log;
180             }
181 0           }
182              
183             sub _log_expand {
184 0     0     my ($self, $log) = @_;
185              
186             # split the commit from the reset of the message
187 0           my ($ver, $rest) = split /\n/, $log, 2;
188              
189             # split log details and the description
190 0           my ($details, $description) = split /\n\n\s*/, $rest, 2;
191              
192             # remove excess whitespace at the end of the description
193 0           $description =~ s/\s+\Z//xms;
194 0           my ($conflicts) = $description =~ /\s+Conflicts:\s+(.*)\Z/xms;
195 0           $description =~ s/\s+Conflicts:\s+(.*)\Z//xms;
196              
197             # split up the details
198 0           my %log = map {split /:\s*/, $_, 2} split /\n/, $details;
  0            
199              
200             # add in the description
201 0           $log{description} = $description;
202              
203             # add in the revision
204 0           $log{rev} = $ver;
205              
206             # add conflicts if any
207 0 0         $log{conflicts} = [ split /\n\s+/, $conflicts ] if $conflicts;
208              
209 0           return \%log;
210             }
211              
212             sub versions {
213 0     0 1   my ($self, $file, $oldest, $newest, $max) = @_;
214              
215 0           eval { require Git };
  0            
216 0 0         if ($EVAL_ERROR) {
217 0           die "Git.pm is not installed only propper revision names can be used\n";
218             }
219              
220 0           my $repo = Git->repository(Directory => $self->_base);
221 0           my @revs = reverse $repo->command('rev-list', '--all', '--', path($file)->absolute);
222              
223 0           return @revs;
224             }
225              
226             sub status {
227 0     0 1   my ($self, $dir) = @_;
228 0           my %status;
229 0           my $name = '';
230 0 0         if ( -f $dir ) {
231 0           $name = path($dir)->absolute->basename;
232             }
233 0 0         local $CWD = -f $dir ? path($dir)->absolute->parent : path($dir)->absolute;
234 0           my $status = `$exe status $name`;
235 0           $status =~ s/^no \s+ changes (.*?) $//xms;
236 0           chomp $status;
237              
238 0           my @both = split /\n?[#]?\s+both\s+modified:\s+/, $status;
239 0 0         if ( @both > 1 ) {
240 0           shift @both;
241 0           $both[-1] =~ s/\n.*//xms;
242 0           $status{both} = \@both;
243             }
244              
245 0           my @modified = split /\n?[#]?\s+modified:\s+/, $status;
246 0 0         if ( @modified > 1 ) {
247 0           shift @modified;
248 0           $modified[-1] =~ s/\n.*//xms;
249 0           $status{modified} = \@modified;
250             }
251              
252 0           my @added = split /\n?[#]?\s+new\sfile:\s+/, $status;
253 0 0         if ( @added > 1 ) {
254 0           shift @added;
255 0           $added[-1] =~ s/\n.*//xms;
256 0           $status{added} = \@added;
257             }
258              
259 0           my @committed = split /Changes to be committed:\n/, $status;
260 0 0         if (@committed > 1) {
261 0           my $new = pop @committed;
262 0           $status{committed} = [ $new =~ /^\t[^:]+:\s+(.*?)\n/gxms ];
263             }
264              
265 0           my @untracked = split /Untracked files:\n/, $status;
266 0 0         if ( @untracked > 1 ) {
267 0           my $untracked = pop @untracked;
268 0 0         if ($untracked =~ s/^\s+[(]use \s+ "git \s+ add \s+ [^"]+" \s+ [^)]+\)\n\n//xms) {
269 0           chomp $untracked;
270             }
271             else {
272 0           $untracked =~ s/^[#].*?\n//gxms;
273             }
274              
275 0 0         if ($untracked =~ /^[#]/xms) {
276 0           $status{untracked} = [ grep {$_} map {chomp; $_} split /\n?[#]\s+/, $untracked ];
  0            
  0            
  0            
277             }
278             else {
279 0           $status{untracked} = [ $untracked =~ /^\t(.*?)\n/gxms ];
280             }
281             }
282              
283 0 0         if ($status =~ /
284             You \s+ have \s+ unmerged \s+ paths[.]$
285             |
286             All \s+ conflicts \s+ fixed \s+ but \s+ you \s+ are \s+ still \s+ merging[.]$
287             /xms) {
288 0           $status{merge} = 1;
289             }
290              
291 0           return \%status;
292             }
293              
294             sub checkout {
295 0     0 1   my ($self, $dir, @extra) = @_;
296 0           my $name = '';
297 0 0         if ( -f $dir ) {
298 0           $name = path($dir)->absolute->basename;
299             }
300 0 0         local $CWD = -f $dir ? path($dir)->absolute->parent : path($dir)->absolute;
301 0           my $extra = join ' ', @extra;
302 0           `$exe checkout $extra $name`;
303              
304 0           return;
305             }
306              
307             1;
308              
309             __END__
310              
311             =head1 NAME
312              
313             VCS::Which::Plugin::Git - The Git plugin for VCS::Which
314              
315             =head1 VERSION
316              
317             This documentation refers to VCS::Which::Plugin::Git version 0.6.7.
318              
319             =head1 SYNOPSIS
320              
321             use VCS::Which::Plugin::Git;
322              
323             # Brief but working code example(s) here showing the most common usage(s)
324             # This section will be as far as many users bother reading, so make it as
325             # educational and exemplary as possible.
326              
327             =head1 DESCRIPTION
328              
329             The plugin for the Git version control system
330              
331             =head1 SUBROUTINES/METHODS
332              
333             =head3 C<installed ()>
334              
335             Return: bool - True if the Git is installed
336              
337             Description: Determines if Git is actually installed and usable
338              
339             =head3 C<used ($dir)>
340              
341             Param: C<$dir> - string - Directory to check
342              
343             Return: bool - True if the directory is versioned by this Git
344              
345             Description: Determines if the directory is under version control of this Git
346              
347             =head3 C<uptodate ($dir)>
348              
349             Param: C<$dir> - string - Directory to check
350              
351             Return: bool - True if the directory has no uncommitted changes
352              
353             Description: Determines if the directory has no uncommitted changes
354              
355             =head3 C<cat ( $file[, $revision] )>
356              
357             Param: C<$file> - string - The name of the file to cat
358              
359             Param: C<$revision> - string - The revision to get. If the revision is negative
360             it refers to the number of revisions old is desired. Any other value is
361             assumed to be a version control specific revision. If no revision is specified
362             the most recent revision is returned.
363              
364             Return: The file contents of the desired revision
365              
366             Description: Gets the contents of a specific revision of a file.
367              
368             =head3 C<log ( @args )>
369              
370             TO DO: Body
371              
372             =head3 C<versions ( [$file], [@args] )>
373              
374             Description: Gets all the versions of $file
375              
376             =head3 C<pull ( [$dir] )>
377              
378             Description: Pulls or updates the directory $dir to the newest version
379              
380             =head3 C<push ( [$dir] )>
381              
382             Description: push updates to the master repository
383              
384             =head3 C<status ( $dir )>
385              
386             Description: push updates to the master repository
387              
388             =head3 C<checkout ( [$dir] )>
389              
390             Checkout clean copy of C<$file>
391              
392             =head1 DIAGNOSTICS
393              
394             =head1 CONFIGURATION AND ENVIRONMENT
395              
396             =head1 DEPENDENCIES
397              
398             =head1 INCOMPATIBILITIES
399              
400             =head1 BUGS AND LIMITATIONS
401              
402             There are no known bugs in this module.
403              
404             Please report problems to Ivan Wills (ivan.wills@gmail.com).
405              
406             Patches are welcome.
407              
408             =head1 AUTHOR
409              
410             Ivan Wills - (ivan.wills@gmail.com)
411              
412             =head1 LICENSE AND COPYRIGHT
413              
414             Copyright (c) 2009 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW, Australia 2077).
415             All rights reserved.
416              
417             This module is free software; you can redistribute it and/or modify it under
418             the same terms as Perl itself. See L<perlartistic>. This program is
419             distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
420             without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
421             PARTICULAR PURPOSE.
422              
423             =cut