File Coverage

blib/lib/VCS/Which.pm
Criterion Covered Total %
statement 163 167 97.6
branch 85 88 96.5
condition 13 15 86.6
subroutine 23 23 100.0
pod 15 15 100.0
total 299 308 97.0


line stmt bran cond sub pod time code
1             package VCS::Which;
2              
3             # Created on: 2009-05-16 16:54:35
4             # Create by: ivan
5             # $Id$
6             # $Revision$, $HeadURL$, $Date$
7             # $Revision$, $Source$, $Date$
8              
9 2     2   233022 use Moo;
  2         23585  
  2         10  
10 2     2   2988 use strict;
  2         5  
  2         39  
11 2     2   10 use warnings;
  2         5  
  2         52  
12 2     2   963 use version;
  2         4022  
  2         12  
13 2     2   165 use Carp;
  2         4  
  2         112  
14 2     2   1220 use Data::Dumper qw/Dumper/;
  2         14157  
  2         126  
15 2     2   960 use English qw/ -no_match_vars /;
  2         7517  
  2         19  
16 2     2   2372 use Path::Tiny;
  2         27233  
  2         3761  
17              
18             our $VERSION = version->new('0.6.8');
19              
20             our %systems;
21              
22             has [qw/dir systems/] => (
23             is => 'rw',
24             );
25             has [qw/_which _uptodate/] => (
26             is => 'rw',
27             default => sub {{}},
28             );
29              
30             sub BUILD {
31 18     18 1 144 my ($self) = @_;
32              
33 18 100       58 if ( !%systems ) {
34 1         5 $self->get_systems();
35             }
36              
37 18         61 $self->load_systems();
38              
39 18 100 100     301 if ( $self->dir && -f $self->dir ) {
40 1         89 $self->dir( path($self->dir)->parent );
41             }
42              
43 18         328 return $self;
44             }
45              
46             sub load_systems {
47 18     18 1 34 my ( $self ) = @_;
48              
49 18         60 for my $module (keys %systems) {
50 90         8773 $self->{systems}{$module} = $module->new;
51             }
52              
53 18         1777 return;
54             }
55              
56             sub get_systems {
57 1     1 1 2 my ($self) = @_;
58              
59 1         4 for my $dir (@INC) {
60 10 100       53 if ( $dir !~ /^\/|^\w:\// ) {
61 2         7 $dir = "./$dir";
62             }
63 10         604 my @files = glob "$dir/VCS/Which/Plugin/*.pm";
64              
65 10         43 for my $file (@files) {
66 9         19 my $module = $file;
67 9         100 $module =~ s{\Q$dir\E/}{}xms;
68 9         38 $module =~ s{/}{::}gxms;
69 9         38 $module =~ s{[.]pm$}{}xms;
70              
71 9 100       32 next if $systems{$module};
72              
73             eval {
74 5         2300 require $file;
75 5 50       8 } or do {
76 0         0 confess $@, "Error with $file / $module";
77             };
78 5         21097 $systems{$module} = 1;
79             }
80             }
81              
82 1         4 return;
83             }
84              
85             sub capabilities {
86 3     3 1 1376 my ($self, $dir) = @_;
87 3         7 my $out;
88             my %out;
89              
90 3 100       11 if ($dir) {
91 2         9 $self->dir($dir);
92             }
93             else {
94 1         4 $dir = $self->dir;
95             }
96              
97 3         5 for my $system (values %{ $self->{systems} }) {
  3         10  
98              
99 15         53 $out .= $system->name . ' ' x (10 - length $system->name);
100 15 100       54 $out .= $system->installed ? ' installed ' : ' not installed';
101 15         43 $out{$system->name}{installed} = $system->installed;
102              
103 15 100       33 if ($dir) {
104 10         17 eval {
105 10 100       31 $out .= $system->used($dir) ? ' versioning' : ' not versioning';
106 10         39 $out{$system->name}{installed} = $system->used($dir);
107             };
108 10 50       24 if ($EVAL_ERROR) {
109 0         0 warn "$system error in determining if the directory is used: $EVAL_ERROR\n";
110 0         0 $out .= ' NA';
111 0         0 $out{$system->name}{installed} = ' NA';
112             }
113             }
114              
115 15         45 $out .= "\n";
116             }
117              
118 3 100       25 return wantarray ? %out : $out;
119             }
120              
121             sub which {
122 27     27 1 1246 my ( $self, $dir ) = @_;
123              
124 27 100       58 if ($dir) {
125 5         18 $self->dir($dir);
126             }
127             else {
128 22         45 $dir = $self->dir;
129             }
130              
131 27 100 100     344 if ( $dir && -f $dir ) {
132 7         35 $dir = $self->dir( path($dir)->parent );
133             }
134              
135 27 100       985 confess "No directory supplied!" if !$dir;
136              
137 26 100       112 return $self->_which->{$dir} if exists $self->_which->{$dir};
138              
139 17         75 $self->_which->{$dir} = undef;
140 17         45 my %used;
141             my $min;
142              
143 17         74 for my $system (values %{ $self->{systems} }) {
  17         67  
144 85 100       117 my $used = eval { $system->used($dir) || 0 };
  85         293  
145 85 100       1443 next if $EVAL_ERROR;
146              
147 81 100 66     186 if ( $used && ! defined $min ) {
148 17         24 $min = $used;
149             }
150              
151             # check that the directory is used and that it was found at a level closer to $dir that the last found system
152 81 100 66     206 if ( $used && $used <= $min ) {
153 17         70 $self->_which->{$dir} = $system;
154 17         45 $min = $used;
155             }
156             }
157              
158 17 50       79 confess "Could not work out what plugin to use with '$dir'\n" if !$self->_which->{$dir};
159              
160 17         70 return $self->_which->{$dir};
161             }
162              
163             sub uptodate {
164 4     4 1 3103 my ( $self, $dir ) = @_;
165              
166 4 100       13 if ($dir) {
167 2         10 $self->dir($dir);
168             }
169             else {
170 2         8 $dir = $self->dir;
171             }
172              
173 4 100       23 confess "No directory supplied!" if !$dir;
174              
175 3 100       15 return $self->_uptodate->{$dir} if exists $self->_uptodate->{$dir};
176              
177 2         6 my $system = $self->which;
178              
179 2         10 return $self->_uptodate->{$dir} = $system->uptodate($dir);
180             }
181              
182             sub exec {
183 4     4 1 1915 my ( $self, @args ) = @_;
184 4         8 my $dir;
185              
186 4 100       36 confess "Nothing to exec!" if !@args;
187              
188 3 100       61 if (-e $args[0]) {
189 1         8 $dir = $self->dir( shift @args );
190             }
191             else {
192 2         10 $dir = $self->dir;
193             }
194              
195 3 100       31 confess "No directory supplied!" if !$dir;
196              
197 2         8 my $system = $self->which;
198              
199 2         14 return $system->exec($dir, @args);
200             }
201              
202             sub log {
203 5     5 1 2202 my ( $self, $file, @args ) = @_;
204              
205 5 100 100     94 if ( $file && ! -e $file ) {
206 2         9 unshift @args, $file;
207 2         5 undef $file;
208             }
209              
210 5 100       46 my $dir
    100          
211             = !defined $file ? $self->dir
212             : -f $file ? path($file)->parent
213             : $file;
214              
215 5 100       116 confess "No directory supplied!" if !$dir;
216              
217 4         13 my $system = $self->which($dir);
218              
219 4         29 return $system->log($file, @args);
220             }
221              
222             sub cat {
223 5     5 1 2356 my ( $self, $file, @args ) = @_;
224              
225 5 100       14 if ($file) {
226 3         14 $self->dir($file);
227             }
228             else {
229 2         8 $file = $self->dir;
230             }
231              
232 5 100       29 confess "No file supplied!" if !$file;
233              
234 4         10 my $system = $self->which;
235              
236 4         20 return $system->cat($file, @args);
237             }
238              
239             sub versions {
240 3     3 1 1736 my ( $self, $file, @args ) = @_;
241              
242 3 100       9 if ($file) {
243 1         6 $self->dir($file);
244             }
245             else {
246 2         7 $file = $self->dir;
247             }
248              
249 3 100       28 confess "No file supplied!" if !$file;
250              
251 2         6 my $system = $self->which;
252              
253 2         20 return $system->versions($file, @args);
254             }
255              
256             sub pull {
257 3     3 1 1725 my ( $self, $dir ) = @_;
258              
259 3 100       9 if ($dir) {
260 1         6 $self->dir($dir);
261             }
262             else {
263 2         11 $dir = $self->dir;
264             }
265              
266 3 100       25 confess "No directory supplied!" if !$dir;
267              
268 2         7 my $system = $self->which;
269              
270 2         21 return $system->pull($dir);
271             }
272              
273             sub push {
274 3     3 1 1652 my ( $self, $dir ) = @_;
275              
276 3 100       10 if ($dir) {
277 1         5 $self->dir($dir);
278             }
279             else {
280 2         7 $dir = $self->dir;
281             }
282              
283 3 100       25 confess "No directory supplied!" if !$dir;
284              
285 2         5 my $system = $self->which;
286              
287 2         19 return $system->push($dir);
288             }
289              
290             sub status {
291 3     3 1 1740 my ( $self, $dir ) = @_;
292              
293 3 100       9 if ($dir) {
294 1         5 $self->dir($dir);
295             }
296             else {
297 2         9 $dir = $self->dir;
298             }
299              
300 3 100       25 confess "No directory supplied!" if !$dir;
301              
302 2         5 my $system = $self->which;
303              
304 2         21 return $system->status($dir);
305             }
306              
307             sub checkout {
308 3     3 1 1732 my ( $self, $dir, @extra ) = @_;
309              
310 3 100       12 if ($dir) {
311 1         5 $self->dir($dir);
312             }
313             else {
314 2         8 $dir = $self->dir;
315             }
316              
317 3 100       24 confess "No directory supplied!" if !$dir;
318              
319 2         6 my $system = $self->which;
320              
321 2         20 return $system->checkout($dir, @extra);
322             }
323              
324             sub add {
325 3     3 1 1936 my ( $self, $dir, @extra ) = @_;
326              
327 3 100       8 if ($dir) {
328 1         7 $self->dir($dir);
329             }
330             else {
331 2         8 $dir = $self->dir;
332             }
333              
334 3 100       35 confess "No directory supplied!" if !$dir;
335              
336 2         6 my $system = $self->which;
337              
338 2         20 return $system->add($dir, @extra);
339             }
340              
341             1;
342              
343             __END__
344              
345             =head1 NAME
346              
347             VCS::Which - Generically interface with version control systems
348              
349             =head1 VERSION
350              
351             This documentation refers to VCS::Which version 0.6.8.
352              
353             =head1 SYNOPSIS
354              
355             use VCS::Which;
356              
357             # create a new object
358             my $vcs = VCS::Which->new();
359              
360             if ( !$vcs->uptodate('.') ) {
361             warn "Directory has uncommitted changes\n";
362             }
363              
364             =head1 DESCRIPTION
365              
366             This module provides methods to interface with a version control system
367             (vcs) with out having to care which command to use or which sub command in
368             needed for several basic operations like checking if there are any
369             uncommitted changes.
370              
371             =head1 SUBROUTINES/METHODS
372              
373             =head2 C<BUILD ()>
374              
375             Initializes the C<VCS::Which> object.
376              
377             =head2 C<load_systems ()>
378              
379             Description: Creates new objects for each version control system found
380              
381             =head2 C<get_systems ()>
382              
383             Description: Searches for version control systems plugins installed
384              
385             =head2 C<capabilities ( [$dir] )>
386              
387             Param: C<$dir> - string - Directory to base out put on
388              
389             Return: list context - The data for each system's capabilities
390             scalar context - A string displaying each system's capabilities
391              
392             Description: Gets the capabilities of each system and returns the results
393              
394             =head2 C<which ( [$dir] )>
395              
396             Param: C<$dir> - string - Directory to work out which system it is using
397              
398             Return: VCS::Which::Plugin - Object which can be used against the directory
399              
400             Description: Determines which version control plugin can be used to with the
401             supplied directory.
402              
403             =head2 C<uptodate ( $dir )>
404              
405             Param: C<$dir> - string - Directory to base out put on
406              
407             Return: bool - True if the everything is checked in for the directory
408              
409             Description: Determines if there are any changes that have not been committed
410             to the VCS running the directory.
411              
412             =head2 C<exec ( @args )>
413              
414             Param: C<@args> - array - Arguments to pass on to the appropriate vcs command
415              
416             Description: Runs the appropriate vcs command with the parameters supplied
417              
418             =head2 C<cat ( $file[, $revision] )>
419              
420             Param: C<$file> - string - The name of the file to cat
421              
422             Param: C<$revision> - string - The revision to get. If the revision is negative
423             it refers to the number of revisions old is desired. Any other value is
424             assumed to be a version control specific revision. If no revision is specified
425             the most recent revision is returned.
426              
427             Return: The file contents of the desired revision
428              
429             Description: Gets the contents of a specific revision of a file.
430              
431             =head2 C<log ( [$file], [@args] )>
432              
433             Param: C<$file> - string - The name of the file or directory to get the log of
434              
435             Param: C<@args> - strings - Any other arguments to pass to the log command
436              
437             Return: The log out put
438              
439             Description: Gets the log of changes (optionally limited to a file)
440              
441             =head2 C<versions ( [$file], [@args] )>
442              
443             Description: Gets all the versions of $file
444              
445             =head2 C<pull ( [$dir] )>
446              
447             Description: Pulls or updates the directory $dir to the newest version
448              
449             =head2 C<push ( [$dir] )>
450              
451             Description: Pushes content to master repository for distributed VCS systems
452              
453             =head2 C<status ( [$dir] )>
454              
455             Return: HASHREF - Status of files
456              
457             Description: Get the statuses of all files not added or not committed in the
458             repository.
459              
460             =head2 C<add ( [$file] )>
461              
462             Add C<$file> to VCS
463              
464             =head2 C<checkout ( [$dir] )>
465              
466             Checkout clean copy of C<$file>
467              
468             =head1 ATTRIBUTES
469              
470             =head2 C<dir>
471              
472             The directory base for the VCS operation to be carried out.
473              
474             =head2 C<systems>
475              
476             All the available VCS system plugins found.
477              
478             =head1 DIAGNOSTICS
479              
480             =head1 CONFIGURATION AND ENVIRONMENT
481              
482             =head1 DEPENDENCIES
483              
484             =head1 INCOMPATIBILITIES
485              
486             =head1 BUGS AND LIMITATIONS
487              
488             The initial template usually just has:
489              
490             There are no known bugs in this module.
491              
492             Please report problems to Ivan Wills (ivan.wills@gmail.com).
493              
494             Patches are welcome.
495              
496             =head1 AUTHOR
497              
498             Ivan Wills - (ivan.wills@gmail.com)
499              
500             =head1 LICENSE AND COPYRIGHT
501              
502             Copyright (c) 2009 Ivan Wills (14 Mullion Close, Hornsby Heights, NSW, Australia 2077).
503             All rights reserved.
504              
505             This module is free software; you can redistribute it and/or modify it under
506             the same terms as Perl itself. See L<perlartistic>. This program is
507             distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
508             without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
509             PARTICULAR PURPOSE.
510              
511             =cut