Profile of File/Slurp.pm

← 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:23:42 2012

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

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 1.52ms | 1.63ms | File::Slurp::::BEGIN@12File::Slurp::BEGIN@12
1 | 1 | 1 | 564µs | 5.56ms | File::Slurp::::BEGIN@11File::Slurp::BEGIN@11
1 | 1 | 1 | 57µs | 101µs | File::Slurp::::read_fileFile::Slurp::read_file
1 | 1 | 1 | 30µs | 30µs | File::Slurp::::CORE:sysopenFile::Slurp::CORE:sysopen (opcode)
1 | 1 | 1 | 25µs | 25µs | File::Slurp::::BEGIN@3File::Slurp::BEGIN@3
1 | 1 | 1 | 11µs | 11µs | File::Slurp::::CORE:sysreadFile::Slurp::CORE:sysread (opcode)
1 | 1 | 1 | 10µs | 28µs | File::Slurp::::BEGIN@263File::Slurp::BEGIN@263
1 | 1 | 1 | 9µs | 2.02ms | File::Slurp::::BEGIN@10File::Slurp::BEGIN@10
1 | 1 | 1 | 8µs | 8µs | File::Slurp::::BEGIN@62File::Slurp::BEGIN@62
1 | 1 | 1 | 8µs | 43µs | File::Slurp::::BEGIN@8File::Slurp::BEGIN@8
1 | 1 | 1 | 8µs | 83µs | File::Slurp::::BEGIN@15File::Slurp::BEGIN@15
1 | 1 | 1 | 8µs | 12µs | File::Slurp::::BEGIN@5File::Slurp::BEGIN@5
1 | 1 | 1 | 8µs | 22µs | File::Slurp::::BEGIN@6File::Slurp::BEGIN@6
1 | 1 | 1 | 6µs | 17µs | File::Slurp::::BEGIN@9File::Slurp::BEGIN@9
1 | 1 | 1 | 4µs | 4µs | File::Slurp::::CORE:matchFile::Slurp::CORE:match (opcode)
1 | 1 | 1 | 2µs | 2µs | File::Slurp::::CORE:ftisFile::Slurp::CORE:ftis (opcode)
3 | 2 | 1 | 1µs | 1µs | File::Slurp::::CORE:ftsizeFile::Slurp::CORE:ftsize (opcode)
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:64]File::Slurp::__ANON__[:64]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:65]File::Slurp::__ANON__[:65]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:66]File::Slurp::__ANON__[:66]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:70]File::Slurp::__ANON__[:70]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:71]File::Slurp::__ANON__[:71]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:72]File::Slurp::__ANON__[:72]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:78]File::Slurp::__ANON__[:78]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:79]File::Slurp::__ANON__[:79]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:80]File::Slurp::__ANON__[:80]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:83]File::Slurp::__ANON__[:83]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:84]File::Slurp::__ANON__[:84]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:85]File::Slurp::__ANON__[:85]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:88]File::Slurp::__ANON__[:88]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:89]File::Slurp::__ANON__[:89]
0 | 0 | 0 | 0s | 0s | File::Slurp::::__ANON__[:90]File::Slurp::__ANON__[:90]
0 | 0 | 0 | 0s | 0s | File::Slurp::::_check_refFile::Slurp::_check_ref
0 | 0 | 0 | 0s | 0s | File::Slurp::::_errorFile::Slurp::_error
0 | 0 | 0 | 0s | 0s | File::Slurp::::_seek_data_handleFile::Slurp::_seek_data_handle
0 | 0 | 0 | 0s | 0s | File::Slurp::::append_fileFile::Slurp::append_file
0 | 0 | 0 | 0s | 0s | File::Slurp::::edit_fileFile::Slurp::edit_file
0 | 0 | 0 | 0s | 0s | File::Slurp::::edit_file_linesFile::Slurp::edit_file_lines
0 | 0 | 0 | 0s | 0s | File::Slurp::::prepend_fileFile::Slurp::prepend_file
0 | 0 | 0 | 0s | 0s | File::Slurp::::read_dirFile::Slurp::read_dir
0 | 0 | 0 | 0s | 0s | File::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
--- | --- | --- | --- | --- | ---
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 use 5.6.2 ; # 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 use strict; # 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 use warnings ; # 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 use Carp ; # 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 use Exporter ; # 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 use Fcntl qw( :DEFAULT ) ; # 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 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
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 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 |  |  |  |  |
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 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
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 BEGIN {
63 | 1 | 800ns |  |  | unless( defined &SEEK_SET ) {
64 |  |  |  |  | *SEEK_SET = sub { 0 };
65 |  |  |  |  | *SEEK_CUR = sub { 1 };
66 |  |  |  |  | *SEEK_END = sub { 2 };
67 |  |  |  |  | }
68 |  |  |  |  |
69 | 1 | 200ns |  |  | unless( defined &O_BINARY ) {
70 |  |  |  |  | *O_BINARY = sub { 0 };
71 |  |  |  |  | *O_RDONLY = sub { 0 };
72 |  |  |  |  | *O_WRONLY = sub { 1 };
73 |  |  |  |  | }
74 |  |  |  |  |
75 | 1 | 8µs |  |  | 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 sub read_file {
108 |  |  |  |  |
109 | 1 | 900ns |  |  | my $file_name = shift ;
110 | 1 | 2µs |  |  | 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 | 1 | 15µ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 | 1 | 300ns |  |  | my $fh ;
121 | 1 | 40µs | 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 | 1 | 18µs | 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 | 1 | 300ns |  |  | unless ( defined $read_cnt ) {
130 |  |  |  |  |
131 |  |  |  |  | @_ = ( $opts,
132 |  |  |  |  | "read_file '$file_name' - small sysread: $!");
133 |  |  |  |  | goto &_error ;
134 |  |  |  |  | }
135 |  |  |  |  |
136 | 1 | 400ns |  |  | $buf =~ s/\015\012/\n/g if $is_win32 ;
137 | 1 | 25µs |  |  | 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 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 |  |  |  |  |
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: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