File Coverage

blib/lib/CPANPLUS/Dist/Slackware/Util.pm
Criterion Covered Total %
statement 77 110 70.0
branch 21 52 40.3
condition n/a
subroutine 15 16 93.7
pod 6 6 100.0
total 119 184 64.6


line stmt bran cond sub pod time code
1             package CPANPLUS::Dist::Slackware::Util;
2              
3 2     2   95069 use strict;
  2         13  
  2         70  
4 2     2   18 use warnings;
  2         8  
  2         121  
5              
6             our $VERSION = '1.029';
7              
8 2     2   13 use base qw(Exporter);
  2         5  
  2         341  
9              
10             our @EXPORT_OK
11             = qw(can_run run catdir catfile tmpdir slurp spurt filetype gzip strip);
12              
13 2     2   527 use English qw( -no_match_vars );
  2         1721  
  2         12  
14              
15 2     2   1201 use CPANPLUS::Error;
  2         18813  
  2         130  
16              
17 2     2   14 use Cwd qw();
  2         4  
  2         38  
18 2     2   506 use File::Spec::Functions qw(catdir catfile tmpdir);
  2         910  
  2         128  
19 2     2   1197 use IO::Compress::Gzip qw();
  2         69306  
  2         69  
20 2     2   686 use IPC::Cmd qw(can_run);
  2         45625  
  2         128  
21 2     2   18 use Locale::Maketext::Simple ( Style => 'gettext' );
  2         7  
  2         15  
22              
23             my $file_cmd = can_run('file');
24             my $strip_cmd = can_run('strip');
25              
26             sub run {
27 1     1 1 4 my ( $cmd, $param_ref ) = @_;
28              
29 1         2 my $dir = $param_ref->{dir};
30 1         3 my $verbose = $param_ref->{verbose};
31 1         2 my $buf_ref = $param_ref->{buffer};
32 1 50       4 if ( !$buf_ref ) {
33 1         2 my $buf;
34 1         3 $buf_ref = \$buf;
35             }
36              
37 1         2 my $orig_dir;
38 1 50       3 if ($dir) {
39 1         4199 $orig_dir = Cwd::cwd();
40 1 50       54 if ( !chdir($dir) ) {
41 0         0 return;
42             }
43             }
44              
45 1         8 my $fail = 0;
46 1 50       49 if (!IPC::Cmd::run(
47             command => $cmd,
48             buffer => $buf_ref,
49             verbose => $verbose
50             )
51             )
52             {
53 0         0 my $cmdline = join q{ }, @{$cmd};
  0         0  
54 0         0 error( loc( q{Could not run '%1': %2}, $cmdline, ${$buf_ref} ) );
  0         0  
55 0         0 ++$fail;
56             }
57              
58 1 50       24423 if ($orig_dir) {
59 1 50       37 if ( !chdir($orig_dir) ) {
60 0         0 ++$fail;
61             }
62             }
63              
64 1 50       44 return ( $fail ? 0 : 1 );
65             }
66              
67             sub slurp {
68 1     1 1 3 my $filename = shift;
69              
70 1         2 my $fh;
71 1 50       42 if ( !open $fh, '<', $filename ) {
72 0         0 error( loc( q{Could not open file '%1': %2}, $filename, $OS_ERROR ) );
73 0         0 return;
74             }
75              
76 1         3 my $text = do { local $RS = undef; <$fh> };
  1         6  
  1         22  
77              
78 1 50       13 if ( !close $fh ) {
79 0         0 error(
80             loc( q{Could not close file '%1': %2}, $filename, $OS_ERROR ) );
81 0         0 return;
82             }
83              
84 1         10 return $text;
85             }
86              
87             sub spurt {
88 1     1 1 949 my ( $filename, @lines ) = @_;
89              
90 1 50       7 my $param_ref = ( ref $lines[0] eq 'HASH' ) ? shift @lines : {};
91 1 50       8 my $mode = ( $param_ref->{append} ) ? '>>' : '>';
92 1         3 my $binmode = $param_ref->{binmode};
93              
94 1         2 my $fh;
95 1 50       67 if ( !open $fh, $mode, $filename ) {
96 0         0 error(
97             loc( q{Could not create file '%1': %2}, $filename, $OS_ERROR ) );
98 0         0 return;
99             }
100              
101 1 50       5 if ($binmode) {
102 0 0       0 if ( !binmode $fh, $binmode ) {
103 0         0 error(
104             loc(q{Could not set binmode for file '%1' to '%2': %3},
105             $filename, $binmode, $OS_ERROR
106             )
107             );
108 0         0 return;
109             }
110             }
111              
112 1         2 my $fail = 0;
113 1 50       3 if ( !print {$fh} @lines ) {
  1         18  
114 0         0 error(
115             loc( q{Could not write to file '%1': %2}, $filename, $OS_ERROR )
116             );
117 0         0 ++$fail;
118             }
119              
120 1 50       46 if ( !close $fh ) {
121 0         0 error(
122             loc( q{Could not close file '%1': %2}, $filename, $OS_ERROR ) );
123 0         0 ++$fail;
124             }
125              
126 1 50       16 return ( $fail ? 0 : 1 );
127             }
128              
129             sub filetype {
130 1     1 1 477 my $filename = shift;
131              
132 1         2 my $type;
133 1 50       6 if ($file_cmd) {
134 0         0 my $cmd = [ $file_cmd, '-b', $filename ];
135 0 0       0 if ( !run( $cmd, { buffer => \$type } ) ) {
136 0         0 undef $type;
137             }
138             }
139 1 50       5 if ($type) {
140 0         0 chomp $type;
141             }
142             else {
143 1         3 $type = 'data';
144             }
145 1         4 return $type;
146             }
147              
148             sub gzip {
149 1     1 1 3 my $filename = shift;
150              
151 1         5 my $gzname = "$filename.gz";
152 1 50       33 if ( -l $filename ) {
    50          
153 0         0 my $target = readlink $filename;
154 0 0       0 if ($target) {
155 0 0       0 if ( symlink "$target.gz", $gzname ) {
156 0         0 return $gzname;
157             }
158             }
159             }
160             elsif ( -f $filename ) {
161 1 50       9 if ( IO::Compress::Gzip::gzip( $filename, $gzname ) ) {
162 1         3048 return $gzname;
163             }
164             }
165 0           return;
166             }
167              
168             sub strip {
169 0     0 1   my (@filenames) = @_;
170              
171 0 0         return 1 if !$strip_cmd;
172              
173 0           my $cmd = [ $strip_cmd, '--strip-unneeded', @filenames ];
174 0           return run($cmd);
175             }
176              
177             1;
178             __END__