File Coverage

blib/lib/CatalystX/VCS/Lookup.pm
Criterion Covered Total %
statement 8 8 100.0
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 11 11 100.0


line stmt bran cond sub pod time code
1             package CatalystX::VCS::Lookup;
2              
3             =head1 NAME
4              
5             CatalystX::VCS::Lookup - Extract VCS revision of application code
6              
7             =cut
8              
9 2     2   1904896 use 5.010;
  2         15  
10 2     2   497 use File::Which 'which';
  2         1021  
  2         114  
11 2     2   513 use Moose::Role;
  2         475938  
  2         14  
12              
13             =head1 VERSION
14              
15             Version 0.08
16              
17             =cut
18              
19             our $VERSION = '0.08';
20              
21             =head1 SYNOPSIS
22              
23             If your application is started from the working copy of version control system,
24             this module allows to get automatically current revision identificator in the
25             application config.
26              
27             Setup application:
28              
29             package MyApp;
30              
31             use Catalyst::Runtime;
32             use Moose;
33              
34             extends 'Catalyst';
35             with 'CatalystX::VCS::Lookup';
36              
37             1;
38              
39             Get revision from controller:
40              
41             sub index : Path Args(0) {
42             my ( $self,$c ) = @_;
43              
44             $c->res->body( "Current version:" . $c->config->{ revision } );
45             }
46              
47             =head1 CONFIGURATION
48              
49             You can customize config key for storing revision identificator.
50             Default key is 'revision'.
51              
52             __PACKAGE__->config(
53             'VCS::Lookup' => { Revision => 'version' }
54             );
55              
56             =cut
57              
58             before setup_finalize => sub {
59             my ( $app ) = @_;
60              
61             # get config key
62             my $key = exists $app->config->{ 'VCS::Lookup' }{ Revision } ?
63             $app->config->{ 'VCS::Lookup' }{ Revision } : 'revision';
64              
65             # revision is already set
66             return if exists $app->config->{ $key };
67              
68             # assume that the root directory of the installation
69             # is a VCS working copy
70             my $home = $app->config->{ home };
71              
72             # try to detect used VCS type
73             if ( -d $app->path_to('.git') ) {
74             if ( which 'git' ) {
75             my $info = qx( cd $home && git show --pretty=format:%H ) or
76             $app->log->warn("VCS::Lookup is unable to fetch Git info");
77              
78             ( $app->config->{ $key } ) = $info =~ m{ ^(\w+) }x or
79             $app->log->warn("VCS::Lookup is unable to determine Git revision")
80             if $info;
81             } else {
82             $app->log->warn("VCS::Lookup can't found git executable")
83             }
84             }
85             elsif ( -d $app->path_to('.hg') ) {
86             if ( which 'hg' ) {
87             my $info = qx( hg --cwd $home id --id ) or
88             $app->log->warn("VCS::Lookup is unable to fetch Mercurial info");
89              
90             ( $app->config->{ $key } ) = $info =~ m{ ^(\w+) }x or
91             $app->log->warn("VCS::Lookup is unable to determine Mercurial revision")
92             if $info;
93             } else {
94             $app->log->warn("VCS::Lookup can't found hg executable")
95             }
96             }
97             elsif ( -d $app->path_to('.svn') ) {
98             if ( which 'svn' ) {
99             my $info = qx( svnversion $home ) or
100             $app->log->warn("VCS::Lookup is unable to fetch SVN info");
101              
102             ( $app->config->{ $key } ) = $info =~ m{ ^(\d+) }x or
103             $app->log->warn("VCS::Lookup is unable to determine SVN revision")
104             if $info;
105             } else {
106             $app->log->warn("VCS::Lookup can't found svn executable")
107             }
108             }
109             else {
110             $app->log->warn("VCS::Lookup is unable to determine VCS type")
111             }
112             };
113              
114              
115             =head1 AUTHOR
116              
117             Oleg A. Mamontov, C<< <lonerr at cpan.org> >>
118              
119             =head1 BUGS
120              
121             Please report any bugs or feature requests to C<bug-catalystx-vcs-lookup at rt.cpan.org>, or through
122             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-VCS-Lookup>. I will be notified, and then you'll
123             automatically be notified of progress on your bug as I make changes.
124              
125             =head1 SUPPORT
126              
127             You can find documentation for this module with the perldoc command.
128              
129             perldoc CatalystX::VCS::Lookup
130              
131             You can also look for information at:
132              
133             =over 4
134              
135             =item * RT: CPAN's request tracker (report bugs here)
136              
137             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-VCS-Lookup>
138              
139             =item * AnnoCPAN: Annotated CPAN documentation
140              
141             L<http://annocpan.org/dist/CatalystX-VCS-Lookup>
142              
143             =item * CPAN Ratings
144              
145             L<http://cpanratings.perl.org/d/CatalystX-VCS-Lookup>
146              
147             =item * Search CPAN
148              
149             L<http://search.cpan.org/dist/CatalystX-VCS-Lookup/>
150              
151             =back
152              
153             =head1 ACKNOWLEDGEMENTS
154              
155             =head1 LICENSE AND COPYRIGHT
156              
157             Copyright 2012 Oleg A. Mamontov.
158              
159             This program is free software; you can redistribute it and/or modify it
160             under the terms of either: the GNU General Public License as published
161             by the Free Software Foundation; or the Artistic License.
162              
163             See http://dev.perl.org/licenses/ for more information.
164              
165             =cut
166              
167             1;