← Index
NYTProf Performance Profile   « block view • line view • sub view »
For xt/tapper-mcp-scheduler-with-db-longrun.t
  Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:22:35 2012

Filename/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/File/Slurp.pm
StatementsExecuted 56 statements in 2.77ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1111.52ms1.63msFile::Slurp::::BEGIN@12File::Slurp::BEGIN@12
111564µs5.56msFile::Slurp::::BEGIN@11File::Slurp::BEGIN@11
11157µs101µsFile::Slurp::::read_fileFile::Slurp::read_file
11130µs30µsFile::Slurp::::CORE:sysopenFile::Slurp::CORE:sysopen (opcode)
11125µs25µsFile::Slurp::::BEGIN@3File::Slurp::BEGIN@3
11111µs11µsFile::Slurp::::CORE:sysreadFile::Slurp::CORE:sysread (opcode)
11110µs28µsFile::Slurp::::BEGIN@263File::Slurp::BEGIN@263
1119µs2.02msFile::Slurp::::BEGIN@10File::Slurp::BEGIN@10
1118µs8µsFile::Slurp::::BEGIN@62File::Slurp::BEGIN@62
1118µs43µsFile::Slurp::::BEGIN@8File::Slurp::BEGIN@8
1118µs83µsFile::Slurp::::BEGIN@15File::Slurp::BEGIN@15
1118µs12µsFile::Slurp::::BEGIN@5File::Slurp::BEGIN@5
1118µs22µsFile::Slurp::::BEGIN@6File::Slurp::BEGIN@6
1116µs17µsFile::Slurp::::BEGIN@9File::Slurp::BEGIN@9
1114µs4µsFile::Slurp::::CORE:matchFile::Slurp::CORE:match (opcode)
1112µs2µsFile::Slurp::::CORE:ftisFile::Slurp::CORE:ftis (opcode)
3211µs1µsFile::Slurp::::CORE:ftsizeFile::Slurp::CORE:ftsize (opcode)
0000s0sFile::Slurp::::__ANON__[:64]File::Slurp::__ANON__[:64]
0000s0sFile::Slurp::::__ANON__[:65]File::Slurp::__ANON__[:65]
0000s0sFile::Slurp::::__ANON__[:66]File::Slurp::__ANON__[:66]
0000s0sFile::Slurp::::__ANON__[:70]File::Slurp::__ANON__[:70]
0000s0sFile::Slurp::::__ANON__[:71]File::Slurp::__ANON__[:71]
0000s0sFile::Slurp::::__ANON__[:72]File::Slurp::__ANON__[:72]
0000s0sFile::Slurp::::__ANON__[:78]File::Slurp::__ANON__[:78]
0000s0sFile::Slurp::::__ANON__[:79]File::Slurp::__ANON__[:79]
0000s0sFile::Slurp::::__ANON__[:80]File::Slurp::__ANON__[:80]
0000s0sFile::Slurp::::__ANON__[:83]File::Slurp::__ANON__[:83]
0000s0sFile::Slurp::::__ANON__[:84]File::Slurp::__ANON__[:84]
0000s0sFile::Slurp::::__ANON__[:85]File::Slurp::__ANON__[:85]
0000s0sFile::Slurp::::__ANON__[:88]File::Slurp::__ANON__[:88]
0000s0sFile::Slurp::::__ANON__[:89]File::Slurp::__ANON__[:89]
0000s0sFile::Slurp::::__ANON__[:90]File::Slurp::__ANON__[:90]
0000s0sFile::Slurp::::_check_refFile::Slurp::_check_ref
0000s0sFile::Slurp::::_errorFile::Slurp::_error
0000s0sFile::Slurp::::_seek_data_handleFile::Slurp::_seek_data_handle
0000s0sFile::Slurp::::append_fileFile::Slurp::append_file
0000s0sFile::Slurp::::edit_fileFile::Slurp::edit_file
0000s0sFile::Slurp::::edit_file_linesFile::Slurp::edit_file_lines
0000s0sFile::Slurp::::prepend_fileFile::Slurp::prepend_file
0000s0sFile::Slurp::::read_dirFile::Slurp::read_dir
0000s0sFile::Slurp::::write_fileFile::Slurp::write_file
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package File::Slurp;
2
3333µs125µs
# spent 25µs within File::Slurp::BEGIN@3 which was called: # once (25µs+0s) by Tapper::Config::BEGIN@16 at line 3
use 5.6.2 ;
# spent 25µs making 1 call to File::Slurp::BEGIN@3
4
5321µs215µ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
use strict;
# spent 12µs making 1 call to File::Slurp::BEGIN@5 # spent 4µs making 1 call to strict::import
6319µs237µ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
use warnings ;
# spent 22µs making 1 call to File::Slurp::BEGIN@6 # spent 15µs making 1 call to warnings::import
7
8318µs277µ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
use Carp ;
# spent 43µs making 1 call to File::Slurp::BEGIN@8 # spent 34µs making 1 call to Exporter::import
9320µs228µ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
use Exporter ;
# spent 17µs making 1 call to File::Slurp::BEGIN@9 # spent 11µs making 1 call to Exporter::import
10327µs24.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
use Fcntl qw( :DEFAULT ) ;
# spent 2.02ms making 1 call to File::Slurp::BEGIN@10 # spent 2.01ms making 1 call to Exporter::import
113109µs28.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
use POSIX qw( :fcntl_h ) ;
# spent 5.56ms making 1 call to File::Slurp::BEGIN@11 # spent 2.65ms making 1 call to POSIX::import
123147µs21.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
use Errno ;
# spent 1.63ms making 1 call to File::Slurp::BEGIN@12 # spent 22µs making 1 call to Exporter::import
13#use Symbol ;
14
153355µs2157µ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
use vars qw( @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION ) ;
# spent 83µs making 1 call to File::Slurp::BEGIN@15 # spent 75µs making 1 call to vars::import
16110µs@ISA = qw( Exporter ) ;
17
181600ns$VERSION = '9999.19';
19
2012µsmy @std_export = qw(
21 read_file
22 write_file
23 overwrite_file
24 append_file
25 read_dir
26) ;
27
281700nsmy @edit_export = qw(
29 edit_file
30 edit_file_lines
31) ;
32
331300nsmy @ok_export = qw(
34) ;
35
3611µs@EXPORT_OK = (
37 @edit_export,
38 qw(
39 slurp
40 prepend_file
41 ),
42) ;
43
4417µs%EXPORT_TAGS = (
45 'all' => [ @std_export, @edit_export, @EXPORT_OK ],
46 'edit' => [ @edit_export ],
47 'std' => [ @std_export ],
48) ;
49
501900ns@EXPORT = @std_export ;
51
521300nsmy $max_fast_slurp_size = 1024 * 100 ;
53
54112µs14µsmy $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
BEGIN {
6339µ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 }
931424µs18µ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
10511µ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
sub read_file {
108
1099102µ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
11633µ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 ;
121130µ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
127212µ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
26331.43ms247µ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
use re 'taint' ;
# 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
296sub _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
329sub _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 ;
346Can't find B.pm with this Perl: $!.
347That module is needed to properly slurp the DATA handle.
348ERR
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
366sub 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
5491500ns*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
555sub 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
580sub 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
634sub 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
687sub 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
742sub 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
78213µsmy %err_func = (
783 'carp' => \&carp,
784 'croak' => \&croak,
785) ;
786
787sub _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
810114µs1;
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:ftis; # opcode
# spent 1µs within File::Slurp::CORE:ftsize which was called 3 times, avg 433ns/call: # 2 times (900ns+0s) by File::Slurp::read_file at line 116, avg 450ns/call # once (400ns+0s) by File::Slurp::read_file at line 127
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
sub File::Slurp::CORE:match; # opcode
# spent 30µs within File::Slurp::CORE:sysopen which was called: # once (30µs+0s) by File::Slurp::read_file at line 121
sub File::Slurp::CORE:sysopen; # opcode
# spent 11µs within File::Slurp::CORE:sysread which was called: # once (11µs+0s) by File::Slurp::read_file at line 127
sub File::Slurp::CORE:sysread; # opcode