| line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
|
1
|
|
|
|
|
|
|
# File::Takeput.pm |
|
2
|
|
|
|
|
|
|
# Slurp style file IO with locking. |
|
3
|
|
|
|
|
|
|
# (c) 2023 Bjørn Hee |
|
4
|
|
|
|
|
|
|
# Licensed under the Apache License, version 2.0 |
|
5
|
|
|
|
|
|
|
# https://www.apache.org/licenses/LICENSE-2.0.txt |
|
6
|
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
package File::Takeput; |
|
8
|
|
|
|
|
|
|
|
|
9
|
6
|
|
|
6
|
|
1957681
|
use strict; |
|
|
6
|
|
|
|
|
13
|
|
|
|
6
|
|
|
|
|
289
|
|
|
10
|
6
|
|
|
6
|
|
36
|
use experimental qw(signatures); |
|
|
6
|
|
|
|
|
14
|
|
|
|
6
|
|
|
|
|
55
|
|
|
11
|
|
|
|
|
|
|
# use Exporter qw(import); |
|
12
|
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
our $VERSION = 0.30; |
|
14
|
|
|
|
|
|
|
|
|
15
|
6
|
|
|
6
|
|
1220
|
use Scalar::Util qw(reftype); # Later builtin::reftype |
|
|
6
|
|
|
|
|
31
|
|
|
|
6
|
|
|
|
|
488
|
|
|
16
|
6
|
|
|
6
|
|
84
|
use Fcntl qw(O_CREAT O_RDONLY O_RDWR O_WRONLY O_EXCL :flock); |
|
|
6
|
|
|
|
|
47
|
|
|
|
6
|
|
|
|
|
1406
|
|
|
17
|
6
|
|
|
6
|
|
50
|
use File::Basename qw(basename dirname); |
|
|
6
|
|
|
|
|
14
|
|
|
|
6
|
|
|
|
|
481
|
|
|
18
|
6
|
|
|
6
|
|
42
|
use Cwd qw(abs_path); |
|
|
6
|
|
|
|
|
8
|
|
|
|
6
|
|
|
|
|
431
|
|
|
19
|
6
|
|
|
6
|
|
37
|
use if $^O eq 'MSWin32' , 'File::Takeput::Win32'; |
|
|
6
|
|
|
|
|
10
|
|
|
|
6
|
|
|
|
|
396
|
|
|
20
|
6
|
|
|
6
|
|
43
|
use if $^O ne 'MSWin32' , 'File::Takeput::Unix'; |
|
|
6
|
|
|
|
|
15
|
|
|
|
6
|
|
|
|
|
3272
|
|
|
21
|
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
my sub qwac( $s ) {grep{/./} map{split /\s+/} map{s/#.*//r} split/\v+/ , $s;}; |
|
23
|
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
our @EXPORT = qwac ' |
|
25
|
|
|
|
|
|
|
append # Append content to file. |
|
26
|
|
|
|
|
|
|
grab # Read file content. |
|
27
|
|
|
|
|
|
|
pass # Release the locks of a taken file. |
|
28
|
|
|
|
|
|
|
plunk # Overwrite file with content. |
|
29
|
|
|
|
|
|
|
put # Write to a taken file and release locks. |
|
30
|
|
|
|
|
|
|
take # Take locks and read file content. |
|
31
|
|
|
|
|
|
|
'; |
|
32
|
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
our @EXPORT_OK = qwac ' |
|
34
|
|
|
|
|
|
|
fgrab # Functional version of grab. |
|
35
|
|
|
|
|
|
|
fpass # Functional version of pass. |
|
36
|
|
|
|
|
|
|
ftake # Functional version of take. |
|
37
|
|
|
|
|
|
|
reset # Reset default values. |
|
38
|
|
|
|
|
|
|
set # Set default values. |
|
39
|
|
|
|
|
|
|
'; |
|
40
|
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
# ------------------------------------------------------------------------- # |
|
42
|
|
|
|
|
|
|
# Globals and defaults. |
|
43
|
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
my $default = { |
|
45
|
|
|
|
|
|
|
'File::Takeput' => { |
|
46
|
|
|
|
|
|
|
create => undef , |
|
47
|
|
|
|
|
|
|
error => undef , |
|
48
|
|
|
|
|
|
|
flatten => undef , |
|
49
|
|
|
|
|
|
|
exclusive => undef , |
|
50
|
|
|
|
|
|
|
newline => undef , |
|
51
|
|
|
|
|
|
|
patience => 0 , |
|
52
|
|
|
|
|
|
|
separator => $/ , |
|
53
|
|
|
|
|
|
|
unique => undef , |
|
54
|
|
|
|
|
|
|
} , |
|
55
|
|
|
|
|
|
|
}; |
|
56
|
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
my %imfh = (); # Hash for holding implicit filehandles. |
|
58
|
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # |
|
60
|
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
my $errh_msg; |
|
62
|
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
my sub advice( $msg ) { |
|
64
|
|
|
|
|
|
|
# Give an error advice (a warning pointing to the caller). |
|
65
|
|
|
|
|
|
|
my ($prog,$lno); |
|
66
|
|
|
|
|
|
|
my $i = 0; |
|
67
|
|
|
|
|
|
|
while (1) { |
|
68
|
|
|
|
|
|
|
(my $nsp,$prog,$lno) = (caller($i))[0,1,2] or last; |
|
69
|
|
|
|
|
|
|
last if $nsp !~ m/^File::Takeput(::.+)?$/n; |
|
70
|
|
|
|
|
|
|
$i++; |
|
71
|
|
|
|
|
|
|
}; |
|
72
|
|
|
|
|
|
|
print STDERR $msg; |
|
73
|
|
|
|
|
|
|
print STDERR ' at '.$prog if defined $prog; |
|
74
|
|
|
|
|
|
|
print STDERR ' line '.$lno if defined $lno; |
|
75
|
|
|
|
|
|
|
print STDERR '.'; |
|
76
|
|
|
|
|
|
|
}; |
|
77
|
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
|
|
79
|
6
|
|
|
6
|
|
10
|
my sub errah( $msg , $s ) { |
|
|
6
|
|
|
|
|
11
|
|
|
|
6
|
|
|
|
|
10
|
|
|
|
6
|
|
|
|
|
8
|
|
|
80
|
|
|
|
|
|
|
# Error advice and handling. |
|
81
|
6
|
50
|
|
|
|
21
|
$msg .= $errh_msg if $errh_msg; |
|
82
|
6
|
|
|
|
|
10
|
$errh_msg = undef; |
|
83
|
6
|
|
|
|
|
22
|
advice($msg.''); |
|
84
|
6
|
|
|
|
|
13
|
$@ = $msg; |
|
85
|
6
|
50
|
|
|
|
19
|
return $s->{error}->() if defined $s->{error}; |
|
86
|
6
|
|
|
|
|
43
|
return; |
|
87
|
|
|
|
|
|
|
}; |
|
88
|
|
|
|
|
|
|
|
|
89
|
|
|
|
|
|
|
|
|
90
|
29
|
|
|
29
|
|
48
|
my sub errh( $msg , $s = undef ) { |
|
|
29
|
|
|
|
|
53
|
|
|
|
29
|
|
|
|
|
45
|
|
|
|
29
|
|
|
|
|
65
|
|
|
91
|
|
|
|
|
|
|
# Error handler. |
|
92
|
29
|
100
|
|
|
|
69
|
if (defined $s) { # For calls coming into Takeput. |
|
93
|
14
|
100
|
|
|
|
43
|
$msg .= $errh_msg if $errh_msg; |
|
94
|
14
|
|
|
|
|
25
|
$errh_msg = undef; |
|
95
|
14
|
|
|
|
|
29
|
$@ = $msg; |
|
96
|
14
|
100
|
|
|
|
63
|
return $s->{error}->() if defined $s->{error}; |
|
97
|
|
|
|
|
|
|
} |
|
98
|
|
|
|
|
|
|
else { # For calls internal to Takeput. |
|
99
|
15
|
|
|
|
|
27
|
$errh_msg = $msg; |
|
100
|
|
|
|
|
|
|
}; |
|
101
|
26
|
|
|
|
|
169
|
return; |
|
102
|
|
|
|
|
|
|
}; |
|
103
|
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
|
|
105
|
0
|
|
|
0
|
|
0
|
my sub fatal_error( $msg ) { |
|
|
0
|
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
0
|
|
|
106
|
0
|
|
|
|
|
0
|
advice($msg.'--compilation aborted'); |
|
107
|
0
|
|
|
|
|
0
|
exit 1; |
|
108
|
|
|
|
|
|
|
}; |
|
109
|
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
|
|
111
|
57
|
|
|
57
|
|
114
|
my sub full_setting( $s , $d ) { |
|
|
57
|
|
|
|
|
100
|
|
|
|
57
|
|
|
|
|
84
|
|
|
|
57
|
|
|
|
|
82
|
|
|
112
|
|
|
|
|
|
|
# Check parameter values and provide a full setting. |
|
113
|
|
|
|
|
|
|
|
|
114
|
57
|
100
|
|
|
|
423
|
return {$d->%*} if not $s->%*; |
|
115
|
|
|
|
|
|
|
|
|
116
|
28
|
100
|
|
|
|
86
|
if (not exists $s->{create}) { |
|
117
|
20
|
|
|
|
|
107
|
$s->{create} = $d->{create}; |
|
118
|
|
|
|
|
|
|
}; |
|
119
|
|
|
|
|
|
|
|
|
120
|
28
|
100
|
|
|
|
79
|
if (exists $s->{error}) { |
|
121
|
8
|
100
|
|
|
|
28
|
if (defined $s->{error}) { |
|
122
|
|
|
|
|
|
|
return errh('"error" not a ref to a subroutine.') |
|
123
|
4
|
100
|
|
|
|
18
|
if reftype $s->{error} ne 'CODE'; |
|
124
|
|
|
|
|
|
|
}; |
|
125
|
|
|
|
|
|
|
} |
|
126
|
|
|
|
|
|
|
else { |
|
127
|
20
|
|
|
|
|
47
|
$s->{error} = $d->{error}; |
|
128
|
|
|
|
|
|
|
}; |
|
129
|
|
|
|
|
|
|
|
|
130
|
27
|
100
|
|
|
|
70
|
if (not exists $s->{flatten}) { |
|
131
|
22
|
|
|
|
|
48
|
$s->{flatten} = $d->{flatten}; |
|
132
|
|
|
|
|
|
|
}; |
|
133
|
|
|
|
|
|
|
|
|
134
|
27
|
100
|
|
|
|
69
|
if (not exists $s->{exclusive}) { |
|
135
|
23
|
|
|
|
|
48
|
$s->{exclusive} = $d->{exclusive}; |
|
136
|
|
|
|
|
|
|
}; |
|
137
|
|
|
|
|
|
|
|
|
138
|
27
|
100
|
|
|
|
73
|
if (not exists $s->{newline}) { |
|
139
|
19
|
|
|
|
|
42
|
$s->{newline} = $d->{newline}; |
|
140
|
|
|
|
|
|
|
}; |
|
141
|
|
|
|
|
|
|
|
|
142
|
27
|
100
|
|
|
|
72
|
if (exists $s->{patience}) { |
|
143
|
|
|
|
|
|
|
return errh('"patience" not defined.') |
|
144
|
7
|
50
|
|
|
|
39
|
if not defined $s->{patience}; |
|
145
|
|
|
|
|
|
|
return errh('"patience" not numerical.') |
|
146
|
7
|
100
|
|
|
|
72
|
if $s->{patience} !~ m/^(\d*\.)?\d+$/n; |
|
147
|
|
|
|
|
|
|
return errh('"patience" negative.') |
|
148
|
6
|
50
|
|
|
|
29
|
if $s->{patience} < 0; |
|
149
|
|
|
|
|
|
|
} |
|
150
|
|
|
|
|
|
|
else { |
|
151
|
20
|
|
|
|
|
51
|
$s->{patience} = $d->{patience}; |
|
152
|
|
|
|
|
|
|
}; |
|
153
|
|
|
|
|
|
|
|
|
154
|
26
|
100
|
|
|
|
61
|
if (exists $s->{separator}) { |
|
155
|
|
|
|
|
|
|
return errh('"separator" an empty string.') |
|
156
|
14
|
100
|
100
|
|
|
100
|
if defined $s->{separator} and $s->{separator} eq ''; |
|
157
|
|
|
|
|
|
|
} |
|
158
|
|
|
|
|
|
|
else { |
|
159
|
12
|
|
|
|
|
33
|
$s->{separator} = $d->{separator}; |
|
160
|
|
|
|
|
|
|
}; |
|
161
|
|
|
|
|
|
|
|
|
162
|
25
|
100
|
|
|
|
60
|
if (not exists $s->{unique}) { |
|
163
|
20
|
|
|
|
|
51
|
$s->{unique} = $d->{unique}; |
|
164
|
|
|
|
|
|
|
}; |
|
165
|
|
|
|
|
|
|
|
|
166
|
25
|
100
|
|
|
|
103
|
if (8 < keys $s->%*) { |
|
167
|
3
|
|
|
|
|
8
|
return errh('Invalid configuration parameter.'); |
|
168
|
|
|
|
|
|
|
}; |
|
169
|
|
|
|
|
|
|
|
|
170
|
22
|
|
|
|
|
82
|
return $s; |
|
171
|
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
}; # sub full_setting |
|
173
|
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # |
|
175
|
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
sub import( @implist ) { |
|
177
|
|
|
|
|
|
|
my $mynsp = shift @implist; |
|
178
|
|
|
|
|
|
|
my $nsp = caller; |
|
179
|
|
|
|
|
|
|
my %check; |
|
180
|
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
if (@implist) { |
|
182
|
|
|
|
|
|
|
%check = map {$_ => 1} qw( |
|
183
|
|
|
|
|
|
|
create error exclusive flatten newline patience separator unique |
|
184
|
|
|
|
|
|
|
); |
|
185
|
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
my $cpar = {}; |
|
187
|
|
|
|
|
|
|
my $i = 0; |
|
188
|
|
|
|
|
|
|
while ($i < @implist) { |
|
189
|
|
|
|
|
|
|
my $p = $implist[$i]; |
|
190
|
|
|
|
|
|
|
if ($check{$p}) { |
|
191
|
|
|
|
|
|
|
fatal_error('Takeput: No "'.$p.'" value.') |
|
192
|
|
|
|
|
|
|
if $i == $#implist; |
|
193
|
|
|
|
|
|
|
$cpar->{$p} = $implist[$i+1]; |
|
194
|
|
|
|
|
|
|
splice @implist , $i , 2; |
|
195
|
|
|
|
|
|
|
$i += -2; |
|
196
|
|
|
|
|
|
|
}; |
|
197
|
|
|
|
|
|
|
$i++; |
|
198
|
|
|
|
|
|
|
}; |
|
199
|
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
my $s = full_setting($cpar,$default->{'File::Takeput'}) |
|
201
|
|
|
|
|
|
|
or fatal_error('Takeput: '.$errh_msg); |
|
202
|
|
|
|
|
|
|
$default->{$nsp} = $s; |
|
203
|
|
|
|
|
|
|
} |
|
204
|
|
|
|
|
|
|
else { |
|
205
|
|
|
|
|
|
|
$default->{$nsp} = {$default->{'File::Takeput'}->%*}; |
|
206
|
|
|
|
|
|
|
}; |
|
207
|
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
my sub amp( $s ) { |
|
209
|
|
|
|
|
|
|
return undef if not defined $s; |
|
210
|
|
|
|
|
|
|
return $s =~ s/^([^\$\@\%\&])/\&$1/r; |
|
211
|
|
|
|
|
|
|
}; |
|
212
|
|
|
|
|
|
|
%check = map {(amp($_),1)} @EXPORT , @EXPORT_OK; |
|
213
|
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
@implist = @EXPORT if not @implist; |
|
215
|
|
|
|
|
|
|
while ($_ = amp shift @implist) { |
|
216
|
|
|
|
|
|
|
fatal_error('Takeput: "'.$_.'" not exported.') if not $check{$_}; |
|
217
|
6
|
|
|
6
|
|
71
|
no strict "refs"; |
|
|
6
|
|
|
|
|
12
|
|
|
|
6
|
|
|
|
|
2247
|
|
|
218
|
|
|
|
|
|
|
if ( m/^\$(.*)$/ ) { *{"${nsp}::$1"} = \$$1; } |
|
219
|
|
|
|
|
|
|
elsif ( m/^\@(.*)$/ ) { *{"${nsp}::$1"} = \@$1; } |
|
220
|
|
|
|
|
|
|
elsif ( m/^\%(.*)$/ ) { *{"${nsp}::$1"} = \%$1; } |
|
221
|
|
|
|
|
|
|
elsif ( m/^\&(.*)$/ ) { *{"${nsp}::$1"} = \&$1; }; |
|
222
|
6
|
|
|
6
|
|
78
|
use strict "refs"; |
|
|
6
|
|
|
|
|
14
|
|
|
|
6
|
|
|
|
|
22879
|
|
|
223
|
|
|
|
|
|
|
}; |
|
224
|
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
}; # sub import |
|
226
|
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # |
|
228
|
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
1; |
|
230
|
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# ------------------------------------------------------------------------- # |
|
232
|
|
|
|
|
|
|
# Private subroutines. |
|
233
|
|
|
|
|
|
|
|
|
234
|
43
|
|
|
43
|
|
68
|
my sub canonical( $fname ) { |
|
|
43
|
|
|
|
|
64
|
|
|
|
43
|
|
|
|
|
61
|
|
|
235
|
|
|
|
|
|
|
# Return a canonical filename. |
|
236
|
|
|
|
|
|
|
|
|
237
|
43
|
100
|
|
|
|
2715
|
return abs_path($fname) if -f $fname; |
|
238
|
8
|
|
|
|
|
483
|
my $dname = dirname $fname; |
|
239
|
8
|
50
|
|
|
|
199
|
return undef if not -d $dname; |
|
240
|
8
|
|
|
|
|
745
|
return abs_path($dname).'/'.basename($fname); |
|
241
|
|
|
|
|
|
|
}; |
|
242
|
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
|
|
244
|
35
|
|
|
35
|
|
62
|
my sub open_file( $cname , $oflag , $lflag , $p ) { |
|
|
35
|
|
|
|
|
52
|
|
|
|
35
|
|
|
|
|
72
|
|
|
|
35
|
|
|
|
|
51
|
|
|
|
35
|
|
|
|
|
62
|
|
|
|
35
|
|
|
|
|
54
|
|
|
245
|
|
|
|
|
|
|
# Open an implicit filehandle. |
|
246
|
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
return errh('Tried to open "'.$cname.'" twice.') |
|
248
|
35
|
100
|
|
|
|
145
|
if (exists $imfh{$cname}); |
|
249
|
|
|
|
|
|
|
|
|
250
|
29
|
|
|
|
|
1696
|
sysopen $imfh{$cname} , $cname , $oflag; |
|
251
|
|
|
|
|
|
|
|
|
252
|
29
|
100
|
|
|
|
182
|
$p = 0 if ($oflag&O_EXCL); |
|
253
|
|
|
|
|
|
|
|
|
254
|
29
|
100
|
|
|
|
125
|
if ( flock_take $imfh{$cname} , $lflag , $p ) { |
|
255
|
26
|
|
|
|
|
111
|
return 1; |
|
256
|
|
|
|
|
|
|
} |
|
257
|
|
|
|
|
|
|
else { |
|
258
|
3
|
|
|
|
|
10
|
close $imfh{$cname}; |
|
259
|
3
|
|
|
|
|
13
|
delete $imfh{$cname}; |
|
260
|
3
|
|
|
|
|
13
|
return errh('Not able to take lock for "'.$cname.'".'); |
|
261
|
|
|
|
|
|
|
}; |
|
262
|
0
|
|
|
|
|
0
|
1;}; |
|
263
|
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
|
|
265
|
26
|
|
|
26
|
|
37
|
my sub close_file( $cname ) { |
|
|
26
|
|
|
|
|
63
|
|
|
|
26
|
|
|
|
|
34
|
|
|
266
|
|
|
|
|
|
|
# Close an implicit filehandle. |
|
267
|
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
return errh('No "'.$cname.'" found, could not close it.') |
|
269
|
26
|
50
|
|
|
|
81
|
if not exists $imfh{$cname}; |
|
270
|
|
|
|
|
|
|
|
|
271
|
26
|
50
|
|
|
|
3182
|
close( $imfh{$cname} ) |
|
272
|
|
|
|
|
|
|
or return errh('Closing "'.$cname.'" failed. '.$@); |
|
273
|
26
|
|
|
|
|
127
|
delete $imfh{$cname}; |
|
274
|
26
|
|
|
|
|
88
|
1;}; |
|
275
|
|
|
|
|
|
|
|
|
276
|
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
my sub read_file( $fh , $s ) { |
|
278
|
|
|
|
|
|
|
# Read from filehandle, handling line endings as required. |
|
279
|
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
my $data; |
|
281
|
|
|
|
|
|
|
{ # block |
|
282
|
|
|
|
|
|
|
local $/ = $s->{separator}; |
|
283
|
|
|
|
|
|
|
$data->@* = readline($fh); |
|
284
|
|
|
|
|
|
|
}; |
|
285
|
|
|
|
|
|
|
if (scalar $data->@* == 0) { |
|
286
|
|
|
|
|
|
|
return '' if $s->{flatten}; |
|
287
|
|
|
|
|
|
|
return ['']; |
|
288
|
|
|
|
|
|
|
}; |
|
289
|
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
if (defined $s->{newline} and defined $s->{separator}) { |
|
291
|
|
|
|
|
|
|
my $e0 = $s->{separator}; |
|
292
|
|
|
|
|
|
|
my $e0n = length $s->{separator}; |
|
293
|
|
|
|
|
|
|
my $e1 = $s->{newline}; |
|
294
|
|
|
|
|
|
|
for (0 .. $data->$#* - 1) { |
|
295
|
|
|
|
|
|
|
substr($data->[$_],-$e0n) = $e1; |
|
296
|
|
|
|
|
|
|
}; |
|
297
|
|
|
|
|
|
|
substr($data->[-1],-$e0n) = $e1 |
|
298
|
|
|
|
|
|
|
if substr($data->[-1],-$e0n) eq $e0; |
|
299
|
|
|
|
|
|
|
}; |
|
300
|
|
|
|
|
|
|
|
|
301
|
|
|
|
|
|
|
$data = join '' , $data->@* if $s->{flatten}; |
|
302
|
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
return $data; |
|
304
|
|
|
|
|
|
|
}; |
|
305
|
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
|
|
307
|
10
|
|
|
10
|
|
19
|
my sub print_file( $fh , $s , $data ) { |
|
|
10
|
|
|
|
|
18
|
|
|
|
10
|
|
|
|
|
17
|
|
|
|
10
|
|
|
|
|
16
|
|
|
|
10
|
|
|
|
|
12
|
|
|
308
|
|
|
|
|
|
|
# Print to filehandle, changing line endings as required. |
|
309
|
|
|
|
|
|
|
|
|
310
|
10
|
100
|
66
|
|
|
51
|
if (defined $s->{newline} and defined $s->{separator}) { |
|
311
|
1
|
|
|
|
|
2
|
my $e0 = $s->{newline}; |
|
312
|
1
|
|
|
|
|
2
|
my $e0n = length $s->{newline}; |
|
313
|
1
|
|
|
|
|
3
|
my $e1 = $s->{separator}; |
|
314
|
1
|
|
|
|
|
5
|
for (0 .. $data->$#* - 1) { |
|
315
|
3
|
|
|
|
|
24
|
print $fh substr($data->[$_],0,-$e0n) , $e1; |
|
316
|
|
|
|
|
|
|
}; |
|
317
|
1
|
50
|
|
|
|
4
|
substr($data->[-1],0,-$e0n) = $e1 |
|
318
|
|
|
|
|
|
|
if substr($data->[-1],0,-$e0n) eq $e0; |
|
319
|
1
|
|
|
|
|
3
|
print $fh $data->[-1]; |
|
320
|
|
|
|
|
|
|
} |
|
321
|
|
|
|
|
|
|
else { |
|
322
|
9
|
|
|
|
|
85
|
print $fh $data->@*; |
|
323
|
|
|
|
|
|
|
}; |
|
324
|
10
|
|
|
|
|
44
|
1;}; |
|
325
|
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # |
|
327
|
|
|
|
|
|
|
|
|
328
|
20
|
|
|
20
|
|
39
|
my sub pgrab( $cname , $s , $lflag ) { |
|
|
20
|
|
|
|
|
32
|
|
|
|
20
|
|
|
|
|
30
|
|
|
|
20
|
|
|
|
|
33
|
|
|
|
20
|
|
|
|
|
55
|
|
|
329
|
|
|
|
|
|
|
# Private part of grab. |
|
330
|
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
open_file $cname , O_RDONLY , $lflag , $s->{patience} |
|
332
|
20
|
100
|
|
|
|
62
|
or return errh('grab: ',$s); |
|
333
|
15
|
|
|
|
|
90
|
seek $imfh{$cname} , 0 , 0; |
|
334
|
15
|
|
|
|
|
46
|
my $data = read_file($imfh{$cname} , $s); |
|
335
|
15
|
50
|
|
|
|
35
|
close_file($cname) |
|
336
|
|
|
|
|
|
|
or return errh('grab: ',$s); |
|
337
|
|
|
|
|
|
|
|
|
338
|
15
|
100
|
|
|
|
65
|
return $data if ref $data eq ''; |
|
339
|
14
|
|
|
|
|
149
|
return $data->@*; |
|
340
|
|
|
|
|
|
|
}; |
|
341
|
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
|
|
343
|
3
|
|
|
3
|
|
6
|
my sub ppass( $cname , $s ) { |
|
|
3
|
|
|
|
|
7
|
|
|
|
3
|
|
|
|
|
6
|
|
|
|
3
|
|
|
|
|
47
|
|
|
344
|
|
|
|
|
|
|
# Private part of pass. |
|
345
|
|
|
|
|
|
|
|
|
346
|
|
|
|
|
|
|
return errh('pass: "'.$cname.'" not taken.',$s) |
|
347
|
3
|
100
|
|
|
|
18
|
if not exists $imfh{$cname}; |
|
348
|
|
|
|
|
|
|
return errh('pass: "'.$cname.'" not opened.',$s) |
|
349
|
1
|
50
|
|
|
|
5
|
if not defined fileno($imfh{$cname}); |
|
350
|
|
|
|
|
|
|
|
|
351
|
1
|
50
|
|
|
|
4
|
close_file($cname) |
|
352
|
|
|
|
|
|
|
or return errh('pass: ',$s); |
|
353
|
1
|
|
|
|
|
5
|
1;}; |
|
354
|
|
|
|
|
|
|
|
|
355
|
|
|
|
|
|
|
|
|
356
|
7
|
|
|
7
|
|
14
|
my sub ptake( $cname , $s , $oflag ) { |
|
|
7
|
|
|
|
|
13
|
|
|
|
7
|
|
|
|
|
13
|
|
|
|
7
|
|
|
|
|
12
|
|
|
|
7
|
|
|
|
|
10
|
|
|
357
|
|
|
|
|
|
|
# Private part of take. |
|
358
|
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
open_file $cname , O_RDWR|$oflag , LOCK_EX , $s->{patience} |
|
360
|
7
|
100
|
|
|
|
57
|
or return errh('take: ',$s); |
|
361
|
5
|
|
|
|
|
43
|
seek $imfh{$cname} , 0 , 0; |
|
362
|
5
|
|
|
|
|
13
|
my $data = read_file($imfh{$cname} , $s); |
|
363
|
|
|
|
|
|
|
|
|
364
|
5
|
50
|
|
|
|
18
|
return $data if ref $data eq ''; |
|
365
|
5
|
|
|
|
|
58
|
return $data->@*; |
|
366
|
|
|
|
|
|
|
}; |
|
367
|
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
# ------------------------------------------------------------------------- # |
|
369
|
|
|
|
|
|
|
# Exportable subroutines. |
|
370
|
|
|
|
|
|
|
|
|
371
|
4
|
|
|
4
|
1
|
485
|
sub append( $fname , %set ) { |
|
|
4
|
|
|
|
|
9
|
|
|
|
4
|
|
|
|
|
8
|
|
|
|
4
|
|
|
|
|
33
|
|
|
372
|
|
|
|
|
|
|
# Append @data to $fname. |
|
373
|
|
|
|
|
|
|
|
|
374
|
4
|
|
|
|
|
13
|
my $nsp = caller; |
|
375
|
|
|
|
|
|
|
my $s = full_setting(\%set,$default->{$nsp}) |
|
376
|
4
|
50
|
|
|
|
17
|
or return errah('append: ',$default->{$nsp}); |
|
377
|
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
my $oflag = ($s->{unique}) ? (O_CREAT|O_EXCL) : |
|
379
|
4
|
50
|
|
|
|
18
|
($s->{create}) ? O_CREAT : 0; |
|
|
|
50
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
|
|
381
|
4
|
50
|
|
|
|
13
|
my $cname = canonical $fname |
|
382
|
|
|
|
|
|
|
or return errah('append: No such file "'.$fname.'" possible.',$s); |
|
383
|
|
|
|
|
|
|
|
|
384
|
4
|
|
|
4
|
|
8
|
return sub( @data ) { |
|
|
4
|
|
|
|
|
19
|
|
|
|
4
|
|
|
|
|
7
|
|
|
385
|
|
|
|
|
|
|
return errh('append: "'.$cname.'" does not exist.',$s) |
|
386
|
4
|
100
|
66
|
|
|
73
|
if (not $s->{create}) and (not -f $cname); |
|
387
|
|
|
|
|
|
|
open_file($cname , O_WRONLY|$oflag , LOCK_EX , $s->{patience}) |
|
388
|
3
|
100
|
|
|
|
14
|
or return errh('append: ',$s); |
|
389
|
2
|
|
|
|
|
30
|
seek $imfh{$cname} , 0 , 2; |
|
390
|
2
|
|
|
|
|
12
|
print_file($imfh{$cname} , $s , [@data]); |
|
391
|
2
|
50
|
|
|
|
8
|
close_file($cname) |
|
392
|
|
|
|
|
|
|
or return errh('append: ',$s); |
|
393
|
4
|
|
|
|
|
51
|
1;}; |
|
|
2
|
|
|
|
|
19
|
|
|
394
|
|
|
|
|
|
|
}; |
|
395
|
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
|
|
397
|
22
|
|
|
22
|
1
|
4412
|
sub grab( $fname , %set ) { |
|
|
22
|
|
|
|
|
55
|
|
|
|
22
|
|
|
|
|
48
|
|
|
|
22
|
|
|
|
|
34
|
|
|
398
|
|
|
|
|
|
|
# Read content of $fname. |
|
399
|
|
|
|
|
|
|
|
|
400
|
22
|
|
|
|
|
69
|
my $nsp = caller; |
|
401
|
|
|
|
|
|
|
my $s = full_setting(\%set,$default->{$nsp}) |
|
402
|
22
|
100
|
|
|
|
79
|
or return errah('grab: ',$default->{$nsp}); |
|
403
|
17
|
50
|
|
|
|
58
|
my $lflag = $s->{exclusive} ? LOCK_EX : LOCK_SH; |
|
404
|
17
|
50
|
|
|
|
86
|
my $cname = canonical $fname |
|
405
|
|
|
|
|
|
|
or return errah('grab: No such file "'.$fname.'" possible.',$s); |
|
406
|
|
|
|
|
|
|
|
|
407
|
17
|
|
|
|
|
56
|
return pgrab($cname,$s,$lflag); |
|
408
|
|
|
|
|
|
|
}; |
|
409
|
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
|
|
411
|
0
|
|
|
0
|
1
|
0
|
sub pass( $fname , %set ) { |
|
|
0
|
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
0
|
|
|
|
0
|
|
|
|
|
0
|
|
|
412
|
|
|
|
|
|
|
# Close filehandle for $fname without changing its content. |
|
413
|
|
|
|
|
|
|
|
|
414
|
0
|
|
|
|
|
0
|
my $nsp = caller; |
|
415
|
|
|
|
|
|
|
my $s = full_setting(\%set,$default->{$nsp}) |
|
416
|
0
|
0
|
|
|
|
0
|
or return errah('pass: ',$default->{$nsp}); |
|
417
|
0
|
0
|
|
|
|
0
|
my $cname = canonical $fname |
|
418
|
|
|
|
|
|
|
or return errah('pass: No such file "'.$fname.'" possible.',$s); |
|
419
|
|
|
|
|
|
|
|
|
420
|
0
|
|
|
|
|
0
|
return ppass($cname,$s); |
|
421
|
0
|
|
|
|
|
0
|
1;}; |
|
422
|
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
|
|
424
|
5
|
|
|
5
|
1
|
2385
|
sub plunk( $fname , %set ) { |
|
|
5
|
|
|
|
|
12
|
|
|
|
5
|
|
|
|
|
14
|
|
|
|
5
|
|
|
|
|
9
|
|
|
425
|
|
|
|
|
|
|
# Write @data to $fname. |
|
426
|
|
|
|
|
|
|
|
|
427
|
5
|
|
|
|
|
15
|
my $nsp = caller; |
|
428
|
|
|
|
|
|
|
my $s = full_setting(\%set,$default->{$nsp}) |
|
429
|
5
|
50
|
|
|
|
21
|
or return errah('plunk: ',$default->{$nsp}); |
|
430
|
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
my $oflag = ($s->{unique}) ? (O_CREAT|O_EXCL) : |
|
432
|
5
|
100
|
|
|
|
27
|
($s->{create}) ? O_CREAT : 0; |
|
|
|
50
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
|
|
434
|
5
|
50
|
|
|
|
14
|
my $cname = canonical $fname |
|
435
|
|
|
|
|
|
|
or return errah('plunk: No such file "'.$fname.'" possible.',$s); |
|
436
|
|
|
|
|
|
|
|
|
437
|
5
|
|
|
5
|
|
10
|
return sub( @data ) { |
|
|
5
|
|
|
|
|
22
|
|
|
|
5
|
|
|
|
|
8
|
|
|
438
|
|
|
|
|
|
|
return errh('plunk: "'.$cname.'" does not exist.',$s) |
|
439
|
5
|
50
|
66
|
|
|
60
|
if (not $s->{create}) and (not -f $cname); |
|
440
|
|
|
|
|
|
|
open_file( $cname , O_WRONLY|$oflag , LOCK_EX , $s->{patience}) |
|
441
|
5
|
100
|
|
|
|
22
|
or return errh('plunk: ',$s); |
|
442
|
4
|
|
|
|
|
28
|
seek $imfh{$cname} , 0 , 0; |
|
443
|
4
|
|
|
|
|
225
|
truncate $imfh{$cname} , 0; |
|
444
|
4
|
|
|
|
|
34
|
print_file($imfh{$cname} , $s , [@data]); |
|
445
|
4
|
50
|
|
|
|
15
|
close_file($cname) |
|
446
|
|
|
|
|
|
|
or return errh('plunk: ',$s); |
|
447
|
5
|
|
|
|
|
67
|
1;}; |
|
|
4
|
|
|
|
|
34
|
|
|
448
|
|
|
|
|
|
|
}; |
|
449
|
|
|
|
|
|
|
|
|
450
|
|
|
|
|
|
|
|
|
451
|
4
|
|
|
4
|
1
|
8
|
sub put( $fname , %set ) { |
|
|
4
|
|
|
|
|
10
|
|
|
|
4
|
|
|
|
|
7
|
|
|
|
4
|
|
|
|
|
7
|
|
|
452
|
|
|
|
|
|
|
# Write content to $fname and close filehandle. |
|
453
|
|
|
|
|
|
|
|
|
454
|
4
|
|
|
|
|
9
|
my $nsp = caller; |
|
455
|
|
|
|
|
|
|
my $s = full_setting(\%set,$default->{$nsp}) |
|
456
|
4
|
50
|
|
|
|
62
|
or return errah('put: ',$default->{$nsp}); |
|
457
|
4
|
50
|
|
|
|
11
|
my $cname = canonical $fname |
|
458
|
|
|
|
|
|
|
or return errah('put: No such file "'.$fname.'" possible.',$s); |
|
459
|
|
|
|
|
|
|
|
|
460
|
5
|
|
|
5
|
|
126
|
return sub( @data ) { |
|
|
5
|
|
|
|
|
25
|
|
|
|
5
|
|
|
|
|
11
|
|
|
461
|
|
|
|
|
|
|
return errh('put: "'.$cname.'" does not exist.',$s) |
|
462
|
5
|
100
|
|
|
|
19
|
if not exists $imfh{$cname}; |
|
463
|
4
|
|
|
|
|
9
|
my $kludge = $imfh{$cname}; |
|
464
|
4
|
50
|
|
|
|
15
|
return errh('put: "'.$fname.'" no longer open.',$s) |
|
465
|
|
|
|
|
|
|
if not defined fileno($kludge); |
|
466
|
|
|
|
|
|
|
|
|
467
|
4
|
|
|
|
|
26
|
seek $imfh{$cname} , 0 , 0; |
|
468
|
4
|
|
|
|
|
250
|
truncate $imfh{$cname} , 0; |
|
469
|
4
|
|
|
|
|
69
|
print_file($imfh{$cname} , $s , [@data]); |
|
470
|
4
|
50
|
|
|
|
14
|
close_file($cname) |
|
471
|
|
|
|
|
|
|
or return errh('put: ',$s); |
|
472
|
4
|
|
|
|
|
45
|
1;}; |
|
|
4
|
|
|
|
|
38
|
|
|
473
|
|
|
|
|
|
|
}; |
|
474
|
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
|
|
476
|
8
|
|
|
8
|
1
|
4947
|
sub take( $fname , %set ) { |
|
|
8
|
|
|
|
|
19
|
|
|
|
8
|
|
|
|
|
30
|
|
|
|
8
|
|
|
|
|
11
|
|
|
477
|
|
|
|
|
|
|
# Read content of $fname and keep filehandle open. |
|
478
|
|
|
|
|
|
|
|
|
479
|
8
|
|
|
|
|
23
|
my $nsp = caller; |
|
480
|
|
|
|
|
|
|
my $s = full_setting(\%set,$default->{$nsp}) |
|
481
|
8
|
50
|
|
|
|
48
|
or return errah('ftake: ',$default->{$nsp}); |
|
482
|
|
|
|
|
|
|
|
|
483
|
|
|
|
|
|
|
my $oflag = ($s->{unique}) ? (O_CREAT|O_EXCL) : |
|
484
|
8
|
100
|
|
|
|
57
|
($s->{create}) ? O_CREAT : 0; |
|
|
|
100
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
|
|
486
|
8
|
50
|
|
|
|
26
|
my $cname = canonical $fname |
|
487
|
|
|
|
|
|
|
or return errah('ftake: No such file "'.$fname.'" possible.',$s); |
|
488
|
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
return errh('take: "'.$fname.'" does not exist.',$s) |
|
490
|
8
|
100
|
100
|
|
|
157
|
if (not $s->{create}) and (not -f $cname); |
|
491
|
|
|
|
|
|
|
|
|
492
|
7
|
|
|
|
|
45
|
return ptake($cname,$s,$oflag); |
|
493
|
|
|
|
|
|
|
}; |
|
494
|
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - # |
|
496
|
|
|
|
|
|
|
|
|
497
|
3
|
|
|
3
|
1
|
11
|
sub fgrab( $fname , %set ) { |
|
|
3
|
|
|
|
|
8
|
|
|
|
3
|
|
|
|
|
52
|
|
|
|
3
|
|
|
|
|
6
|
|
|
498
|
|
|
|
|
|
|
# Functional version of grab. |
|
499
|
|
|
|
|
|
|
|
|
500
|
3
|
|
|
|
|
10
|
my $nsp = caller; |
|
501
|
|
|
|
|
|
|
my $s = full_setting(\%set,$default->{$nsp}) |
|
502
|
3
|
100
|
|
|
|
14
|
or return errah('grab: ',$default->{$nsp}); |
|
503
|
2
|
50
|
|
|
|
10
|
my $lflag = $s->{exclusive} ? LOCK_EX : LOCK_SH; |
|
504
|
2
|
50
|
|
|
|
7
|
my $cname = canonical $fname |
|
505
|
|
|
|
|
|
|
or return errah('grab: No such file "'.$fname.'" possible.',$s); |
|
506
|
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
return sub { |
|
508
|
3
|
|
|
3
|
|
13
|
return pgrab($cname,$s,$lflag); |
|
509
|
2
|
|
|
|
|
24
|
}; |
|
510
|
|
|
|
|
|
|
}; |
|
511
|
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
|
|
513
|
1
|
|
|
1
|
1
|
3
|
sub fpass( $fname , %set ) { |
|
|
1
|
|
|
|
|
2
|
|
|
|
1
|
|
|
|
|
2
|
|
|
|
1
|
|
|
|
|
2
|
|
|
514
|
|
|
|
|
|
|
# Functional version of pass. |
|
515
|
|
|
|
|
|
|
|
|
516
|
1
|
|
|
|
|
4
|
my $nsp = caller; |
|
517
|
|
|
|
|
|
|
my $s = full_setting(\%set,$default->{$nsp}) |
|
518
|
1
|
50
|
|
|
|
4
|
or return errah('pass: ',$default->{$nsp}); |
|
519
|
1
|
50
|
|
|
|
5
|
my $cname = canonical $fname |
|
520
|
|
|
|
|
|
|
or return errah('pass: No such file "'.$fname.'" possible.',$s); |
|
521
|
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
return sub { |
|
523
|
3
|
|
|
3
|
|
12
|
return ppass($cname,$s); |
|
524
|
1
|
|
|
|
|
12
|
}; |
|
525
|
0
|
|
|
|
|
0
|
1;}; |
|
526
|
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
|
|
528
|
2
|
|
|
2
|
1
|
2473
|
sub ftake( $fname , %set ) { |
|
|
2
|
|
|
|
|
7
|
|
|
|
2
|
|
|
|
|
5
|
|
|
|
2
|
|
|
|
|
3
|
|
|
529
|
|
|
|
|
|
|
# Functional version of take. |
|
530
|
|
|
|
|
|
|
|
|
531
|
2
|
|
|
|
|
6
|
my $nsp = caller; |
|
532
|
|
|
|
|
|
|
my $s = full_setting(\%set,$default->{$nsp}) |
|
533
|
2
|
50
|
|
|
|
10
|
or return errah('ftake: ',$default->{$nsp}); |
|
534
|
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
my $oflag = ($s->{unique}) ? (O_CREAT|O_EXCL) : |
|
536
|
2
|
50
|
|
|
|
9
|
($s->{create}) ? O_CREAT : 0; |
|
|
|
50
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
|
|
538
|
2
|
50
|
|
|
|
24
|
my $cname = canonical $fname |
|
539
|
|
|
|
|
|
|
or return errah('ftake: No such file "'.$fname.'" possible.',$s); |
|
540
|
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
return sub { |
|
542
|
4
|
|
|
4
|
|
24
|
return take($cname,$s->%*); |
|
543
|
2
|
|
|
|
|
23
|
}; |
|
544
|
|
|
|
|
|
|
}; |
|
545
|
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
|
|
547
|
2
|
|
|
2
|
1
|
905
|
sub reset() { |
|
|
2
|
|
|
|
|
3
|
|
|
548
|
|
|
|
|
|
|
# Change default settings to the original defaults. |
|
549
|
|
|
|
|
|
|
|
|
550
|
2
|
|
|
|
|
8
|
my $nsp = caller; |
|
551
|
2
|
|
|
|
|
22
|
$default->{$nsp} = {$default->{'File::Takeput'}->%*}; |
|
552
|
2
|
|
|
|
|
10
|
1;}; |
|
553
|
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
|
|
555
|
4
|
|
|
4
|
1
|
3983
|
sub set( %set ) { |
|
|
4
|
|
|
|
|
36
|
|
|
|
4
|
|
|
|
|
7
|
|
|
556
|
|
|
|
|
|
|
# Change default settings. |
|
557
|
|
|
|
|
|
|
|
|
558
|
4
|
|
|
|
|
15
|
my $nsp = caller; |
|
559
|
|
|
|
|
|
|
my $s = full_setting(\%set,$default->{$nsp}) |
|
560
|
4
|
50
|
|
|
|
20
|
or return errah('set: ',$default->{$nsp}); |
|
561
|
|
|
|
|
|
|
|
|
562
|
4
|
|
|
|
|
19
|
$default->{$nsp} = $s; |
|
563
|
4
|
|
|
|
|
24
|
1;}; |
|
564
|
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
# ------------------------------------------------------------------------- # |
|
566
|
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
=pod |
|
568
|
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
=encoding utf8 |
|
570
|
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
=head1 NAME |
|
572
|
|
|
|
|
|
|
|
|
573
|
|
|
|
|
|
|
File::Takeput - Slurp style file IO with locking. |
|
574
|
|
|
|
|
|
|
|
|
575
|
|
|
|
|
|
|
=head1 VERSION |
|
576
|
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
0.30 |
|
578
|
|
|
|
|
|
|
|
|
579
|
|
|
|
|
|
|
=head1 SYNOPSIS |
|
580
|
|
|
|
|
|
|
|
|
581
|
|
|
|
|
|
|
use File::Takeput; |
|
582
|
|
|
|
|
|
|
|
|
583
|
|
|
|
|
|
|
# Lock some file and read its content. |
|
584
|
|
|
|
|
|
|
my @content1 = take('some_file_name.csv'); |
|
585
|
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
# Read content of some other file. |
|
587
|
|
|
|
|
|
|
# Retry for up to 2.5 seconds if it is already locked. |
|
588
|
|
|
|
|
|
|
my @content2 = grab('some_other_file_name.log' , patience => 2.5); |
|
589
|
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
# Append some data to that other file. |
|
591
|
|
|
|
|
|
|
append('some_other_file_name.log')->(@some_data); |
|
592
|
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
# Read content of some third file as a single string. |
|
594
|
|
|
|
|
|
|
my ($content3) = grab('some_third_file_name.html' , separator => undef); |
|
595
|
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
# Write content back to the first file after editing it. |
|
597
|
|
|
|
|
|
|
# The locks will be released right afterwards. |
|
598
|
|
|
|
|
|
|
$content1[$_] =~ s/,/;/g for (0..$#content1); |
|
599
|
|
|
|
|
|
|
put('some_file_name.csv')->(@content1); |
|
600
|
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
=head1 DESCRIPTION |
|
602
|
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
Slurp style file IO with locking. The purpose of Takeput is to make it pleasant for you to script file IO. Slurp style is both user friendly and very effective if you can have your files in memory. |
|
604
|
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
The other major point of Takeput is locking. Takeput is careful to help your script be a good citizen in a busy filesystem. All its file operations respect and set flock locking. |
|
606
|
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
If your script misses a lock and does not release it, the lock will be released when your script terminates. |
|
608
|
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
Encoding is often part of file IO operations, but Takeput keeps out of that. It reads and writes file content just as strings of bytes, in a sort of line-based binmode. Use some other module if you need decoding and encoding. For example: |
|
610
|
|
|
|
|
|
|
|
|
611
|
|
|
|
|
|
|
use File::Takeput; |
|
612
|
|
|
|
|
|
|
use Encode; |
|
613
|
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
my @article = map {decode('iso-8859-1',$_)} grab 'article.latin-1'; |
|
615
|
|
|
|
|
|
|
|
|
616
|
|
|
|
|
|
|
=head1 SUBROUTINES AND VARIABLES |
|
617
|
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
Imported by default: |
|
619
|
|
|
|
|
|
|
L( @data )>, |
|
620
|
|
|
|
|
|
|
L, |
|
621
|
|
|
|
|
|
|
L, |
|
622
|
|
|
|
|
|
|
L( @data )>, |
|
623
|
|
|
|
|
|
|
L( @data )>, |
|
624
|
|
|
|
|
|
|
L |
|
625
|
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
Imported on demand: |
|
627
|
|
|
|
|
|
|
L, |
|
628
|
|
|
|
|
|
|
L, |
|
629
|
|
|
|
|
|
|
L, |
|
630
|
|
|
|
|
|
|
L, |
|
631
|
|
|
|
|
|
|
L |
|
632
|
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
=over |
|
634
|
|
|
|
|
|
|
|
|
635
|
|
|
|
|
|
|
=item append( $filename )->( @data ) |
|
636
|
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
Appends @data to the $filename file. |
|
638
|
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
=item grab( $filename ) |
|
640
|
|
|
|
|
|
|
|
|
641
|
|
|
|
|
|
|
Reads and returns the content of the $filename file. Will never change the content of $filename, or create the file. |
|
642
|
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
Reading an empty file will return a list with one element, the empty string. If a false value is returned instead, it is because "grab" could not read the file. |
|
644
|
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
=item pass( $filename ) |
|
646
|
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
Releases the lock on the $filename file. |
|
648
|
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
The content of the file will normally be the same as when the lock was taken with the "take" subroutine. This is useful when a lock was taken, but it later turned out that there was nothing to write to the file. |
|
650
|
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
There are two caveats. If the "create" configuration parameter is true, the file might have been created when it was taken, so it has been changed in that sense. And of course flock locks are only advisory, so other processes can ignore the locks and change the file while it is taken. |
|
652
|
|
|
|
|
|
|
|
|
653
|
|
|
|
|
|
|
=item plunk( $filename )->( @data ) |
|
654
|
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
Overwrites the $filename file with @data. |
|
656
|
|
|
|
|
|
|
|
|
657
|
|
|
|
|
|
|
=item put( $filename )->( @data ) |
|
658
|
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
Overwrites the taken $filename file, with @data, and releases the lock on it. |
|
660
|
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
Setting the L<"create" configuration parameter|/create> on this call will not work. Set it on the "take" call instead. |
|
662
|
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
=item take( $filename ) |
|
664
|
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
Sets a lock on the $filename file, reads and returns its content. |
|
666
|
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
The "take" call has write intention, because it is the first part of an operation. The second part is a call A call to "put" or "pass". |
|
668
|
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
Opening an empty file will return a list with one element, the empty string. If a false value is returned instead, it is because "take" could not read the file. |
|
670
|
|
|
|
|
|
|
|
|
671
|
|
|
|
|
|
|
=item fgrab( $filename ) |
|
672
|
|
|
|
|
|
|
|
|
673
|
|
|
|
|
|
|
A functional version of the "grab" subroutine. |
|
674
|
|
|
|
|
|
|
|
|
675
|
|
|
|
|
|
|
=item fpass( $filename ) |
|
676
|
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
A functional version of the "pass" subroutine. |
|
678
|
|
|
|
|
|
|
|
|
679
|
|
|
|
|
|
|
=item ftake( $filename ) |
|
680
|
|
|
|
|
|
|
|
|
681
|
|
|
|
|
|
|
A functional version of the "take" subroutine. |
|
682
|
|
|
|
|
|
|
|
|
683
|
|
|
|
|
|
|
Note that "take"s twin, "put", also returns a function. With these you can separate the file operations from their definitions. As you can with filehandles. This is true for all the functional subroutines. Here is an example using "ftake" and "put", where they are sent as parameters. |
|
684
|
|
|
|
|
|
|
|
|
685
|
|
|
|
|
|
|
sub changecurr($r,$w,$x) { |
|
686
|
|
|
|
|
|
|
$w->( map {s/((\d*\.)?\d+)/$x*$1/ger} $r->() ); |
|
687
|
|
|
|
|
|
|
}; |
|
688
|
|
|
|
|
|
|
|
|
689
|
|
|
|
|
|
|
my $r = ftake('wednesday.csv' , patience => 5); |
|
690
|
|
|
|
|
|
|
my $w = put('wednesday.csv'); |
|
691
|
|
|
|
|
|
|
my $rate = current_rate('GBP'); |
|
692
|
|
|
|
|
|
|
changecurr($r,$w,$rate); |
|
693
|
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
=item reset |
|
695
|
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
Sets the default configuration parameters back to the Takeput defaults. |
|
697
|
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
=item set( %settings ) |
|
699
|
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
Customize the default values by setting parameters as in %settings. Can be reset by calling "reset". |
|
701
|
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
=back |
|
703
|
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
=head1 CONFIGURATION |
|
705
|
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
There are eight configuration parameters. |
|
707
|
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
=over |
|
709
|
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
=item create |
|
711
|
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
A scalar. If true the subroutines that have write intention, will create the file if it does not exist. If false, they will just fail if the file does not exist. |
|
713
|
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
Be careful with this parameter. For example if a process renames the file while another process is waiting for the lock, that other process will open the file with the new name when it gets the lock. If it plunks, it is not to a file with the name it was called with, but to the file with this new name. Maybe not what is wanted... |
|
715
|
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
The "create" parameter is ignored by "put". Use it on "take" instead, if you want this functionality. |
|
717
|
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
=item error |
|
719
|
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
A ref to a subroutine that is called if Takeput runs into a runtime error. It will be called without parameters. The $@ variable will be set just prior to the subroutine call, and the subroutines return value will be passed on back to your script. An example: |
|
721
|
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
use Logger::Syslog qw(warning); |
|
723
|
|
|
|
|
|
|
use File::Takeput error => sub {warning 'commit.pl: '.$@; die;}; |
|
724
|
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
my @data = take('transaction.data' , patience => 10); |
|
726
|
|
|
|
|
|
|
do_stuff [@data]; |
|
727
|
|
|
|
|
|
|
put('transaction.data')->(@data); |
|
728
|
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
If you just need non-fatal warnings, here is a simple error handler you can use: |
|
730
|
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
use File::Takeput error => sub {print STDERR "$@\n"; undef;}; |
|
732
|
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
If the value of "error" is undef, Takeput will not make these calls. |
|
734
|
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
=item exclusive |
|
736
|
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
A scalar. If true Takeput will take an exclusive lock on read operations. If false it will just take a shared lock on them, as it normally does. |
|
738
|
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
=item flatten |
|
740
|
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
A scalar. If true Takeput will flatten the file content and return it as a string. If false it will return an array. |
|
742
|
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
Normally you would also set "separator" to undef, when you set "flatten" to true. For example: |
|
744
|
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
use YAML::XS qw(Load Dump); # Working with YAML. |
|
746
|
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
File::Takeput::set(separator => undef , flatten => 1); # Because of this... |
|
748
|
|
|
|
|
|
|
my $fancy_data = Load grab('my_file.yaml'); # ...this will work. |
|
749
|
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
Note that with "flatten" set to true, reading an empty file returns the empty string, which counts as false. Failing to read a file returns undef. So test for definedness to not be tricked by this. |
|
751
|
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
=item newline |
|
753
|
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
A string that replaces the "separator" string at the end of each line when reading from a file. When writing to a file the replacement is the other way around. Then "separator" will replace "newline". |
|
755
|
|
|
|
|
|
|
|
|
756
|
|
|
|
|
|
|
If either the "newline" value or the "separator" value is undef, no replacements will be done. |
|
757
|
|
|
|
|
|
|
|
|
758
|
|
|
|
|
|
|
=item patience |
|
759
|
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
The time in seconds that a call will wait for a lock to be released. The value can be fractional. |
|
761
|
|
|
|
|
|
|
|
|
762
|
|
|
|
|
|
|
If "patience" is set to 0, there will be no waiting. |
|
763
|
|
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
=item separator |
|
765
|
|
|
|
|
|
|
|
|
766
|
|
|
|
|
|
|
The string defining the end of a line. It is used in read operations to split the data into lines. Note that the value is read as a bytestring. So take care if you use a special separator in combination with an unusual encoding. |
|
767
|
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
Setting this parameter does not change the value of $/ or vice versa. |
|
769
|
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
The "separator" value cannot be an empty string. If it is undef the data is seen as a single string. |
|
771
|
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
=item unique |
|
773
|
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
A scalar. If true Takeput will fail opening a file if it already exists. This can be used to avoid race conditions. |
|
775
|
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
Only used by calls with write intention. |
|
777
|
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
If "unique" is true, calls will work as if "create" is true and "patience" is 0, no matter what they are set to. |
|
779
|
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
=back |
|
781
|
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
=head2 CONFIGURATION OPTIONS |
|
783
|
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
You have a number of options for setting the configuration parameters. |
|
785
|
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
=over |
|
787
|
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
=item 1. In a file operation call, as optional named parameters. |
|
789
|
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
=item 2. In a statement by calling "set" or "reset". |
|
791
|
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
=item 3. Directly in the use statement of your script. |
|
793
|
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
=item 4. Default configuration. |
|
795
|
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
=back |
|
797
|
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
If a parameter is set in more than one way, the most specific setting wins out. In the list above, the item with the lowest number wins out. |
|
799
|
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
=head3 1. OPTIONAL NAMED PARAMETERS |
|
801
|
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
All the file operation subroutines can take the configuration parameters as optional named parameters. That means that you can set them per call. The place to write them is after the filename parameter. Example: |
|
803
|
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
my @text = grab 'windows_file.txt' , separator => "\r\n" , newline => "\n"; |
|
805
|
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
=head3 2. SET AND RESET SUBROUTINES |
|
807
|
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
The two subroutines "set" and "reset" will customize the default values of the configuration parameters, so that subsequent file operations are using those defaults. |
|
809
|
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
You use "set" to set the values, and "reset" to set the values back to the Takeput defaults. Think of it as assignment statements. If there are multiple calls, the last one is the one that is in effect. |
|
811
|
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
Customized defaults are limited to the namespace in which you set them. |
|
813
|
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
=head3 3. USE STATEMENT |
|
815
|
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
Another way to customize the default values is in the use statement that imports Takeput. For example: |
|
817
|
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
use File::Takeput separator => "\n"; |
|
819
|
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
When you do it like this, the values are set at compile-time. Because of that, Takeput will die on any errors that those settings will give rise to. |
|
821
|
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
Note that customized defaults are limited to the namespace in which you set them. |
|
823
|
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
=head3 4. DEFAULT CONFIGURATION |
|
825
|
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
The Takeput defaults are: |
|
827
|
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
C: undef (false) |
|
829
|
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
C: undef |
|
831
|
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
C: undef (false) |
|
833
|
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
C: undef (false) |
|
835
|
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
C: undef |
|
837
|
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
C: 0 |
|
839
|
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
C: $/ (at compile time) |
|
841
|
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
C: undef (false) |
|
843
|
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
=head1 ERROR HANDLING |
|
845
|
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
Takeput will die on compile-time errors, but not on runtime errors. In case of a runtime error it might or might not issue a warning. But it will always write an error message in $@ and return an error value. |
|
847
|
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
That said, you have the option of changing how runtime errors are handled, by using the L<"error" configuration parameter|/error>. |
|
849
|
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
=head1 DEPENDENCIES |
|
851
|
|
|
|
|
|
|
|
|
852
|
|
|
|
|
|
|
Cwd |
|
853
|
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
Exporter |
|
855
|
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
Fcntl |
|
857
|
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
File::Basename |
|
859
|
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
Scalar::Util |
|
861
|
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
Time::HiRes |
|
863
|
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
=head1 KNOWN ISSUES |
|
865
|
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
No known issues. |
|
867
|
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
=head1 TODO |
|
869
|
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
Decide on empty string "separator". It ought to give a list of bytes, but readline gives an unintuitive list. It would be a mess with the line ending transformations. |
|
871
|
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
An empty string will be an invalid value for now. |
|
873
|
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
=head1 SEE ALSO |
|
875
|
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
L |
|
877
|
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
L |
|
879
|
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
L |
|
881
|
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
=head1 LICENSE & COPYRIGHT |
|
883
|
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
(c) 2023 Bjørn Hee |
|
885
|
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
Licensed under the Apache License, version 2.0 |
|
887
|
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
https://www.apache.org/licenses/LICENSE-2.0.txt |
|
889
|
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
=cut |
|
891
|
|
|
|
|
|
|
|
|
892
|
|
|
|
|
|
|
__END__ |