File Coverage

blib/lib/MDK/Common/File.pm
Criterion Covered Total %
statement 6 198 3.0
branch 0 124 0.0
condition 0 43 0.0
subroutine 2 34 5.8
pod 29 32 90.6
total 37 431 8.5


line stmt bran cond sub pod time code
1             package MDK::Common::File;
2              
3             =head1 NAME
4              
5             MDK::Common::File - miscellaneous file/filename manipulation functions
6              
7             =head1 SYNOPSIS
8              
9             use MDK::Common::File qw(:all);
10              
11             =head1 EXPORTS
12              
13             =over
14              
15             =item dirname(FILENAME)
16              
17             =item basename(FILENAME)
18              
19             returns the dirname/basename of the file name
20              
21             =item cat_(FILES)
22              
23             returns the files contents: in scalar context it returns a single string, in
24             array context it returns the lines.
25              
26             If no file is found, undef is returned
27              
28             =item cat_or_die(FILENAME)
29              
30             same as C but dies when something goes wrong
31              
32             =item cat_utf8(FILES)
33              
34             same as C() but reads utf8 encoded strings
35              
36             =item cat_utf8_or_die(FILES)
37              
38             same as C() but reads utf8 encoded strings
39              
40             =item cat__(FILEHANDLE REF)
41              
42             returns the file content: in scalar context it returns a single string, in
43             array context it returns the lines
44              
45             =item output(FILENAME, LIST)
46              
47             creates a file and outputs the list (if the file exists, it is clobbered)
48              
49             =item output_utf8(FILENAME, LIST)
50              
51             same as C() but writes utf8 encoded strings
52              
53             =item secured_output(FILENAME, LIST)
54              
55             likes output() but prevents insecured usage (it dies if somebody try
56             to exploit the race window between unlink() and creat())
57              
58             =item append_to_file(FILENAME, LIST)
59              
60             add the LIST at the end of the file
61              
62             =item output_p(FILENAME, LIST)
63              
64             just like C but creates directories if needed
65              
66             =item output_with_perm(FILENAME, PERMISSION, LIST)
67              
68             same as C but sets FILENAME permission to PERMISSION (using chmod)
69              
70             =item mkdir_p(DIRNAME)
71              
72             creates the directory (make parent directories as needed)
73              
74             =item rm_rf(FILES)
75              
76             remove the files (including sub-directories)
77              
78             =item cp_f(FILES, DEST)
79              
80             just like "cp -f"
81              
82             =item cp_af(FILES, DEST)
83              
84             just like "cp -af"
85              
86             =item cp_afx(FILES, DEST)
87              
88             just like "cp -afx"
89              
90             =item linkf(SOURCE, DESTINATION)
91              
92             =item symlinkf(SOURCE, DESTINATION)
93              
94             =item renamef(SOURCE, DESTINATION)
95              
96             same as link/symlink/rename but removes the destination file first
97              
98             =item touch(FILENAME)
99              
100             ensure the file exists, set the modification time to current time
101              
102             =item all(DIRNAME)
103              
104             returns all the file in directory (except "." and "..")
105              
106             =item all_files_rec(DIRNAME)
107              
108             returns all the files in directory and the sub-directories (except "." and "..")
109              
110             =item glob_(STRING)
111              
112             simple version of C: doesn't handle wildcards in directory (eg:
113             */foo.c), nor special constructs (eg: [0-9] or {a,b})
114              
115             =item substInFile { CODE } FILENAME
116              
117             executes the code for each line of the file. You can know the end of the file
118             is reached using C
119              
120             =item expand_symlinks(FILENAME)
121              
122             expand the symlinks in the absolute filename:
123             C gives "/usr/bin/Xorg"
124              
125             =item openFileMaybeCompressed(FILENAME)
126              
127             opens the file and returns the file handle. If the file is not found, tries to
128             gunzip the file + .gz
129              
130             =item catMaybeCompressed(FILENAME)
131              
132             cat_ alike. If the file is not found, tries to gunzip the file + .gz
133              
134             =back
135              
136             =head1 SEE ALSO
137              
138             L
139              
140             =cut
141              
142 1     1   378 use File::Sync qw(fsync);
  1         4574  
  1         90  
143              
144 1     1   11 use Exporter;
  1         3  
  1         4060  
145             our @ISA = qw(Exporter);
146             our @EXPORT_OK = qw(dirname basename cat_ cat_utf8 cat_or_die cat_utf8_or_die cat__ output output_p output_with_perm append_to_file linkf symlinkf renamef mkdir_p rm_rf cp_f cp_af cp_afx touch all all_files_rec glob_ substInFile expand_symlinks openFileMaybeCompressed catMaybeCompressed);
147             our %EXPORT_TAGS = (all => [ @EXPORT_OK ]);
148              
149 0 0   0 1   sub dirname { local $_ = shift; s|[^/]*/*\s*$||; s|(.)/*$|$1|; $_ || '.' }
  0            
  0            
  0            
150 0     0 1   sub basename { local $_ = shift; s|/*\s*$||; s|.*/||; $_ }
  0            
  0            
  0            
151 0 0   0 1   sub cat_ { my @l = map { my $F; open($F, '<', $_) ? <$F> : () } @_; wantarray() ? @l : join '', @l }
  0 0          
  0            
  0            
152 0 0   0 1   sub cat_utf8 { my @l = map { my $F; open($F, '<:utf8', $_) ? <$F> : () } @_; wantarray() ? @l : join '', @l }
  0 0          
  0            
  0            
153 0 0   0 1   sub cat_or_die { open(my $F, '<', $_[0]) or die "can't read file $_[0]: $!\n"; my @l = <$F>; wantarray() ? @l : join '', @l }
  0 0          
  0            
154 0 0   0 1   sub cat_utf8_or_die { open(my $F, '<:utf8', $_[0]) or die "can't read file $_[0]: $!\n"; my @l = <$F>; wantarray() ? @l : join '', @l }
  0 0          
  0            
155 0 0   0 1   sub cat__ { my ($f) = @_; my @l = <$f>; wantarray() ? @l : join '', @l }
  0            
  0            
156 0 0   0 1   sub output { my $f = shift; open(my $F, ">$f") or die "output in file $f failed: $!\n"; print $F $_ foreach @_; fsync($F); 1 }
  0            
  0            
  0            
  0            
157 0 0   0 1   sub output_utf8 { my $f = shift; open(my $F, '>:utf8', $f) or die "output in file $f failed: $!\n"; print $F $_ foreach @_; fsync($F); 1 }
  0            
  0            
  0            
  0            
158 0 0   0 1   sub append_to_file { my $f = shift; open(my $F, ">>$f") or die "append to file $f failed: $!\n"; print $F $_ foreach @_; fsync($F); 1 }
  0            
  0            
  0            
  0            
159 0     0 1   sub output_p { my $f = shift; mkdir_p(dirname($f)); output($f, @_) }
  0            
  0            
160 0     0 1   sub output_with_perm { my ($f, $perm, @l) = @_; mkdir_p(dirname($f)); output($f, @l); chmod $perm, $f }
  0            
  0            
  0            
161 0     0 1   sub linkf { unlink $_[1]; link $_[0], $_[1] }
  0            
162 0     0 1   sub symlinkf { unlink $_[1]; symlink $_[0], $_[1] }
  0            
163 0     0 1   sub renamef { unlink $_[1]; rename $_[0], $_[1] }
  0            
164              
165             sub secured_output {
166 0     0 1   my ($f, @l) = @_;
167 0           require POSIX;
168 0           unlink($f);
169 0 0         sysopen(my $F, $f, POSIX::O_CREAT() | POSIX::O_EXCL() | POSIX::O_RDWR()) or die "secure output in file $f failed: $! $@\n";
170 0           print $F $_ foreach @l;
171 0           1;
172             }
173              
174             sub mkdir_p {
175 0     0 1   my ($dir) = @_;
176 0 0         if (-d $dir) {
    0          
177             # nothing to do
178             } elsif (-e $dir) {
179 0           die "mkdir: error creating directory $dir: $dir is a file and i won't delete it\n";
180             } else {
181 0           mkdir_p(dirname($dir));
182 0 0         mkdir($dir, 0755) or die "mkdir: error creating directory $dir: $!\n";
183             }
184 0           1;
185             }
186              
187             sub rm_rf {
188 0     0 1   foreach (@_) {
189 0 0 0       if (!-l $_ && -d $_) {
190 0           rm_rf(glob_($_));
191 0 0         rmdir($_) or die "can't remove directory $_: $!\n";
192             } else {
193 0 0         unlink $_ or die "rm of $_ failed: $!\n";
194             }
195             }
196 0           1;
197             }
198              
199             sub cp_with_option {
200 0     0 0   my $option = shift @_;
201 0           my $keep_special = $option =~ /a/;
202              
203 0           my $dest = pop @_;
204              
205 0 0         @_ or return;
206 0 0 0       @_ == 1 || -d $dest or die "cp: copying multiple files, but last argument ($dest) is not a directory\n";
207              
208 0           foreach my $src (@_) {
209 0           my $dest = $dest;
210 0 0         -d $dest and $dest .= '/' . basename($src);
211              
212 0           unlink $dest;
213              
214 0 0 0       if (-l $src && $keep_special) {
    0 0        
    0 0        
215 0 0 0       unless (symlink(readlink($src) || die("readlink failed: $!"), $dest)) {
216 0           warn "symlink: can't create symlink $dest: $!\n";
217             }
218             } elsif (-d $src) {
219 0 0 0       -d $dest or mkdir $dest, (stat($src))[2] or die "mkdir: can't create directory $dest: $!\n";
220 0           cp_with_option($option, glob_($src), $dest);
221             } elsif ((-b $src || -c $src || -S $src || -p $src) && $keep_special) {
222 0           my @stat = stat($src);
223 0           require MDK::Common::System;
224 0 0         MDK::Common::System::syscall_('mknod', $dest, $stat[2], $stat[6]) or die "mknod failed (dev $dest): $!";
225             } else {
226 0 0         open(my $F, $src) or die "can't open $src for reading: $!\n";
227 0 0         open(my $G, "> $dest") or die "can't cp to file $dest: $!\n";
228 0           local $_; while (<$F>) { print $G $_ }
  0            
  0            
229 0           chmod((stat($src))[2], $dest);
230             }
231             }
232 0           1;
233             }
234              
235             sub cp_same_filesystem_with_options {
236 0     0 0   my $rootdev = shift @_;
237 0           my $option = shift @_;
238 0           my $keep_special = $option =~ /a/;
239              
240 0           my $dest = pop @_;
241              
242 0 0         @_ or return;
243 0 0 0       @_ == 1 || -d $dest or die "cp: copying multiple files, but last argument ($dest) is not a directory\n";
244              
245 0           foreach my $src (@_) {
246             # detect original file system
247 0 0         if ($rootdev == -1) {
248 0           my @stat = stat($src);
249 0           $rootdev = $stat[0];
250             }
251              
252 0           my $dest = $dest;
253 0 0         -d $dest and $dest .= '/' . basename($src);
254              
255 0           unlink $dest;
256              
257 0 0 0       if (-l $src && $keep_special) {
    0 0        
    0 0        
258 0 0 0       unless (symlink(readlink($src) || die("readlink failed: $!"), $dest)) {
259 0           warn "symlink: can't create symlink $dest: $!\n";
260             }
261             } elsif (-d $src) {
262 0 0 0       -d $dest or mkdir $dest, (stat($src))[2] or die "mkdir: can't create directory $dest: $!\n";
263 0           cp_same_filesystem_with_options($rootdev, $option, glob_($src), $dest);
264             } elsif ((-b $src || -c $src || -S $src || -p $src) && $keep_special) {
265 0           my @stat = stat($src);
266 0           require MDK::Common::System;
267 0 0         MDK::Common::System::syscall_('mknod', $dest, $stat[2], $stat[6]) or die "mknod failed (dev $dest): $!";
268             } else {
269 0           my @stat = stat($src);
270 0 0         if ($stat[0] != $rootdev) {
271 0           next;
272             }
273 0 0         open(my $F, $src) or die "can't open $src for reading: $!\n";
274 0 0         open(my $G, "> $dest") or die "can't cp to file $dest: $!\n";
275 0           local $_; while (<$F>) { print $G $_ }
  0            
  0            
276 0           chmod((stat($src))[2], $dest);
277             }
278             }
279 0           1;
280             }
281              
282 0     0 1   sub cp_f { cp_with_option('f', @_) }
283 0     0 1   sub cp_af { cp_with_option('af', @_) }
284 0     0 1   sub cp_afx { cp_same_filesystem_with_options(-1, 'af', @_) }
285              
286             sub touch {
287 0     0 1   my ($f) = @_;
288 0 0         unless (-e $f) {
289 0           my $F;
290 0           open($F, ">$f");
291             }
292 0           my $now = time();
293 0           utime $now, $now, $f;
294             }
295              
296              
297             sub all {
298 0     0 1   my $d = shift;
299              
300 0           local *F;
301 0 0         opendir F, $d or return;
302 0 0         my @l = grep { $_ ne '.' && $_ ne '..' } readdir F;
  0            
303 0           closedir F;
304              
305 0           @l;
306             }
307              
308             sub all_files_rec {
309 0     0 1   my ($d) = @_;
310              
311 0 0         map { $_, -d $_ ? all_files_rec($_) : () } map { "$d/$_" } all($d);
  0            
  0            
312             }
313              
314             sub glob_ {
315 0 0   0 1   my ($d, $f) = $_[0] =~ /\*/ ? (dirname($_[0]), basename($_[0])) : ($_[0], '*');
316              
317 0 0         $d =~ /\*/ and die "glob_: wildcard in directory not handled ($_[0])\n";
318 0           ($f = quotemeta $f) =~ s/\\\*/.*/g;
319              
320 0 0         $d =~ m|/$| or $d .= '/';
321 0 0         map { $d eq './' ? $_ : "$d$_" } grep { /^$f$/ } all($d);
  0            
  0            
322             }
323              
324              
325             sub substInFile(&@) {
326 0     0 1   my ($f, $file) = @_;
327             #FIXME we should follow symlinks, and fail in case of loop
328 0 0         if (-l $file) {
329 0           my $targetfile = readlink $file;
330 0           $file = $targetfile;
331             }
332 0 0         if (-s $file) {
333 0           local @ARGV = $file;
334 0           local $^I = '.bak';
335 0           local $_;
336 0           while (<>) {
337 0 0 0       $_ .= "\n" if eof && !/\n/;
338 0           &$f($_);
339 0           print;
340             }
341 0           open(my $F, $file);
342 0           fsync($F);
343 0           unlink "$file$^I"; # remove old backup now that we have closed new file
344             } else {
345             #- special handling for zero-sized or nonexistent files
346             #- because while (<>) will not do any iteration
347 0 0         open(my $F, "+> $file") or return;
348             #- "eof" without an argument uses the last file read
349 0           my $dummy = <$F>;
350 0           local $_ = '';
351 0           &$f($_);
352 0           print $F $_;
353 0           fsync($F);
354             }
355             }
356              
357              
358             sub concat_symlink {
359 0     0 0   my ($f, $l) = @_;
360 0 0         $l =~ m|^\.\./(/.*)| and return $1;
361              
362 0           $f =~ s|/$||;
363 0           while ($l =~ s|^\.\./||) {
364 0 0         $f =~ s|/[^/]+$|| or die "concat_symlink: $f $l\n";
365             }
366 0           "$f/$l";
367             }
368             sub expand_symlinks {
369 0     0 1   my ($first, @l) = split '/', $_[0];
370 0 0         $first eq '' or die "expand_symlinks: $_[0] is relative\n";
371 0           my ($f, $l);
372 0           foreach (@l) {
373 0           $f .= "/$_";
374 0           $f = concat_symlink($f, "../$l") while $l = readlink $f;
375             }
376 0           $f;
377             }
378              
379              
380             sub openFileMaybeCompressed {
381 0     0 1   my ($f) = @_;
382 0 0 0       -e $f || -e "$f.gz" or die "file $f not found";
383 0 0         open(my $F, -e $f ? $f : "gzip -dc '$f.gz'|") or die "file $f is not readable";
    0          
384 0           $F;
385             }
386 0     0 1   sub catMaybeCompressed { cat__(openFileMaybeCompressed($_[0])) }
387              
388             1;