File Coverage

blib/lib/Shipwright/Test.pm
Criterion Covered Total %
statement 38 86 44.1
branch 2 32 6.2
condition 5 33 15.1
subroutine 13 24 54.1
pod 14 14 100.0
total 72 189 38.1


line stmt bran cond sub pod time code
1             package Shipwright::Test;
2              
3 13     13   166310 use warnings;
  13         48  
  13         365  
4 13     13   59 use strict;
  13         26  
  13         255  
5 13     13   52 use base qw/Exporter/;
  13         28  
  13         1332  
6              
7 13     13   1400 use File::Temp qw/tempdir/;
  13         43851  
  13         615  
8 13     13   4916 use IPC::Cmd qw/can_run/;
  13         377985  
  13         826  
9 13     13   852 use File::Spec::Functions qw/catfile catdir/;
  13         1836  
  13         591  
10 13     13   950 use Shipwright::Util;
  13         30  
  13         954  
11 13     13   70 use Cwd 'getcwd';
  13         25  
  13         7206  
12              
13             our @EXPORT =
14             qw/has_svk has_svn skip_svk skip_svn create_fs_repo create_svk_repo
15             create_svn_repo devel_cover_enabled test_cmd skip_git create_git_repo/;
16              
17             =head1 NAME
18              
19             Shipwright::Test - Test
20              
21             =head1 SYNOPSIS
22              
23             use Shipwright::Test;
24              
25             =head2 has_svk
26              
27             check to see if we have svk or not, also limit the svk version to be 2+.
28             in fact, it also checks svnadmin since we need that to create repo for svk.
29              
30             =cut
31              
32             sub has_svk {
33 0 0 0 0 1 0 if ( can_run( $ENV{'SHIPWRIGHT_SVK'} )
34             && can_run( $ENV{'SHIPWRIGHT_SVN'} . 'admin' ) )
35             {
36             my $out =
37 0         0 run_cmd( [ $ENV{'SHIPWRIGHT_SVK'}, '--version' ], 1 );
38 0 0 0     0 if ( $out && $out =~ /version v(\d)\./i ) {
39 0 0       0 return 1 if $1 >= 2;
40             }
41             }
42 0         0 return;
43             }
44              
45             =head2 has_svn
46              
47             check to see if we have svn or not, also limit the svn version to be 1.4+.
48             in fact, it also checks svnadmin since we need that to create repo.
49              
50             =cut
51              
52             sub has_svn {
53 0 0 0 0 1 0 if ( can_run( $ENV{'SHIPWRIGHT_SVN'} )
54             && can_run( $ENV{'SHIPWRIGHT_SVN'} . 'admin' ) )
55             {
56             my $out =
57 0         0 run_cmd( [ $ENV{'SHIPWRIGHT_SVN'}, '--version' ], 1 );
58 0 0 0     0 if ( $out && $out =~ /version 1\.(\d)/i ) {
59 0 0       0 return 1 if $1 >= 4;
60             }
61             }
62 0         0 return;
63             }
64              
65             =head2 has_git
66              
67             check to see if we have git or not
68              
69             =cut
70              
71             sub has_git {
72 0 0   0 1 0 if ( can_run( $ENV{'SHIPWRIGHT_GIT'} ) ) {
73 0         0 return 1;
74             }
75 0         0 return;
76             }
77              
78             =head2 skip_svn
79              
80             if skip svn when test.
81             skip test svn unless env SHIPWRIGHT_TEST_SVN is set to true and
82             the system has svn
83              
84             =cut
85              
86             sub skip_svn {
87 2 50 33 2 1 3429 return if $ENV{'SHIPWRIGHT_TEST_SVN'} && has_svn();
88 2         5 return 1;
89             }
90              
91             =head2 skip_svk
92              
93             if skip svk when test.
94             skip test svk unless env SHIPWRIGHT_TEST_SVK is set to true and
95             the system has svk
96              
97             =cut
98              
99             sub skip_svk {
100 1 50 33 1 1 446 return if $ENV{'SHIPWRIGHT_TEST_SVK'} && has_svk();
101 1         2 return 1;
102             }
103              
104             =head2 skip_git
105              
106             if skip git when test.
107             skip test git unless env SHIPWRIGHT_TEST_GIT is set to true and
108             the system has git
109              
110             =cut
111              
112             sub skip_git {
113 0 0 0 0 1 0 return if $ENV{'SHIPWRIGHT_TEST_GIT'} && has_git();
114 0         0 return 1;
115             }
116              
117              
118             =head2 create_fs_repo
119              
120             create a repo for fs
121              
122             =cut
123              
124             sub create_fs_repo {
125 2     2 1 919 return tempdir( 'shipwright_test_fs_XXXXXX', CLEANUP => 1, TMPDIR => 1 );
126             }
127              
128             =head2 create_git_repo
129              
130             create a repo for git
131              
132             =cut
133              
134             sub create_git_repo {
135 0     0 1 0 my $dir = tempdir( 'shipwright_test_git_XXXXXX', CLEANUP => 1, TMPDIR => 1 );
136 0         0 my $cwd = getcwd();
137 0         0 chdir $dir;
138 0         0 run_cmd( [$ENV{'SHIPWRIGHT_GIT'}, 'init', '--bare' ] );
139 0         0 chdir $cwd;
140 0         0 return "file://$dir";
141             }
142              
143             =head2 create_svk_repo
144              
145             create a repo for svk, will set $ENV{SVKROOT} accordingly.
146             return $ENV{SVKROOT}
147              
148             =cut
149              
150             sub create_svk_repo {
151             $ENV{SVKROOT} =
152 0     0 1 0 tempdir( 'shipwright_test_svk_XXXXXX', CLEANUP => 1, TMPDIR => 1 );
153 0         0 my $svk_root_local = catdir( $ENV{SVKROOT}, 'local' );
154 0         0 system("$ENV{SHIPWRIGHT_SVN}admin create $svk_root_local");
155 0         0 system("$ENV{SHIPWRIGHT_SVK} depotmap -i");
156 0         0 return $ENV{SVKROOT};
157             }
158              
159             =head2 create_svn_repo
160              
161             create a svn repo.
162             return the repo's uri, like file:///tmp/foo
163              
164             =cut
165              
166             sub create_svn_repo {
167 0     0 1 0 my $repo =
168             tempdir( 'shipwright_test_svn_XXXXXX', CLEANUP => 1, TMPDIR => 1 );
169 0 0       0 system("$ENV{SHIPWRIGHT_SVN}admin create $repo")
170             && confess_or_die "create repo failed: $!";
171 0         0 return "file://$repo";
172             }
173              
174             =head2 init
175              
176             init something, like log
177              
178             =cut
179              
180             sub init {
181 7     7 1 513 require Shipwright::Logger;
182 7         44 Shipwright::Logger->new( log_level => 'FATAL' );
183 7   50     32 $ENV{'SHIPWRIGHT_SVK'} ||= 'svk';
184 7   50     25 $ENV{'SHIPWRIGHT_SVN'} ||= 'svn';
185 7   50     28 $ENV{'SHIPWRIGHT_GIT'} ||= 'git';
186 7         32 $ENV{'SHIPWRIGHT_USER_ROOT'} =
187             tempdir( 'shipwright_user_root_XXXXXX', CLEANUP => 1, TMPDIR => 1 );
188             }
189              
190             =head2 shipwright_bin
191              
192             return the path of bin/shipwright
193              
194             =cut
195              
196             sub shipwright_bin {
197 13     13   91 no warnings 'uninitialized';
  13         28  
  13         3337  
198              
199             # so, we'd better add lib to PERL5LIB before run shipwright.
200             # what? you don't want to run shipwright?!!
201             # then what did you call this method for?
202              
203 0 0   0 1   $ENV{PERL5LIB} = 'lib:' . $ENV{PERL5LIB} unless $ENV{PERL5LIB} =~ /^lib:/;
204 0           return catfile( 'bin', 'shipwright' );
205             }
206              
207             =head2 devel_cover_enabled
208              
209             return true if -MDevel::Cover
210              
211             =cut
212              
213             sub devel_cover_enabled {
214 0     0 1   return $INC{'Devel/Cover.pm'};
215             }
216              
217             =head2 test_cmd
218              
219             a simple wrap for test cmd like create, list ...
220              
221             =cut
222              
223             sub test_cmd {
224 0     0 1   my $cmd = shift;
225 0           my $exp = shift;
226 0   0       my $msg = shift || "@$cmd out";
227 0           my $exp_err = shift;
228 0   0       my $msg_err = shift || "@$cmd err";
229              
230 0 0         unshift @$cmd, $^X, '-MDevel::Cover' if devel_cover_enabled;
231              
232 0           require Test::More;
233 0           my ( $out, $err ) = run_cmd( $cmd, 1 ); # ingnore failure
234              
235 0 0         _test_cmd( $out, $exp, $msg ) if defined $exp;
236 0 0         _test_cmd( $err, $exp_err, $msg_err ) if defined $exp_err;
237             }
238              
239             sub _test_cmd {
240 0     0     my $out = shift;
241 0           my $exp = shift;
242 0           my $msg = shift;
243              
244 0 0         if ( ref $exp eq 'Regexp' ) {
245 0           Test::More::like( $out, $exp, $msg );
246             }
247             else {
248 0           Test::More::is( $out, $exp, $msg );
249             }
250             }
251              
252             1;
253              
254             __END__