File Coverage

blib/lib/No/Worries/Dir.pm
Criterion Covered Total %
statement 56 56 100.0
branch 25 32 78.1
condition 5 6 83.3
subroutine 14 14 100.0
pod 6 6 100.0
total 106 114 92.9


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: No/Worries/Dir.pm #
4             # #
5             # Description: directory handling without worries #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package No::Worries::Dir;
14 16     16   205842 use strict;
  16         38  
  16         416  
15 16     16   62 use warnings;
  16         30  
  16         1161  
16             our $VERSION = "1.6";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 1.16 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 16     16   749 use No::Worries qw($_IntegerRegexp);
  16         39  
  16         86  
24 16     16   807 use No::Worries::Die qw(dief);
  16         21  
  16         68  
25 16     16   93 use No::Worries::Export qw(export_control);
  16         19  
  16         78  
26 16     16   84 use Params::Validate qw(validate :types);
  16         40  
  16         13794  
27              
28             #
29             # change the working directory
30             #
31              
32             sub dir_change ($) {
33 2     2 1 1492 my($path) = @_;
34              
35 2 50       26 chdir($path) or dief("cannot chdir(%s): %s", $path, $!);
36             }
37              
38             #
39             # ensure that a directory exists
40             #
41              
42             # really make a directory, recursively
43              
44             sub _mkdir ($$);
45             sub _mkdir ($$) {
46 3     3   11 my($path, $mode) = @_;
47              
48 3 100 100     39 if ($path =~ m{^(.+)/[^/]+$} and not -d $1) {
49 1         5 _mkdir($1, $mode);
50             }
51 3 50       182 mkdir($path, $mode)
52             or dief("cannot mkdir(%s, %04o): %s", $path, $mode, $!);
53             }
54              
55             # public interface
56              
57             my %dir_ensure_options = (
58             mode => { optional => 1, type => SCALAR, regex => $_IntegerRegexp },
59             );
60              
61             sub dir_ensure ($@) {
62 4     4 1 19763 my($path, %option);
63              
64 4         11 $path = shift(@_);
65 4 50       12 %option = validate(@_, \%dir_ensure_options) if @_;
66 4 50       15 $option{mode} = oct(777) unless defined($option{mode});
67 4         14 $path =~ s{/+$}{};
68 4 100 66     100 _mkdir($path, $option{mode}) unless $path eq "" or -d $path;
69             }
70              
71             #
72             # make a directory
73             #
74              
75             my %dir_make_options = (
76             mode => { optional => 1, type => SCALAR, regex => $_IntegerRegexp },
77             );
78              
79             sub dir_make ($@) {
80 3     3 1 1258 my($path, %option);
81              
82 3         7 $path = shift(@_);
83 3 100       34 %option = validate(@_, \%dir_make_options) if @_;
84 3 100       24 $option{mode} = oct(777) unless defined($option{mode});
85             mkdir($path, $option{mode})
86 3 100       111 or dief("cannot mkdir(%s, %04o): %s", $path, $option{mode}, $!);
87             }
88              
89             #
90             # return the parent directory of the given path
91             #
92              
93             sub dir_parent ($) {
94 13     13 1 5151 my($path) = @_;
95              
96 13 100       36 return(".") if $path eq "";
97 12         48 $path =~ s{/+$}{};
98 12 100       30 return("/") if $path eq "";
99 10         37 $path =~ s{[^/]+$}{};
100 10 100       27 return(".") if $path eq "";
101 8         18 $path =~ s{/+$}{};
102 8 100       21 return("/") if $path eq "";
103 6         21 return($path);
104             }
105              
106             #
107             # read a directory
108             #
109              
110             sub dir_read ($) {
111 2     2 1 1194 my($path) = @_;
112 2         7 my($dh, @list);
113              
114 2 50       77 opendir($dh, $path) or dief("cannot opendir(%s): %s", $path, $!);
115 2         70 @list = grep($_ !~ /^\.\.?$/, readdir($dh));
116 2 50       43 closedir($dh) or dief("cannot closedir(%s): %s", $path, $!);
117 2         15 return(@list);
118             }
119              
120             #
121             # remove a directory
122             #
123              
124             sub dir_remove ($) {
125 3     3 1 1744 my($path) = @_;
126              
127 3 50       145 rmdir($path) or dief("cannot rmdir(%s): %s", $path, $!);
128             }
129              
130             #
131             # export control
132             #
133              
134             sub import : method {
135 32     32   75 my($pkg, %exported);
136              
137 32         61 $pkg = shift(@_);
138 32         260 grep($exported{$_}++,
139             map("dir_$_", qw(change ensure make parent read remove)));
140 32         133 export_control(scalar(caller()), $pkg, \%exported, @_);
141             }
142              
143             1;
144              
145             __DATA__