Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/File/Slurp.pm |
Statements | Executed 56 statements in 2.77ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 1.52ms | 1.63ms | BEGIN@12 | File::Slurp::
1 | 1 | 1 | 564µs | 5.56ms | BEGIN@11 | File::Slurp::
1 | 1 | 1 | 57µs | 101µs | read_file | File::Slurp::
1 | 1 | 1 | 30µs | 30µs | CORE:sysopen (opcode) | File::Slurp::
1 | 1 | 1 | 25µs | 25µs | BEGIN@3 | File::Slurp::
1 | 1 | 1 | 11µs | 11µs | CORE:sysread (opcode) | File::Slurp::
1 | 1 | 1 | 10µs | 28µs | BEGIN@263 | File::Slurp::
1 | 1 | 1 | 9µs | 2.02ms | BEGIN@10 | File::Slurp::
1 | 1 | 1 | 8µs | 8µs | BEGIN@62 | File::Slurp::
1 | 1 | 1 | 8µs | 43µs | BEGIN@8 | File::Slurp::
1 | 1 | 1 | 8µs | 83µs | BEGIN@15 | File::Slurp::
1 | 1 | 1 | 8µs | 12µs | BEGIN@5 | File::Slurp::
1 | 1 | 1 | 8µs | 22µs | BEGIN@6 | File::Slurp::
1 | 1 | 1 | 6µs | 17µs | BEGIN@9 | File::Slurp::
1 | 1 | 1 | 4µs | 4µs | CORE:match (opcode) | File::Slurp::
1 | 1 | 1 | 2µs | 2µs | CORE:ftis (opcode) | File::Slurp::
3 | 2 | 1 | 1µs | 1µs | CORE:ftsize (opcode) | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:64] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:65] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:66] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:70] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:71] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:72] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:78] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:79] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:80] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:83] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:84] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:85] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:88] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:89] | File::Slurp::
0 | 0 | 0 | 0s | 0s | __ANON__[:90] | File::Slurp::
0 | 0 | 0 | 0s | 0s | _check_ref | File::Slurp::
0 | 0 | 0 | 0s | 0s | _error | File::Slurp::
0 | 0 | 0 | 0s | 0s | _seek_data_handle | File::Slurp::
0 | 0 | 0 | 0s | 0s | append_file | File::Slurp::
0 | 0 | 0 | 0s | 0s | edit_file | File::Slurp::
0 | 0 | 0 | 0s | 0s | edit_file_lines | File::Slurp::
0 | 0 | 0 | 0s | 0s | prepend_file | File::Slurp::
0 | 0 | 0 | 0s | 0s | read_dir | File::Slurp::
0 | 0 | 0 | 0s | 0s | write_file | File::Slurp::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package File::Slurp; | ||||
2 | |||||
3 | 3 | 33µs | 1 | 25µs | # spent 25µs within File::Slurp::BEGIN@3 which was called:
# once (25µs+0s) by Tapper::Config::BEGIN@16 at line 3 # spent 25µs making 1 call to File::Slurp::BEGIN@3 |
4 | |||||
5 | 3 | 21µs | 2 | 15µs | # spent 12µs (8+4) within File::Slurp::BEGIN@5 which was called:
# once (8µs+4µs) by Tapper::Config::BEGIN@16 at line 5 # spent 12µs making 1 call to File::Slurp::BEGIN@5
# spent 4µs making 1 call to strict::import |
6 | 3 | 19µs | 2 | 37µs | # spent 22µs (8+15) within File::Slurp::BEGIN@6 which was called:
# once (8µs+15µs) by Tapper::Config::BEGIN@16 at line 6 # spent 22µs making 1 call to File::Slurp::BEGIN@6
# spent 15µs making 1 call to warnings::import |
7 | |||||
8 | 3 | 18µs | 2 | 77µs | # spent 43µs (8+34) within File::Slurp::BEGIN@8 which was called:
# once (8µs+34µs) by Tapper::Config::BEGIN@16 at line 8 # spent 43µs making 1 call to File::Slurp::BEGIN@8
# spent 34µs making 1 call to Exporter::import |
9 | 3 | 20µs | 2 | 28µs | # spent 17µs (6+11) within File::Slurp::BEGIN@9 which was called:
# once (6µs+11µs) by Tapper::Config::BEGIN@16 at line 9 # spent 17µs making 1 call to File::Slurp::BEGIN@9
# spent 11µs making 1 call to Exporter::import |
10 | 3 | 27µs | 2 | 4.04ms | # spent 2.02ms (9µs+2.01) within File::Slurp::BEGIN@10 which was called:
# once (9µs+2.01ms) by Tapper::Config::BEGIN@16 at line 10 # spent 2.02ms making 1 call to File::Slurp::BEGIN@10
# spent 2.01ms making 1 call to Exporter::import |
11 | 3 | 109µs | 2 | 8.21ms | # spent 5.56ms (564µs+5.00) within File::Slurp::BEGIN@11 which was called:
# once (564µs+5.00ms) by Tapper::Config::BEGIN@16 at line 11 # spent 5.56ms making 1 call to File::Slurp::BEGIN@11
# spent 2.65ms making 1 call to POSIX::import |
12 | 3 | 147µs | 2 | 1.65ms | # spent 1.63ms (1.52+108µs) within File::Slurp::BEGIN@12 which was called:
# once (1.52ms+108µs) by Tapper::Config::BEGIN@16 at line 12 # spent 1.63ms making 1 call to File::Slurp::BEGIN@12
# spent 22µs making 1 call to Exporter::import |
13 | #use Symbol ; | ||||
14 | |||||
15 | 3 | 355µs | 2 | 157µs | # spent 83µs (8+75) within File::Slurp::BEGIN@15 which was called:
# once (8µs+75µs) by Tapper::Config::BEGIN@16 at line 15 # spent 83µs making 1 call to File::Slurp::BEGIN@15
# spent 75µs making 1 call to vars::import |
16 | 1 | 10µs | @ISA = qw( Exporter ) ; | ||
17 | |||||
18 | 1 | 600ns | $VERSION = '9999.19'; | ||
19 | |||||
20 | 1 | 2µs | my @std_export = qw( | ||
21 | read_file | ||||
22 | write_file | ||||
23 | overwrite_file | ||||
24 | append_file | ||||
25 | read_dir | ||||
26 | ) ; | ||||
27 | |||||
28 | 1 | 700ns | my @edit_export = qw( | ||
29 | edit_file | ||||
30 | edit_file_lines | ||||
31 | ) ; | ||||
32 | |||||
33 | 1 | 300ns | my @ok_export = qw( | ||
34 | ) ; | ||||
35 | |||||
36 | 1 | 1µs | @EXPORT_OK = ( | ||
37 | @edit_export, | ||||
38 | qw( | ||||
39 | slurp | ||||
40 | prepend_file | ||||
41 | ), | ||||
42 | ) ; | ||||
43 | |||||
44 | 1 | 7µs | %EXPORT_TAGS = ( | ||
45 | 'all' => [ @std_export, @edit_export, @EXPORT_OK ], | ||||
46 | 'edit' => [ @edit_export ], | ||||
47 | 'std' => [ @std_export ], | ||||
48 | ) ; | ||||
49 | |||||
50 | 1 | 900ns | @EXPORT = @std_export ; | ||
51 | |||||
52 | 1 | 300ns | my $max_fast_slurp_size = 1024 * 100 ; | ||
53 | |||||
54 | 1 | 12µs | 1 | 4µs | my $is_win32 = $^O =~ /win32/i ; # spent 4µs making 1 call to File::Slurp::CORE:match |
55 | |||||
56 | # Install subs for various constants that aren't set in older perls | ||||
57 | # (< 5.005). Fcntl on old perls uses Exporter to define subs without a | ||||
58 | # () prototype These can't be overridden with the constant pragma or | ||||
59 | # we get a prototype mismatch. Hence this less than aesthetically | ||||
60 | # appealing BEGIN block: | ||||
61 | |||||
62 | # spent 8µs within File::Slurp::BEGIN@62 which was called:
# once (8µs+0s) by Tapper::Config::BEGIN@16 at line 93 | ||||
63 | 3 | 9µs | unless( defined &SEEK_SET ) { | ||
64 | *SEEK_SET = sub { 0 }; | ||||
65 | *SEEK_CUR = sub { 1 }; | ||||
66 | *SEEK_END = sub { 2 }; | ||||
67 | } | ||||
68 | |||||
69 | unless( defined &O_BINARY ) { | ||||
70 | *O_BINARY = sub { 0 }; | ||||
71 | *O_RDONLY = sub { 0 }; | ||||
72 | *O_WRONLY = sub { 1 }; | ||||
73 | } | ||||
74 | |||||
75 | unless ( defined &O_APPEND ) { | ||||
76 | |||||
77 | if ( $^O =~ /olaris/ ) { | ||||
78 | *O_APPEND = sub { 8 }; | ||||
79 | *O_CREAT = sub { 256 }; | ||||
80 | *O_EXCL = sub { 1024 }; | ||||
81 | } | ||||
82 | elsif ( $^O =~ /inux/ ) { | ||||
83 | *O_APPEND = sub { 1024 }; | ||||
84 | *O_CREAT = sub { 64 }; | ||||
85 | *O_EXCL = sub { 128 }; | ||||
86 | } | ||||
87 | elsif ( $^O =~ /BSD/i ) { | ||||
88 | *O_APPEND = sub { 8 }; | ||||
89 | *O_CREAT = sub { 512 }; | ||||
90 | *O_EXCL = sub { 2048 }; | ||||
91 | } | ||||
92 | } | ||||
93 | 1 | 424µs | 1 | 8µs | } # spent 8µs making 1 call to File::Slurp::BEGIN@62 |
94 | |||||
95 | # print "OS [$^O]\n" ; | ||||
96 | |||||
97 | # print "O_BINARY = ", O_BINARY(), "\n" ; | ||||
98 | # print "O_RDONLY = ", O_RDONLY(), "\n" ; | ||||
99 | # print "O_WRONLY = ", O_WRONLY(), "\n" ; | ||||
100 | # print "O_APPEND = ", O_APPEND(), "\n" ; | ||||
101 | # print "O_CREAT ", O_CREAT(), "\n" ; | ||||
102 | # print "O_EXCL ", O_EXCL(), "\n" ; | ||||
103 | |||||
104 | |||||
105 | 1 | 1µs | *slurp = \&read_file ; | ||
106 | |||||
107 | # spent 101µs (57+44) within File::Slurp::read_file which was called:
# once (57µs+44µs) by Tapper::Config::_switch_context at line 71 of Tapper/Config.pm | ||||
108 | |||||
109 | 3 | 18µs | my $file_name = shift ; | ||
110 | my $opts = ( ref $_[0] eq 'HASH' ) ? shift : { @_ } ; | ||||
111 | |||||
112 | # this is the optimized read_file for shorter files. | ||||
113 | # the test for -s > 0 is to allow pseudo files to be read with the | ||||
114 | # regular loop since they return a size of 0. | ||||
115 | |||||
116 | 6 | 84µs | 3 | 3µs | if ( !ref $file_name && -e $file_name && -s _ > 0 && # spent 2µs making 1 call to File::Slurp::CORE:ftis
# spent 900ns making 2 calls to File::Slurp::CORE:ftsize, avg 450ns/call |
117 | -s _ < $max_fast_slurp_size && !%{$opts} && !wantarray ) { | ||||
118 | |||||
119 | |||||
120 | my $fh ; | ||||
121 | 1 | 30µs | unless( sysopen( $fh, $file_name, O_RDONLY ) ) { # spent 30µs making 1 call to File::Slurp::CORE:sysopen | ||
122 | |||||
123 | @_ = ( $opts, "read_file '$file_name' - sysopen: $!"); | ||||
124 | goto &_error ; | ||||
125 | } | ||||
126 | |||||
127 | 2 | 12µs | my $read_cnt = sysread( $fh, my $buf, -s _ ) ; # spent 11µs making 1 call to File::Slurp::CORE:sysread
# spent 400ns making 1 call to File::Slurp::CORE:ftsize | ||
128 | |||||
129 | unless ( defined $read_cnt ) { | ||||
130 | |||||
131 | @_ = ( $opts, | ||||
132 | "read_file '$file_name' - small sysread: $!"); | ||||
133 | goto &_error ; | ||||
134 | } | ||||
135 | |||||
136 | $buf =~ s/\015\012/\n/g if $is_win32 ; | ||||
137 | return $buf ; | ||||
138 | } | ||||
139 | |||||
140 | # set the buffer to either the passed in one or ours and init it to the null | ||||
141 | # string | ||||
142 | |||||
143 | my $buf ; | ||||
144 | my $buf_ref = $opts->{'buf_ref'} || \$buf ; | ||||
145 | ${$buf_ref} = '' ; | ||||
146 | |||||
147 | my( $read_fh, $size_left, $blk_size ) ; | ||||
148 | |||||
149 | # deal with ref for a file name | ||||
150 | # it could be an open handle or an overloaded object | ||||
151 | |||||
152 | if ( ref $file_name ) { | ||||
153 | |||||
154 | my $ref_result = _check_ref( $file_name ) ; | ||||
155 | |||||
156 | if ( ref $ref_result ) { | ||||
157 | |||||
158 | # we got an error, deal with it | ||||
159 | |||||
160 | @_ = ( $opts, $ref_result ) ; | ||||
161 | goto &_error ; | ||||
162 | } | ||||
163 | |||||
164 | if ( $ref_result ) { | ||||
165 | |||||
166 | # we got an overloaded object and the result is the stringified value | ||||
167 | # use it as the file name | ||||
168 | |||||
169 | $file_name = $ref_result ; | ||||
170 | } | ||||
171 | else { | ||||
172 | |||||
173 | # here we have just an open handle. set $read_fh so we don't do a sysopen | ||||
174 | |||||
175 | $read_fh = $file_name ; | ||||
176 | $blk_size = $opts->{'blk_size'} || 1024 * 1024 ; | ||||
177 | $size_left = $blk_size ; | ||||
178 | } | ||||
179 | } | ||||
180 | |||||
181 | # see if we have a path we need to open | ||||
182 | |||||
183 | unless ( $read_fh ) { | ||||
184 | |||||
185 | # a regular file. set the sysopen mode | ||||
186 | |||||
187 | my $mode = O_RDONLY ; | ||||
188 | |||||
189 | #printf "RD: BINARY %x MODE %x\n", O_BINARY, $mode ; | ||||
190 | |||||
191 | $read_fh = local( *FH ) ; | ||||
192 | # $read_fh = gensym ; | ||||
193 | unless ( sysopen( $read_fh, $file_name, $mode ) ) { | ||||
194 | @_ = ( $opts, "read_file '$file_name' - sysopen: $!"); | ||||
195 | goto &_error ; | ||||
196 | } | ||||
197 | |||||
198 | if ( my $binmode = $opts->{'binmode'} ) { | ||||
199 | binmode( $read_fh, $binmode ) ; | ||||
200 | } | ||||
201 | |||||
202 | # get the size of the file for use in the read loop | ||||
203 | |||||
204 | $size_left = -s $read_fh ; | ||||
205 | |||||
206 | #print "SIZE $size_left\n" ; | ||||
207 | |||||
208 | # we need a blk_size if the size is 0 so we can handle pseudofiles like in | ||||
209 | # /proc. these show as 0 size but have data to be slurped. | ||||
210 | |||||
211 | unless( $size_left ) { | ||||
212 | |||||
213 | $blk_size = $opts->{'blk_size'} || 1024 * 1024 ; | ||||
214 | $size_left = $blk_size ; | ||||
215 | } | ||||
216 | } | ||||
217 | |||||
218 | # infinite read loop. we exit when we are done slurping | ||||
219 | |||||
220 | while( 1 ) { | ||||
221 | |||||
222 | # do the read and see how much we got | ||||
223 | |||||
224 | my $read_cnt = sysread( $read_fh, ${$buf_ref}, | ||||
225 | $size_left, length ${$buf_ref} ) ; | ||||
226 | |||||
227 | # since we're using sysread Perl won't automatically restart the call | ||||
228 | # when interrupted by a signal. | ||||
229 | |||||
230 | next if $!{EINTR}; | ||||
231 | |||||
232 | unless ( defined $read_cnt ) { | ||||
233 | |||||
234 | @_ = ( $opts, "read_file '$file_name' - loop sysread: $!"); | ||||
235 | goto &_error ; | ||||
236 | } | ||||
237 | |||||
238 | # good read. see if we hit EOF (nothing left to read) | ||||
239 | |||||
240 | last if $read_cnt == 0 ; | ||||
241 | |||||
242 | # loop if we are slurping a handle. we don't track $size_left then. | ||||
243 | |||||
244 | next if $blk_size ; | ||||
245 | |||||
246 | # count down how much we read and loop if we have more to read. | ||||
247 | |||||
248 | $size_left -= $read_cnt ; | ||||
249 | last if $size_left <= 0 ; | ||||
250 | } | ||||
251 | |||||
252 | # fix up cr/lf to be a newline if this is a windows text file | ||||
253 | |||||
254 | ${$buf_ref} =~ s/\015\012/\n/g if $is_win32 && !$opts->{'binmode'} ; | ||||
255 | |||||
256 | my $sep = $/ ; | ||||
257 | $sep = '\n\n+' if defined $sep && $sep eq '' ; | ||||
258 | |||||
259 | # see if caller wants lines | ||||
260 | |||||
261 | if( wantarray || $opts->{'array_ref'} ) { | ||||
262 | |||||
263 | 3 | 1.43ms | 2 | 47µs | # spent 28µs (10+18) within File::Slurp::BEGIN@263 which was called:
# once (10µs+18µs) by Tapper::Config::BEGIN@16 at line 263 # spent 28µs making 1 call to File::Slurp::BEGIN@263
# spent 18µs making 1 call to re::import |
264 | |||||
265 | my @lines = length(${$buf_ref}) ? | ||||
266 | ${$buf_ref} =~ /(.*?$sep|.+)/sg : () ; | ||||
267 | |||||
268 | chomp @lines if $opts->{'chomp'} ; | ||||
269 | |||||
270 | # caller wants an array ref | ||||
271 | |||||
272 | return \@lines if $opts->{'array_ref'} ; | ||||
273 | |||||
274 | # caller wants list of lines | ||||
275 | |||||
276 | return @lines ; | ||||
277 | } | ||||
278 | |||||
279 | # caller wants a scalar ref to the slurped text | ||||
280 | |||||
281 | return $buf_ref if $opts->{'scalar_ref'} ; | ||||
282 | |||||
283 | # caller wants a scalar with the slurped text (normal scalar context) | ||||
284 | |||||
285 | return ${$buf_ref} if defined wantarray ; | ||||
286 | |||||
287 | # caller passed in an i/o buffer by reference (normal void context) | ||||
288 | |||||
289 | return ; | ||||
290 | } | ||||
291 | |||||
292 | # errors in this sub are returned as scalar refs | ||||
293 | # a normal IO/GLOB handle is an empty return | ||||
294 | # an overloaded object returns its stringified as a scalarfilename | ||||
295 | |||||
296 | sub _check_ref { | ||||
297 | |||||
298 | my( $handle ) = @_ ; | ||||
299 | |||||
300 | # check if we are reading from a handle (GLOB or IO object) | ||||
301 | |||||
302 | if ( eval { $handle->isa( 'GLOB' ) || $handle->isa( 'IO' ) } ) { | ||||
303 | |||||
304 | # we have a handle. deal with seeking to it if it is DATA | ||||
305 | |||||
306 | my $err = _seek_data_handle( $handle ) ; | ||||
307 | |||||
308 | # return the error string if any | ||||
309 | |||||
310 | return \$err if $err ; | ||||
311 | |||||
312 | # we have good handle | ||||
313 | return ; | ||||
314 | } | ||||
315 | |||||
316 | eval { require overload } ; | ||||
317 | |||||
318 | # return an error if we can't load the overload pragma | ||||
319 | # or if the object isn't overloaded | ||||
320 | |||||
321 | return \"Bad handle '$handle' is not a GLOB or IO object or overloaded" | ||||
322 | if $@ || !overload::Overloaded( $handle ) ; | ||||
323 | |||||
324 | # must be overloaded so return its stringified value | ||||
325 | |||||
326 | return "$handle" ; | ||||
327 | } | ||||
328 | |||||
329 | sub _seek_data_handle { | ||||
330 | |||||
331 | my( $handle ) = @_ ; | ||||
332 | |||||
333 | # DEEP DARK MAGIC. this checks the UNTAINT IO flag of a | ||||
334 | # glob/handle. only the DATA handle is untainted (since it is from | ||||
335 | # trusted data in the source file). this allows us to test if this is | ||||
336 | # the DATA handle and then to do a sysseek to make sure it gets | ||||
337 | # slurped correctly. on some systems, the buffered i/o pointer is not | ||||
338 | # left at the same place as the fd pointer. this sysseek makes them | ||||
339 | # the same so slurping with sysread will work. | ||||
340 | |||||
341 | eval{ require B } ; | ||||
342 | |||||
343 | if ( $@ ) { | ||||
344 | |||||
345 | return <<ERR ; | ||||
346 | Can't find B.pm with this Perl: $!. | ||||
347 | That module is needed to properly slurp the DATA handle. | ||||
348 | ERR | ||||
349 | } | ||||
350 | |||||
351 | if ( B::svref_2object( $handle )->IO->IoFLAGS & 16 ) { | ||||
352 | |||||
353 | # set the seek position to the current tell. | ||||
354 | |||||
355 | unless( sysseek( $handle, tell( $handle ), SEEK_SET ) ) { | ||||
356 | return "read_file '$handle' - sysseek: $!" ; | ||||
357 | } | ||||
358 | } | ||||
359 | |||||
360 | # seek was successful, return no error string | ||||
361 | |||||
362 | return ; | ||||
363 | } | ||||
364 | |||||
365 | |||||
366 | sub write_file { | ||||
367 | |||||
368 | my $file_name = shift ; | ||||
369 | |||||
370 | # get the optional argument hash ref from @_ or an empty hash ref. | ||||
371 | |||||
372 | my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ; | ||||
373 | |||||
374 | my( $buf_ref, $write_fh, $no_truncate, $orig_file_name, $data_is_ref ) ; | ||||
375 | |||||
376 | # get the buffer ref - it depends on how the data is passed into write_file | ||||
377 | # after this if/else $buf_ref will have a scalar ref to the data. | ||||
378 | |||||
379 | if ( ref $opts->{'buf_ref'} eq 'SCALAR' ) { | ||||
380 | |||||
381 | # a scalar ref passed in %opts has the data | ||||
382 | # note that the data was passed by ref | ||||
383 | |||||
384 | $buf_ref = $opts->{'buf_ref'} ; | ||||
385 | $data_is_ref = 1 ; | ||||
386 | } | ||||
387 | elsif ( ref $_[0] eq 'SCALAR' ) { | ||||
388 | |||||
389 | # the first value in @_ is the scalar ref to the data | ||||
390 | # note that the data was passed by ref | ||||
391 | |||||
392 | $buf_ref = shift ; | ||||
393 | $data_is_ref = 1 ; | ||||
394 | } | ||||
395 | elsif ( ref $_[0] eq 'ARRAY' ) { | ||||
396 | |||||
397 | # the first value in @_ is the array ref to the data so join it. | ||||
398 | |||||
399 | ${$buf_ref} = join '', @{$_[0]} ; | ||||
400 | } | ||||
401 | else { | ||||
402 | |||||
403 | # good old @_ has all the data so join it. | ||||
404 | |||||
405 | ${$buf_ref} = join '', @_ ; | ||||
406 | } | ||||
407 | |||||
408 | # deal with ref for a file name | ||||
409 | |||||
410 | if ( ref $file_name ) { | ||||
411 | |||||
412 | my $ref_result = _check_ref( $file_name ) ; | ||||
413 | |||||
414 | if ( ref $ref_result ) { | ||||
415 | |||||
416 | # we got an error, deal with it | ||||
417 | |||||
418 | @_ = ( $opts, $ref_result ) ; | ||||
419 | goto &_error ; | ||||
420 | } | ||||
421 | |||||
422 | if ( $ref_result ) { | ||||
423 | |||||
424 | # we got an overloaded object and the result is the stringified value | ||||
425 | # use it as the file name | ||||
426 | |||||
427 | $file_name = $ref_result ; | ||||
428 | } | ||||
429 | else { | ||||
430 | |||||
431 | # we now have a proper handle ref. | ||||
432 | # make sure we don't call truncate on it. | ||||
433 | |||||
434 | $write_fh = $file_name ; | ||||
435 | $no_truncate = 1 ; | ||||
436 | } | ||||
437 | } | ||||
438 | |||||
439 | # see if we have a path we need to open | ||||
440 | |||||
441 | unless( $write_fh ) { | ||||
442 | |||||
443 | # spew to regular file. | ||||
444 | |||||
445 | if ( $opts->{'atomic'} ) { | ||||
446 | |||||
447 | # in atomic mode, we spew to a temp file so make one and save the original | ||||
448 | # file name. | ||||
449 | $orig_file_name = $file_name ; | ||||
450 | $file_name .= ".$$" ; | ||||
451 | } | ||||
452 | |||||
453 | # set the mode for the sysopen | ||||
454 | |||||
455 | my $mode = O_WRONLY | O_CREAT ; | ||||
456 | $mode |= O_APPEND if $opts->{'append'} ; | ||||
457 | $mode |= O_EXCL if $opts->{'no_clobber'} ; | ||||
458 | |||||
459 | my $perms = $opts->{perms} ; | ||||
460 | $perms = 0666 unless defined $perms ; | ||||
461 | |||||
462 | #printf "WR: BINARY %x MODE %x\n", O_BINARY, $mode ; | ||||
463 | |||||
464 | # open the file and handle any error. | ||||
465 | |||||
466 | $write_fh = local( *FH ) ; | ||||
467 | # $write_fh = gensym ; | ||||
468 | unless ( sysopen( $write_fh, $file_name, $mode, $perms ) ) { | ||||
469 | |||||
470 | @_ = ( $opts, "write_file '$file_name' - sysopen: $!"); | ||||
471 | goto &_error ; | ||||
472 | } | ||||
473 | } | ||||
474 | |||||
475 | if ( my $binmode = $opts->{'binmode'} ) { | ||||
476 | binmode( $write_fh, $binmode ) ; | ||||
477 | } | ||||
478 | |||||
479 | sysseek( $write_fh, 0, SEEK_END ) if $opts->{'append'} ; | ||||
480 | |||||
481 | #print 'WR before data ', unpack( 'H*', ${$buf_ref}), "\n" ; | ||||
482 | |||||
483 | # fix up newline to write cr/lf if this is a windows text file | ||||
484 | |||||
485 | if ( $is_win32 && !$opts->{'binmode'} ) { | ||||
486 | |||||
487 | # copy the write data if it was passed by ref so we don't clobber the | ||||
488 | # caller's data | ||||
489 | $buf_ref = \do{ my $copy = ${$buf_ref}; } if $data_is_ref ; | ||||
490 | ${$buf_ref} =~ s/\n/\015\012/g ; | ||||
491 | } | ||||
492 | |||||
493 | #print 'after data ', unpack( 'H*', ${$buf_ref}), "\n" ; | ||||
494 | |||||
495 | # get the size of how much we are writing and init the offset into that buffer | ||||
496 | |||||
497 | my $size_left = length( ${$buf_ref} ) ; | ||||
498 | my $offset = 0 ; | ||||
499 | |||||
500 | # loop until we have no more data left to write | ||||
501 | |||||
502 | do { | ||||
503 | |||||
504 | # do the write and track how much we just wrote | ||||
505 | |||||
506 | my $write_cnt = syswrite( $write_fh, ${$buf_ref}, | ||||
507 | $size_left, $offset ) ; | ||||
508 | |||||
509 | # since we're using syswrite Perl won't automatically restart the call | ||||
510 | # when interrupted by a signal. | ||||
511 | |||||
512 | next if $!{EINTR}; | ||||
513 | |||||
514 | unless ( defined $write_cnt ) { | ||||
515 | |||||
516 | @_ = ( $opts, "write_file '$file_name' - syswrite: $!"); | ||||
517 | goto &_error ; | ||||
518 | } | ||||
519 | |||||
520 | # track how much left to write and where to write from in the buffer | ||||
521 | |||||
522 | $size_left -= $write_cnt ; | ||||
523 | $offset += $write_cnt ; | ||||
524 | |||||
525 | } while( $size_left > 0 ) ; | ||||
526 | |||||
527 | # we truncate regular files in case we overwrite a long file with a shorter file | ||||
528 | # so seek to the current position to get it (same as tell()). | ||||
529 | |||||
530 | truncate( $write_fh, | ||||
531 | sysseek( $write_fh, 0, SEEK_CUR ) ) unless $no_truncate ; | ||||
532 | |||||
533 | close( $write_fh ) ; | ||||
534 | |||||
535 | # handle the atomic mode - move the temp file to the original filename. | ||||
536 | |||||
537 | if ( $opts->{'atomic'} && !rename( $file_name, $orig_file_name ) ) { | ||||
538 | |||||
539 | @_ = ( $opts, "write_file '$file_name' - rename: $!" ) ; | ||||
540 | goto &_error ; | ||||
541 | } | ||||
542 | |||||
543 | return 1 ; | ||||
544 | } | ||||
545 | |||||
546 | # this is for backwards compatibility with the previous File::Slurp module. | ||||
547 | # write_file always overwrites an existing file | ||||
548 | |||||
549 | 1 | 500ns | *overwrite_file = \&write_file ; | ||
550 | |||||
551 | # the current write_file has an append mode so we use that. this | ||||
552 | # supports the same API with an optional second argument which is a | ||||
553 | # hash ref of options. | ||||
554 | |||||
555 | sub append_file { | ||||
556 | |||||
557 | # get the optional opts hash ref | ||||
558 | my $opts = $_[1] ; | ||||
559 | if ( ref $opts eq 'HASH' ) { | ||||
560 | |||||
561 | # we were passed an opts ref so just mark the append mode | ||||
562 | |||||
563 | $opts->{append} = 1 ; | ||||
564 | } | ||||
565 | else { | ||||
566 | |||||
567 | # no opts hash so insert one with the append mode | ||||
568 | |||||
569 | splice( @_, 1, 0, { append => 1 } ) ; | ||||
570 | } | ||||
571 | |||||
572 | # magic goto the main write_file sub. this overlays the sub without touching | ||||
573 | # the stack or @_ | ||||
574 | |||||
575 | goto &write_file | ||||
576 | } | ||||
577 | |||||
578 | # prepend data to the beginning of a file | ||||
579 | |||||
580 | sub prepend_file { | ||||
581 | |||||
582 | my $file_name = shift ; | ||||
583 | |||||
584 | #print "FILE $file_name\n" ; | ||||
585 | |||||
586 | my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ; | ||||
587 | |||||
588 | # delete unsupported options | ||||
589 | |||||
590 | my @bad_opts = | ||||
591 | grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ; | ||||
592 | |||||
593 | delete @{$opts}{@bad_opts} ; | ||||
594 | |||||
595 | my $prepend_data = shift ; | ||||
596 | $prepend_data = '' unless defined $prepend_data ; | ||||
597 | $prepend_data = ${$prepend_data} if ref $prepend_data eq 'SCALAR' ; | ||||
598 | |||||
599 | #print "PRE [$prepend_data]\n" ; | ||||
600 | |||||
601 | my $err_mode = delete $opts->{err_mode} ; | ||||
602 | $opts->{ err_mode } = 'croak' ; | ||||
603 | $opts->{ scalar_ref } = 1 ; | ||||
604 | |||||
605 | my $existing_data = eval { read_file( $file_name, $opts ) } ; | ||||
606 | |||||
607 | if ( $@ ) { | ||||
608 | |||||
609 | @_ = ( { err_mode => $err_mode }, | ||||
610 | "prepend_file '$file_name' - read_file: $!" ) ; | ||||
611 | goto &_error ; | ||||
612 | } | ||||
613 | |||||
614 | #print "EXIST [$$existing_data]\n" ; | ||||
615 | |||||
616 | $opts->{atomic} = 1 ; | ||||
617 | my $write_result = | ||||
618 | eval { write_file( $file_name, $opts, | ||||
619 | $prepend_data, $$existing_data ) ; | ||||
620 | } ; | ||||
621 | |||||
622 | if ( $@ ) { | ||||
623 | |||||
624 | @_ = ( { err_mode => $err_mode }, | ||||
625 | "prepend_file '$file_name' - write_file: $!" ) ; | ||||
626 | goto &_error ; | ||||
627 | } | ||||
628 | |||||
629 | return $write_result ; | ||||
630 | } | ||||
631 | |||||
632 | # edit a file as a scalar in $_ | ||||
633 | |||||
634 | sub edit_file(&$;$) { | ||||
635 | |||||
636 | my( $edit_code, $file_name, $opts ) = @_ ; | ||||
637 | $opts = {} unless ref $opts eq 'HASH' ; | ||||
638 | |||||
639 | # my $edit_code = shift ; | ||||
640 | # my $file_name = shift ; | ||||
641 | # my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ; | ||||
642 | |||||
643 | #print "FILE $file_name\n" ; | ||||
644 | |||||
645 | # delete unsupported options | ||||
646 | |||||
647 | my @bad_opts = | ||||
648 | grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ; | ||||
649 | |||||
650 | delete @{$opts}{@bad_opts} ; | ||||
651 | |||||
652 | # keep the user err_mode and force croaking on internal errors | ||||
653 | |||||
654 | my $err_mode = delete $opts->{err_mode} ; | ||||
655 | $opts->{ err_mode } = 'croak' ; | ||||
656 | |||||
657 | # get a scalar ref for speed and slurp the file into a scalar | ||||
658 | |||||
659 | $opts->{ scalar_ref } = 1 ; | ||||
660 | my $existing_data = eval { read_file( $file_name, $opts ) } ; | ||||
661 | |||||
662 | if ( $@ ) { | ||||
663 | |||||
664 | @_ = ( { err_mode => $err_mode }, | ||||
665 | "edit_file '$file_name' - read_file: $!" ) ; | ||||
666 | goto &_error ; | ||||
667 | } | ||||
668 | |||||
669 | #print "EXIST [$$existing_data]\n" ; | ||||
670 | |||||
671 | my( $edited_data ) = map { $edit_code->(); $_ } $$existing_data ; | ||||
672 | |||||
673 | $opts->{atomic} = 1 ; | ||||
674 | my $write_result = | ||||
675 | eval { write_file( $file_name, $opts, $edited_data ) } ; | ||||
676 | |||||
677 | if ( $@ ) { | ||||
678 | |||||
679 | @_ = ( { err_mode => $err_mode }, | ||||
680 | "edit_file '$file_name' - write_file: $!" ) ; | ||||
681 | goto &_error ; | ||||
682 | } | ||||
683 | |||||
684 | return $write_result ; | ||||
685 | } | ||||
686 | |||||
687 | sub edit_file_lines(&$;$) { | ||||
688 | |||||
689 | my( $edit_code, $file_name, $opts ) = @_ ; | ||||
690 | $opts = {} unless ref $opts eq 'HASH' ; | ||||
691 | |||||
692 | # my $edit_code = shift ; | ||||
693 | # my $file_name = shift ; | ||||
694 | # my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ; | ||||
695 | |||||
696 | #print "FILE $file_name\n" ; | ||||
697 | |||||
698 | # delete unsupported options | ||||
699 | |||||
700 | my @bad_opts = | ||||
701 | grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ; | ||||
702 | |||||
703 | delete @{$opts}{@bad_opts} ; | ||||
704 | |||||
705 | # keep the user err_mode and force croaking on internal errors | ||||
706 | |||||
707 | my $err_mode = delete $opts->{err_mode} ; | ||||
708 | $opts->{ err_mode } = 'croak' ; | ||||
709 | |||||
710 | # get an array ref for speed and slurp the file into lines | ||||
711 | |||||
712 | $opts->{ array_ref } = 1 ; | ||||
713 | my $existing_data = eval { read_file( $file_name, $opts ) } ; | ||||
714 | |||||
715 | if ( $@ ) { | ||||
716 | |||||
717 | @_ = ( { err_mode => $err_mode }, | ||||
718 | "edit_file_lines '$file_name' - read_file: $!" ) ; | ||||
719 | goto &_error ; | ||||
720 | } | ||||
721 | |||||
722 | #print "EXIST [$$existing_data]\n" ; | ||||
723 | |||||
724 | my @edited_data = map { $edit_code->(); $_ } @$existing_data ; | ||||
725 | |||||
726 | $opts->{atomic} = 1 ; | ||||
727 | my $write_result = | ||||
728 | eval { write_file( $file_name, $opts, @edited_data ) } ; | ||||
729 | |||||
730 | if ( $@ ) { | ||||
731 | |||||
732 | @_ = ( { err_mode => $err_mode }, | ||||
733 | "edit_file_lines '$file_name' - write_file: $!" ) ; | ||||
734 | goto &_error ; | ||||
735 | } | ||||
736 | |||||
737 | return $write_result ; | ||||
738 | } | ||||
739 | |||||
740 | # basic wrapper around opendir/readdir | ||||
741 | |||||
742 | sub read_dir { | ||||
743 | |||||
744 | my $dir = shift ; | ||||
745 | my $opts = ( ref $_[0] eq 'HASH' ) ? shift : { @_ } ; | ||||
746 | |||||
747 | # this handle will be destroyed upon return | ||||
748 | |||||
749 | local(*DIRH); | ||||
750 | |||||
751 | # open the dir and handle any errors | ||||
752 | |||||
753 | unless ( opendir( DIRH, $dir ) ) { | ||||
754 | |||||
755 | @_ = ( $opts, "read_dir '$dir' - opendir: $!" ) ; | ||||
756 | goto &_error ; | ||||
757 | } | ||||
758 | |||||
759 | my @dir_entries = readdir(DIRH) ; | ||||
760 | |||||
761 | @dir_entries = grep( $_ ne "." && $_ ne "..", @dir_entries ) | ||||
762 | unless $opts->{'keep_dot_dot'} ; | ||||
763 | |||||
764 | if ( $opts->{'prefix'} ) { | ||||
765 | |||||
766 | substr( $_, 0, 0, "$dir/" ) for @dir_entries ; | ||||
767 | } | ||||
768 | |||||
769 | return @dir_entries if wantarray ; | ||||
770 | return \@dir_entries ; | ||||
771 | } | ||||
772 | |||||
773 | # error handling section | ||||
774 | # | ||||
775 | # all the error handling uses magic goto so the caller will get the | ||||
776 | # error message as if from their code and not this module. if we just | ||||
777 | # did a call on the error code, the carp/croak would report it from | ||||
778 | # this module since the error sub is one level down on the call stack | ||||
779 | # from read_file/write_file/read_dir. | ||||
780 | |||||
781 | |||||
782 | 1 | 3µs | my %err_func = ( | ||
783 | 'carp' => \&carp, | ||||
784 | 'croak' => \&croak, | ||||
785 | ) ; | ||||
786 | |||||
787 | sub _error { | ||||
788 | |||||
789 | my( $opts, $err_msg ) = @_ ; | ||||
790 | |||||
791 | # get the error function to use | ||||
792 | |||||
793 | my $func = $err_func{ $opts->{'err_mode'} || 'croak' } ; | ||||
794 | |||||
795 | # if we didn't find it in our error function hash, they must have set | ||||
796 | # it to quiet and we don't do anything. | ||||
797 | |||||
798 | return unless $func ; | ||||
799 | |||||
800 | # call the carp/croak function | ||||
801 | |||||
802 | $func->($err_msg) if $func ; | ||||
803 | |||||
804 | # return a hard undef (in list context this will be a single value of | ||||
805 | # undef which is not a legal in-band value) | ||||
806 | |||||
807 | return undef ; | ||||
808 | } | ||||
809 | |||||
810 | 1 | 14µs | 1; | ||
811 | __END__ | ||||
# spent 2µs within File::Slurp::CORE:ftis which was called:
# once (2µs+0s) by File::Slurp::read_file at line 116 | |||||
sub File::Slurp::CORE:ftsize; # opcode | |||||
# spent 4µs within File::Slurp::CORE:match which was called:
# once (4µs+0s) by Tapper::Config::BEGIN@16 at line 54 | |||||
# spent 30µs within File::Slurp::CORE:sysopen which was called:
# once (30µs+0s) by File::Slurp::read_file at line 121 | |||||
# spent 11µs within File::Slurp::CORE:sysread which was called:
# once (11µs+0s) by File::Slurp::read_file at line 127 |