| 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 | File::Slurp::BEGIN@12 |
| 1 | 1 | 1 | 564µs | 5.56ms | File::Slurp::BEGIN@11 |
| 1 | 1 | 1 | 57µs | 101µs | File::Slurp::read_file |
| 1 | 1 | 1 | 30µs | 30µs | File::Slurp::CORE:sysopen (opcode) |
| 1 | 1 | 1 | 25µs | 25µs | File::Slurp::BEGIN@3 |
| 1 | 1 | 1 | 11µs | 11µs | File::Slurp::CORE:sysread (opcode) |
| 1 | 1 | 1 | 10µs | 28µs | File::Slurp::BEGIN@263 |
| 1 | 1 | 1 | 9µs | 2.02ms | File::Slurp::BEGIN@10 |
| 1 | 1 | 1 | 8µs | 8µs | File::Slurp::BEGIN@62 |
| 1 | 1 | 1 | 8µs | 43µs | File::Slurp::BEGIN@8 |
| 1 | 1 | 1 | 8µs | 83µs | File::Slurp::BEGIN@15 |
| 1 | 1 | 1 | 8µs | 12µs | File::Slurp::BEGIN@5 |
| 1 | 1 | 1 | 8µs | 22µs | File::Slurp::BEGIN@6 |
| 1 | 1 | 1 | 6µs | 17µs | File::Slurp::BEGIN@9 |
| 1 | 1 | 1 | 4µs | 4µs | File::Slurp::CORE:match (opcode) |
| 1 | 1 | 1 | 2µs | 2µs | File::Slurp::CORE:ftis (opcode) |
| 3 | 2 | 1 | 1µs | 1µs | File::Slurp::CORE:ftsize (opcode) |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:64] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:65] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:66] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:70] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:71] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:72] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:78] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:79] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:80] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:83] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:84] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:85] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:88] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:89] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::__ANON__[:90] |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::_check_ref |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::_error |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::_seek_data_handle |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::append_file |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::edit_file |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::edit_file_lines |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::prepend_file |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::read_dir |
| 0 | 0 | 0 | 0s | 0s | File::Slurp::write_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 # 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 |