File Coverage

blib/lib/No/Worries/File.pm
Criterion Covered Total %
statement 105 123 85.3
branch 34 66 51.5
condition 2 6 33.3
subroutine 14 15 93.3
pod 3 3 100.0
total 158 213 74.1


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: No/Worries/File.pm #
4             # #
5             # Description: file handling without worries #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package No::Worries::File;
14 15     15   1117798 use strict;
  15         152  
  15         473  
15 15     15   75 use warnings;
  15         33  
  15         1168  
16             our $VERSION = "1.7";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 1.19 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 15     15   5213 use No::Worries qw($_IntegerRegexp);
  15         32  
  15         77  
24 15     15   6676 use No::Worries::Die qw(dief);
  15         42  
  15         95  
25 15     15   6187 use No::Worries::Dir qw(dir_ensure dir_parent);
  15         35  
  15         121  
26 15     15   106 use No::Worries::Export qw(export_control);
  15         29  
  15         76  
27 15     15   7896 use No::Worries::Proc qw(proc_run);
  15         59  
  15         107  
28 15     15   117 use Params::Validate qw(validate :types);
  15         32  
  15         22570  
29              
30             #
31             # global variables
32             #
33              
34             our($DefaultBufSize);
35              
36             #
37             # open() helper
38             #
39              
40             sub _open ($$$) {
41 48     48   306 my($path, $mode, $opt) = @_;
42 48         106 my($fh);
43              
44 48 100       170 return($opt->{handle}) if $opt->{handle};
45             ## no critic 'InputOutput::RequireBriefOpen'
46 46 100       4818 open($fh, $mode, $path) or dief("cannot open(%s): %s", $path, $!);
47 45 100       444 if ($opt->{binmode}) {
    100          
48             binmode($fh, $opt->{binmode})
49 2 50       17 or dief("cannot binmode(%s, %s): %s", $path, $opt->{binmode}, $!);
50             } elsif ($opt->{binary}) {
51 2 50       13 binmode($fh)
52             or dief("cannot binmode(%s): %s", $path, $!);
53             }
54 45         190 return($fh);
55             }
56              
57             #
58             # sysread() helper
59             #
60              
61             sub _read ($$$$) {
62 22     22   150 my($path, $fh, $data, $bufsize) = @_;
63 22         51 my($done, $ref, $result);
64              
65 22         69 $done = -1;
66 22 100       201 $ref = $data ? ref($data) : "";
67 22 100       139 if ($ref eq "SCALAR") {
    100          
68             # by reference
69 1         4 ${ $data } = "";
  1         2  
70 1         5 while ($done) {
71 2         4 $done = sysread($fh, ${ $data }, $bufsize, length(${ $data }));
  2         4  
  2         28  
72 2 50       10 dief("cannot sysread(%s): %s", $path, $!)
73             unless defined($done);
74             }
75 1         4 $result = $data;
76             } elsif ($ref eq "CODE") {
77             # by code
78 1         5 while ($done) {
79 2         8 $result = "";
80 2         21 $done = sysread($fh, $result, $bufsize);
81 2 50       8 dief("cannot sysread(%s): %s", $path, $!)
82             unless defined($done);
83 2 100       9 $data->($result) if $done;
84             }
85 1         5 $result = $data->("");
86             } else {
87             # normal
88 20         78 $result = "";
89 20         70 while ($done) {
90 39         1071 $done = sysread($fh, $result, $bufsize, length($result));
91 39 50       289 dief("cannot sysread(%s): %s", $path, $!)
92             unless defined($done);
93             }
94             }
95 22         87 return(\$result);
96             }
97              
98             #
99             # syswrite() helper
100             #
101              
102             sub _write ($$$$) {
103 25     25   107 my($path, $fh, $data, $bufsize) = @_;
104 25         62 my($ref, $offset, $length, $done, $chunk);
105              
106 25         47 $offset = 0;
107 25         60 $ref = ref($data);
108 25 100       118 if ($ref eq "SCALAR") {
    100          
109             # by reference
110 2         6 $length = length(${ $data });
  2         9  
111 2         7 while ($length) {
112 2         4 $done = syswrite($fh, ${ $data }, $bufsize, $offset);
  2         52  
113 2 50       14 dief("cannot syswrite(%s): %s", $path, $!)
114             unless defined($done);
115 2         5 $length -= $done;
116 2         7 $offset += $done;
117             }
118             } elsif ($ref eq "CODE") {
119             # by code
120 1         3 while (1) {
121 4         10 $chunk = $data->();
122 4         29 $length = length($chunk);
123 4 100       11 last unless $length;
124 3         5 $offset = 0;
125 3         6 while ($length) {
126 3         53 $done = syswrite($fh, $chunk, $bufsize, $offset);
127 3 50       12 dief("cannot syswrite(%s): %s", $path, $!)
128             unless defined($done);
129 3         6 $length -= $done;
130 3         8 $offset += $done;
131             }
132             }
133             } else {
134             # normal
135 22         42 $length = length($data);
136 22         82 while ($length) {
137 21         1013 $done = syswrite($fh, $data, $bufsize, $offset);
138 21 50       217 dief("cannot syswrite(%s): %s", $path, $!)
139             unless defined($done);
140 21         64 $length -= $done;
141 21         91 $offset += $done;
142             }
143             }
144             }
145              
146             #
147             # common read/write options
148             #
149              
150             my %file_rw_options = (
151             binary => { optional => 1, type => BOOLEAN },
152             binmode => { optional => 1, type => SCALAR },
153             bufsize => { optional => 1, type => SCALAR, regex => $_IntegerRegexp },
154             handle => { optional => 1, type => HANDLE },
155             );
156              
157             #
158             # read from a file
159             #
160              
161             my %file_read_options = (%file_rw_options,
162             data => { optional => 1, type => SCALARREF | CODEREF },
163             );
164              
165             sub file_read ($@) {
166 23     23 1 21850 my($path, %option, $fh, $result);
167              
168 23         98 $path = shift(@_);
169 23 100       248 %option = validate(@_, \%file_read_options) if @_;
170 23   33     311 $option{bufsize} ||= $DefaultBufSize;
171 23         219 $fh = _open($path, "<", \%option);
172 22         243 $result = _read($path, $fh, $option{data}, $option{bufsize});
173 22 50       416 close($fh) or dief("cannot close(%s): %s", $path, $!);
174 22         75 return(${ $result });
  22         613  
175             }
176              
177             #
178             # write to a file
179             #
180              
181             my %file_write_options = (%file_rw_options,
182             data => { optional => 0, type => SCALAR | SCALARREF | CODEREF },
183             );
184              
185             sub file_write ($@) {
186 25     25 1 44479 my($path, %option, $fh);
187              
188 25         90 $path = shift(@_);
189 25         994 %option = validate(@_, \%file_write_options);
190 25   33     335 $option{bufsize} ||= $DefaultBufSize;
191 25         137 $fh = _open($path, ">", \%option);
192 25         177 _write($path, $fh, $option{data}, $option{bufsize});
193 25 50       784 close($fh) or dief("cannot close(%s): %s", $path, $!);
194             }
195              
196             #
197             # update a file (high level wrapper for text files)
198             #
199              
200             my %file_update_options = (
201             data => { optional => 0, type => SCALAR },
202             diff => { optional => 1, type => BOOLEAN },
203             noaction => { optional => 1, type => BOOLEAN },
204             silent => { optional => 1, type => BOOLEAN },
205             );
206              
207             sub file_update ($@) {
208 0     0 1 0 my($path, %option, $data, $fh);
209              
210 0         0 $path = shift(@_);
211 0         0 %option = validate(@_, \%file_update_options);
212 0 0       0 if (-f $path) {
213 0         0 $data = file_read($path);
214 0 0       0 if ($data eq $option{data}) {
215             printf("did not update %s (already up-to-date)\n", $path)
216 0 0       0 unless $option{silent};
217             } else {
218             proc_run(
219             command => [ qw(diff -u), $path, "-" ],
220             stdin => \$option{data},
221 0 0       0 ) if $option{diff};
222 0 0       0 if ($option{noaction}) {
223             printf("did not update %s (noaction)\n", $path)
224 0 0       0 unless $option{silent};
225             } else {
226 0         0 file_write($path, data => $option{data});
227             printf("updated %s\n", $path)
228 0 0       0 unless $option{silent};
229             }
230             }
231             } else {
232             proc_run(
233             command => [ qw(diff -u /dev/null), "-" ],
234             stdin => \$option{data},
235 0 0       0 ) if $option{diff};
236 0 0       0 if ($option{noaction}) {
237             printf("did not create %s (noaction)\n", $path)
238 0 0       0 unless $option{silent};
239             } else {
240 0         0 dir_ensure(dir_parent($path));
241 0         0 file_write($path, data => $option{data});
242             printf("created %s\n", $path)
243 0 0       0 unless $option{silent};
244             }
245             }
246             }
247              
248             #
249             # module initialization
250             #
251              
252             $DefaultBufSize = 1_048_576; # 1MB
253              
254             #
255             # export control
256             #
257              
258             sub import : method {
259 15     15   138 my($pkg, %exported);
260              
261 15         42 $pkg = shift(@_);
262 15         131 grep($exported{$_}++, map("file_$_", qw(read write update)));
263 15         114 export_control(scalar(caller()), $pkg, \%exported, @_);
264             }
265              
266             1;
267              
268             __DATA__