File Coverage

blib/lib/Footprintless/Util.pm
Criterion Covered Total %
statement 96 112 85.7
branch 30 46 65.2
condition 5 17 29.4
subroutine 19 20 95.0
pod 14 14 100.0
total 164 209 78.4


line stmt bran cond sub pod time code
1 18     18   102566 use strict;
  18         48  
  18         434  
2 18     18   78 use warnings;
  18         30  
  18         665  
3              
4             package Footprintless::Util;
5             $Footprintless::Util::VERSION = '1.26';
6             # ABSTRACT: A utility method package for common functionality in Footprintless
7             # PODNAME: Footprintless::Util
8              
9 18     18   87 use Carp;
  18         31  
  18         867  
10 18     18   91 use Exporter qw(import);
  18         31  
  18         441  
11 18     18   1049 use Log::Any;
  18         29976  
  18         88  
12              
13             our @EXPORT_OK = qw(
14             agent
15             clean
16             default_command_runner
17             dynamic_module_new
18             dumper
19             exit_due_to
20             extract
21             factory
22             invalid_entity
23             rebase
24             slurp
25             spurt
26             temp_dir
27             temp_file
28             );
29              
30             my $logger = Log::Any->get_logger();
31             my $extract_impl;
32              
33             sub agent {
34 11     11 1 30 my (%options) = @_;
35              
36 11         1413 require LWP::UserAgent;
37 11         100149 my $agent = LWP::UserAgent->new();
38 11         9013 $agent->env_proxy();
39              
40 11 50       33045 $agent->timeout( $options{timeout} ) if ( defined( $options{timeout} ) );
41 11 50       48 $agent->cookie_jar( $options{cookie_jar} ) if ( defined( $options{cookie_jar} ) );
42              
43 11         58 return $agent;
44             }
45              
46             sub clean {
47 14     14 1 92 my ( $paths, %options ) = @_;
48              
49 14 50 33     169 if ( $paths && ref($paths) eq 'ARRAY' && scalar(@$paths) ) {
      50        
50 14         80 $logger->debugf( "cleaning %s", $paths );
51             my $command_runner = $options{command_runner}
52 14   33     250 || default_command_runner();
53              
54             my @all_paths =
55             $options{rebase}
56 14 50       68 ? map { rebase( $_, $options{rebase} ) } @$paths
  0         0  
57             : @$paths;
58 14 100       44 my @dir_paths = map { ( $_ =~ /\/\s*$/ ) ? $_ : () } @all_paths;
  18         148  
59              
60 14         429 require Footprintless::Command;
61 14         30 eval {
62             $command_runner->run_or_die(
63             Footprintless::Command::batch_command(
64             Footprintless::Command::rm_command(@all_paths),
65             ( @dir_paths
66             ? Footprintless::Command::mkdir_command(@dir_paths)
67             : ()
68             ),
69             $options{command_options}
70             )
71 14 50       78 );
72             };
73 14 50       750 if ($@) {
74 0         0 $logger->errorf( 'clean failed: %s', $@ );
75 0         0 croak($@);
76             }
77             }
78             }
79              
80             sub default_command_runner {
81 13     13 1 5687 require Footprintless::CommandRunner::IPCRun;
82 13         210 return Footprintless::CommandRunner::IPCRun->new(@_);
83             }
84              
85             sub dumper {
86 1     1 1 645 require Data::Dumper;
87 1         7698 return Data::Dumper->new( \@_ )->Indent(1)->Sortkeys(1)->Dump();
88             }
89              
90             sub dynamic_module_new {
91 40     40 1 146 my ( $module, @args ) = @_;
92 40         99 my $module_path = $module;
93 40         203 $module_path =~ s/::/\//g;
94 40         5512 require "$module_path.pm"; ## no critic
95 28         1920 return $module->new(@args);
96             }
97              
98             sub exit_due_to {
99 0     0 1 0 my ( $dollar_at, $verbose ) = @_;
100 0 0 0     0 if ( ref($dollar_at)
101             && $dollar_at->isa('Footprintless::CommandRunner::ExecutionException') )
102             {
103 0         0 $dollar_at->exit($verbose);
104             }
105             else {
106 0         0 print( STDERR "$dollar_at\n" );
107 0         0 exit 255;
108             }
109             }
110              
111             sub extract {
112 5     5 1 21 my ( $archive, %options ) = @_;
113              
114 5 50       46 my @to = $options{to} ? ( to => $options{to} ) : ();
115 5         43 my @type_option = ();
116 5 50       23 if ( $options{type} ) {
    100          
117 0         0 push( @type_option, type => $options{type} );
118             }
119             elsif ( $archive =~ /\.war|\.jar|\.ear|\.twbx$/ ) {
120              
121             # other known zip type extensions
122 1         18 push( @type_option, type => 'zip' );
123             }
124              
125 5   33     80 return _new_extract( archive => $archive, @type_option )->extract(@to)
126             || croak("unable to extract $archive: $!");
127             }
128              
129             sub factory {
130 49     49 1 90204 my ( $entities, @options ) = @_;
131              
132 49 100       401 if ( ref($entities) eq 'HASH' ) {
133 30         506 require Config::Entities;
134 30         6873 $entities = Config::Entities->new( { entity => $entities } );
135             }
136              
137 49         6216 my $factory;
138 49         186 my $factory_module = $entities->get_entity('footprintless.factory');
139 49 100       878 if ( $entities->get_entity('footprintless.factory') ) {
140 5         91 $factory = dynamic_module_new( $factory_module, $entities, @options );
141             }
142             else {
143 44         4198 require Footprintless::Factory;
144 44         286 $factory = Footprintless::Factory->new( $entities, @options );
145             }
146              
147 49         409 return $factory;
148             }
149              
150             sub invalid_entity {
151 2     2 1 3 my ( $coordinate, $message ) = @_;
152              
153 2         10 require Footprintless::InvalidEntityException;
154 2   33     9 die(Footprintless::InvalidEntityException->new(
155             $coordinate, $message || "$coordinate required"
156             )
157             );
158             }
159              
160             sub _new_extract {
161 5     5   23 my (@args) = @_;
162              
163 5 100       19 unless ($extract_impl) {
164 2         5 eval {
165 2         133 require Archive::Extract::Libarchive;
166 0         0 $extract_impl = 'Archive::Extract::Libarchive';
167             };
168             }
169 5 100       17 unless ($extract_impl) {
170 2         5 eval {
171 2         75 require Archive::Extract;
172 0         0 $extract_impl = 'Archive::Extract';
173             };
174             }
175 5 100       19 unless ($extract_impl) {
176 2         943 require Footprintless::Extract;
177 2         7 $extract_impl = 'Footprintless::Extract';
178             }
179              
180 5         37 return $extract_impl->new(@args);
181             }
182              
183             sub rebase {
184 1     1 1 6 my ( $path, $rebase ) = @_;
185              
186 1         4 my $rebased;
187 1 50       175 if ( $path =~ /^$rebase->{from}(.*)$/ ) {
188 1         13 $rebased = "$rebase->{to}$1";
189             }
190             else {
191 0         0 croak("invalid rebase $path from $rebase->{from} to $rebase->{to}");
192             }
193              
194 1         20 return $rebased;
195             }
196              
197             sub slurp {
198 92     92 1 54988 my ($file) = @_;
199              
200             # http://www.perl.com/pub/2003/11/21/slurp.html
201             return $file
202 92         540 ? do { local ( @ARGV, $/ ) = $file; <> }
  92         4312  
203 92 50       270 : do { local $/; };
  0         0  
  0         0  
204             }
205              
206             sub spurt {
207 23     23 1 75649 my ( $content, $file, %options ) = @_;
208 23 50       145 my $write_mode = $options{append} ? '>>' : '>';
209 23 50       1096 open( my $handle, $write_mode, $file )
210             || croak("unable to open [$file]: $!");
211 23         234 print( $handle $content );
212 23         692 close($handle);
213             }
214              
215             sub temp_dir {
216 7     7 1 18006 require File::Temp;
217 7         11394 my $temp = File::Temp->newdir( 'fpl_XXXXXXXX', TMPDIR => 1 );
218 7 50       3122 if ( !chmod( 0700, $temp ) ) {
219 0         0 croak("unable to create secure temp file");
220             }
221 7         143 return $temp;
222             }
223              
224             sub temp_file {
225 8     8 1 28 my (%options) = @_;
226 8         457 require File::Temp;
227             my $temp = File::Temp->new(
228             'fpl_XXXXXXXX',
229             TMPDIR => 1,
230 8 100       11436 ( $options{suffix} ? ( SUFFIX => $options{suffix} ) : () )
231             );
232 8 50       3520 if ( !chmod( 0600, $temp ) ) {
233 0         0 croak("unable to create secure temp file");
234             }
235 8         37 return $temp;
236             }
237              
238             1;
239              
240             __END__