8 use Fcntl qw( :DEFAULT ) ;
9 use POSIX qw( :fcntl_h ) ;
13 use vars qw( %EXPORT_TAGS @EXPORT_OK $VERSION @EXPORT ) ;
15 %EXPORT_TAGS = ( 'all' => [
16 qw( read_file write_file overwrite_file append_file read_dir ) ] ) ;
18 @EXPORT = ( @{ $EXPORT_TAGS{'all'} } );
19 @EXPORT_OK = qw( slurp ) ;
23 our $max_fast_slurp_size = 1024 * 100 ;
25 my $is_win32 = $^O =~ /win32/i ;
27 # Install subs for various constants that aren't set in older perls
28 # (< 5.005). Fcntl on old perls uses Exporter to define subs without a
29 # () prototype These can't be overridden with the constant pragma or
30 # we get a prototype mismatch. Hence this less than aesthetically
31 # appealing BEGIN block:
34 unless( defined &SEEK_SET ) {
35 *SEEK_SET = sub { 0 };
36 *SEEK_CUR = sub { 1 };
37 *SEEK_END = sub { 2 };
40 unless( defined &O_BINARY ) {
41 *O_BINARY = sub { 0 };
42 *O_RDONLY = sub { 0 };
43 *O_WRONLY = sub { 1 };
46 unless ( defined O_APPEND ) {
48 if ( $^O =~ /olaris/ ) {
49 *O_APPEND = sub { 8 };
50 *O_CREAT = sub { 256 };
51 *O_EXCL = sub { 1024 };
53 elsif ( $^O =~ /inux/ ) {
54 *O_APPEND = sub { 1024 };
55 *O_CREAT = sub { 64 };
56 *O_EXCL = sub { 128 };
58 elsif ( $^O =~ /BSD/i ) {
59 *O_APPEND = sub { 8 };
60 *O_CREAT = sub { 512 };
61 *O_EXCL = sub { 2048 };
66 # print "OS [$^O]\n" ;
68 # print "O_BINARY = ", O_BINARY(), "\n" ;
69 # print "O_RDONLY = ", O_RDONLY(), "\n" ;
70 # print "O_WRONLY = ", O_WRONLY(), "\n" ;
71 # print "O_APPEND = ", O_APPEND(), "\n" ;
72 # print "O_CREAT ", O_CREAT(), "\n" ;
73 # print "O_EXCL ", O_EXCL(), "\n" ;
76 *slurp = \&read_file ;
80 my( $file_name, %args ) = @_ ;
82 if ( !ref $file_name && 0 &&
83 -e $file_name && -s _ < $max_fast_slurp_size && ! %args && !wantarray ) {
87 unless( open( FH, $file_name ) ) {
89 @_ = ( \%args, "read_file '$file_name' - sysopen: $!");
93 my $read_cnt = sysread( FH, my $buf, -s _ ) ;
95 unless ( defined $read_cnt ) {
97 # handle the read error
100 "read_file '$file_name' - small sysread: $!");
107 # set the buffer to either the passed in one or ours and init it to the null
111 my $buf_ref = $args{'buf_ref'} || \$buf ;
114 my( $read_fh, $size_left, $blk_size ) ;
116 # check if we are reading from a handle (glob ref or IO:: object)
118 if ( ref $file_name ) {
120 # slurping a handle so use it and don't open anything.
121 # set the block size so we know it is a handle and read that amount
123 $read_fh = $file_name ;
124 $blk_size = $args{'blk_size'} || 1024 * 1024 ;
125 $size_left = $blk_size ;
127 # DEEP DARK MAGIC. this checks the UNTAINT IO flag of a
128 # glob/handle. only the DATA handle is untainted (since it is from
129 # trusted data in the source file). this allows us to test if this is
130 # the DATA handle and then to do a sysseek to make sure it gets
131 # slurped correctly. on some systems, the buffered i/o pointer is not
132 # left at the same place as the fd pointer. this sysseek makes them
133 # the same so slurping with sysread will work.
139 @_ = ( \%args, <<ERR ) ;
140 Can't find B.pm with this Perl: $!.
141 That module is needed to slurp the DATA handle.
146 if ( B::svref_2object( $read_fh )->IO->IoFLAGS & 16 ) {
148 # set the seek position to the current tell.
150 sysseek( $read_fh, tell( $read_fh ), SEEK_SET ) ||
156 # a regular file. set the sysopen mode
158 my $mode = O_RDONLY ;
160 #printf "RD: BINARY %x MODE %x\n", O_BINARY, $mode ;
162 # open the file and handle any error
165 unless ( sysopen( $read_fh, $file_name, $mode ) ) {
166 @_ = ( \%args, "read_file '$file_name' - sysopen: $!");
170 if ( my $binmode = $args{'binmode'} ) {
171 binmode( $read_fh, $binmode ) ;
174 # get the size of the file for use in the read loop
176 $size_left = -s $read_fh ;
178 #print "SIZE $size_left\n" ;
181 # we need a blk_size if the size is 0 so we can handle pseudofiles like in
182 # /proc. these show as 0 size but have data to be slurped.
184 unless( $size_left ) {
186 $blk_size = $args{'blk_size'} || 1024 * 1024 ;
187 $size_left = $blk_size ;
192 # if ( $size_left < 10000 && keys %args == 0 && !wantarray ) {
194 # #print "OPT\n" and $printed++ unless $printed ;
196 # my $read_cnt = sysread( $read_fh, my $buf, $size_left ) ;
198 # unless ( defined $read_cnt ) {
200 # # handle the read error
202 # @_ = ( \%args, "read_file '$file_name' - small2 sysread: $!");
209 # infinite read loop. we exit when we are done slurping
213 # do the read and see how much we got
215 my $read_cnt = sysread( $read_fh, ${$buf_ref},
216 $size_left, length ${$buf_ref} ) ;
218 unless ( defined $read_cnt ) {
220 # handle the read error
222 @_ = ( \%args, "read_file '$file_name' - loop sysread: $!");
226 # good read. see if we hit EOF (nothing left to read)
228 last if $read_cnt == 0 ;
230 # loop if we are slurping a handle. we don't track $size_left then.
234 # count down how much we read and loop if we have more to read.
236 $size_left -= $read_cnt ;
237 last if $size_left <= 0 ;
240 # fix up cr/lf to be a newline if this is a windows text file
242 ${$buf_ref} =~ s/\015\012/\n/g if $is_win32 && !$args{'binmode'} ;
244 # this is the 5 returns in a row. each handles one possible
245 # combination of caller context and requested return type
248 $sep = '\n\n+' if defined $sep && $sep eq '' ;
250 # caller wants to get an array ref of lines
252 # this split doesn't work since it tries to use variable length lookbehind
253 # the m// line works.
254 # return [ split( m|(?<=$sep)|, ${$buf_ref} ) ] if $args{'array_ref'} ;
255 return [ length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : () ]
256 if $args{'array_ref'} ;
258 # caller wants a list of lines (normal list context)
260 # same problem with this split as before.
261 # return split( m|(?<=$sep)|, ${$buf_ref} ) if wantarray ;
262 return length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : ()
265 # caller wants a scalar ref to the slurped text
267 return $buf_ref if $args{'scalar_ref'} ;
269 # caller wants a scalar with the slurped text (normal scalar context)
271 return ${$buf_ref} if defined wantarray ;
273 # caller passed in an i/o buffer by reference (normal void context)
280 my $file_name = shift ;
282 # get the optional argument hash ref from @_ or an empty hash ref.
284 my $args = ( ref $_[0] eq 'HASH' ) ? shift : {} ;
286 my( $buf_ref, $write_fh, $no_truncate, $orig_file_name, $data_is_ref ) ;
288 # get the buffer ref - it depends on how the data is passed into write_file
289 # after this if/else $buf_ref will have a scalar ref to the data.
291 if ( ref $args->{'buf_ref'} eq 'SCALAR' ) {
293 # a scalar ref passed in %args has the data
294 # note that the data was passed by ref
296 $buf_ref = $args->{'buf_ref'} ;
299 elsif ( ref $_[0] eq 'SCALAR' ) {
301 # the first value in @_ is the scalar ref to the data
302 # note that the data was passed by ref
307 elsif ( ref $_[0] eq 'ARRAY' ) {
309 # the first value in @_ is the array ref to the data so join it.
311 ${$buf_ref} = join '', @{$_[0]} ;
315 # good old @_ has all the data so join it.
317 ${$buf_ref} = join '', @_ ;
320 # see if we were passed a open handle to spew to.
322 if ( ref $file_name ) {
324 # we have a handle. make sure we don't call truncate on it.
326 $write_fh = $file_name ;
331 # spew to regular file.
333 if ( $args->{'atomic'} ) {
335 # in atomic mode, we spew to a temp file so make one and save the original
337 $orig_file_name = $file_name ;
338 $file_name .= ".$$" ;
341 # set the mode for the sysopen
343 my $mode = O_WRONLY | O_CREAT ;
344 $mode |= O_APPEND if $args->{'append'} ;
345 $mode |= O_EXCL if $args->{'no_clobber'} ;
347 #printf "WR: BINARY %x MODE %x\n", O_BINARY, $mode ;
349 # open the file and handle any error.
352 unless ( sysopen( $write_fh, $file_name, $mode ) ) {
353 @_ = ( $args, "write_file '$file_name' - sysopen: $!");
358 if ( my $binmode = $args->{'binmode'} ) {
359 binmode( $write_fh, $binmode ) ;
362 sysseek( $write_fh, 0, SEEK_END ) if $args->{'append'} ;
365 #print 'WR before data ', unpack( 'H*', ${$buf_ref}), "\n" ;
367 # fix up newline to write cr/lf if this is a windows text file
369 if ( $is_win32 && !$args->{'binmode'} ) {
371 # copy the write data if it was passed by ref so we don't clobber the
373 $buf_ref = \do{ my $copy = ${$buf_ref}; } if $data_is_ref ;
374 ${$buf_ref} =~ s/\n/\015\012/g ;
377 #print 'after data ', unpack( 'H*', ${$buf_ref}), "\n" ;
379 # get the size of how much we are writing and init the offset into that buffer
381 my $size_left = length( ${$buf_ref} ) ;
384 # loop until we have no more data left to write
388 # do the write and track how much we just wrote
390 my $write_cnt = syswrite( $write_fh, ${$buf_ref},
391 $size_left, $offset ) ;
393 unless ( defined $write_cnt ) {
396 @_ = ( $args, "write_file '$file_name' - syswrite: $!");
400 # track much left to write and where to write from in the buffer
402 $size_left -= $write_cnt ;
403 $offset += $write_cnt ;
405 } while( $size_left > 0 ) ;
407 # we truncate regular files in case we overwrite a long file with a shorter file
408 # so seek to the current position to get it (same as tell()).
411 sysseek( $write_fh, 0, SEEK_CUR ) ) unless $no_truncate ;
415 # handle the atomic mode - move the temp file to the original filename.
417 if ( $args->{'atomic'} && !rename( $file_name, $orig_file_name ) ) {
420 @_ = ( $args, "write_file '$file_name' - rename: $!" ) ;
427 # this is for backwards compatibility with the previous File::Slurp module.
428 # write_file always overwrites an existing file
430 *overwrite_file = \&write_file ;
432 # the current write_file has an append mode so we use that. this
433 # supports the same API with an optional second argument which is a
434 # hash ref of options.
438 # get the optional args hash ref
440 if ( ref $args eq 'HASH' ) {
442 # we were passed an args ref so just mark the append mode
444 $args->{append} = 1 ;
448 # no args hash so insert one with the append mode
450 splice( @_, 1, 0, { append => 1 } ) ;
453 # magic goto the main write_file sub. this overlays the sub without touching
459 # basic wrapper around opendir/readdir
463 my ($dir, %args ) = @_;
465 # this handle will be destroyed upon return
469 # open the dir and handle any errors
471 unless ( opendir( DIRH, $dir ) ) {
473 @_ = ( \%args, "read_dir '$dir' - opendir: $!" ) ;
477 my @dir_entries = readdir(DIRH) ;
479 @dir_entries = grep( $_ ne "." && $_ ne "..", @dir_entries )
480 unless $args{'keep_dot_dot'} ;
482 return @dir_entries if wantarray ;
483 return \@dir_entries ;
486 # error handling section
488 # all the error handling uses magic goto so the caller will get the
489 # error message as if from their code and not this module. if we just
490 # did a call on the error code, the carp/croak would report it from
491 # this module since the error sub is one level down on the call stack
492 # from read_file/write_file/read_dir.
502 my( $args, $err_msg ) = @_ ;
504 # get the error function to use
506 my $func = $err_func{ $args->{'err_mode'} || 'croak' } ;
508 # if we didn't find it in our error function hash, they must have set
509 # it to quiet and we don't do anything.
511 return unless $func ;
513 # call the carp/croak function
517 # return a hard undef (in list context this will be a single value of
518 # undef which is not a legal in-band value)
528 File::Slurp - Efficient Reading/Writing of Complete Files
534 my $text = read_file( 'filename' ) ;
535 my @lines = read_file( 'filename' ) ;
537 write_file( 'filename', @lines ) ;
539 use File::Slurp qw( slurp ) ;
541 my $text = slurp( 'filename' ) ;
546 This module provides subs that allow you to read or write entire files
547 with one simple call. They are designed to be simple to use, have
548 flexible ways to pass in or get the file contents and to be very
549 efficient. There is also a sub to read in all the files in a
550 directory other than C<.> and C<..>
552 These slurp/spew subs work for files, pipes and
553 sockets, and stdio, pseudo-files, and DATA.
557 This sub reads in an entire file and returns its contents to the
558 caller. In list context it will return a list of lines (using the
559 current value of $/ as the separator including support for paragraph
560 mode when it is set to ''). In scalar context it returns the entire
561 file as a single scalar.
563 my $text = read_file( 'filename' ) ;
564 my @lines = read_file( 'filename' ) ;
566 The first argument to C<read_file> is the filename and the rest of the
567 arguments are key/value pairs which are optional and which modify the
568 behavior of the call. Other than binmode the options all control how
569 the slurped file is returned to the caller.
571 If the first argument is a file handle reference or I/O object (if ref
572 is true), then that handle is slurped in. This mode is supported so
573 you slurp handles such as C<DATA>, C<STDIN>. See the test handle.t
574 for an example that does C<open( '-|' )> and child process spews data
575 to the parant which slurps it in. All of the options that control how
576 the data is returned to the caller still work in this case.
578 NOTE: as of version 9999.06, read_file works correctly on the C<DATA>
579 handle. It used to need a sysseek workaround but that is now handled
580 when needed by the module itself.
582 You can optionally request that C<slurp()> is exported to your code. This
583 is an alias for read_file and is meant to be forward compatible with
584 Perl 6 (which will have slurp() built-in).
590 If you set the binmode option, then the option will be passed to a
591 binmode call on the opened filehandle.
593 my $bin_data = read_file( $bin_file, binmode => ':raw' ) ;
594 my $utf_text = read_file( $bin_file, binmode => ':utf8' ) ;
598 If this boolean option is set, the return value (only in scalar
599 context) will be an array reference which contains the lines of the
600 slurped file. The following two calls are equivalent:
602 my $lines_ref = read_file( $bin_file, array_ref => 1 ) ;
603 my $lines_ref = [ read_file( $bin_file ) ] ;
607 If this boolean option is set, the return value (only in scalar
608 context) will be an scalar reference to a string which is the contents
609 of the slurped file. This will usually be faster than returning the
612 my $text_ref = read_file( $bin_file, scalar_ref => 1 ) ;
616 You can use this option to pass in a scalar reference and the slurped
617 file contents will be stored in the scalar. This can be used in
618 conjunction with any of the other options.
620 my $text_ref = read_file( $bin_file, buf_ref => \$buffer,
622 my @lines = read_file( $bin_file, buf_ref => \$buffer ) ;
626 You can use this option to set the block size used when slurping from an already open handle (like \*STDIN). It defaults to 1MB.
628 my $text_ref = read_file( $bin_file, blk_size => 10_000_000,
633 You can use this option to control how read_file behaves when an error
634 occurs. This option defaults to 'croak'. You can set it to 'carp' or
635 to 'quiet to have no error handling. This code wants to carp and then
636 read abother file if it fails.
638 my $text_ref = read_file( $file, err_mode => 'carp' ) ;
639 unless ( $text_ref ) {
641 # read a different file but croak if not found
642 $text_ref = read_file( $another_file ) ;
645 # process ${$text_ref}
649 This sub writes out an entire file in one call.
651 write_file( 'filename', @data ) ;
653 The first argument to C<write_file> is the filename. The next argument
654 is an optional hash reference and it contains key/values that can
655 modify the behavior of C<write_file>. The rest of the argument list is
656 the data to be written to the file.
658 write_file( 'filename', {append => 1 }, @data ) ;
659 write_file( 'filename', {binmode => ':raw' }, $buffer ) ;
661 As a shortcut if the first data argument is a scalar or array
662 reference, it is used as the only data to be written to the file. Any
663 following arguments in @_ are ignored. This is a faster way to pass in
664 the output to be written to the file and is equivilent to the
665 C<buf_ref> option. These following pairs are equivilent but the pass
666 by reference call will be faster in most cases (especially with larger
669 write_file( 'filename', \$buffer ) ;
670 write_file( 'filename', $buffer ) ;
672 write_file( 'filename', \@lines ) ;
673 write_file( 'filename', @lines ) ;
675 If the first argument is a file handle reference or I/O object (if ref
676 is true), then that handle is slurped in. This mode is supported so
677 you spew to handles such as \*STDOUT. See the test handle.t for an
678 example that does C<open( '-|' )> and child process spews data to the
679 parant which slurps it in. All of the options that control how the
680 data is passes into C<write_file> still work in this case.
682 C<write_file> returns 1 upon successfully writing the file or undef if
683 it encountered an error.
689 If you set the binmode option, then the file will be written in binary
692 write_file( $bin_file, {binmode => ':raw'}, @data ) ;
694 NOTE: this actually sets the O_BINARY mode flag for sysopen. It
695 probably should call binmode and pass its argument to support other
700 You can use this option to pass in a scalar reference which has the
701 data to be written. If this is set then any data arguments (including
702 the scalar reference shortcut) in @_ will be ignored. These are
705 write_file( $bin_file, { buf_ref => \$buffer } ) ;
706 write_file( $bin_file, \$buffer ) ;
707 write_file( $bin_file, $buffer ) ;
711 If you set this boolean option, the file will be written to in an
712 atomic fashion. A temporary file name is created by appending the pid
713 ($$) to the file name argument and that file is spewed to. After the
714 file is closed it is renamed to the original file name (and rename is
715 an atomic operation on most OS's). If the program using this were to
716 crash in the middle of this, then the file with the pid suffix could
721 If you set this boolean option, the data will be written at the end of
724 write_file( $file, {append => 1}, @data ) ;
726 C<write_file> croaks if it cannot open the file. It returns true if it
727 succeeded in writing out the file and undef if there was an
728 error. (Yes, I know if it croaks it can't return anything but that is
729 for when I add the options to select the error handling mode).
733 If you set this boolean option, an existing file will not be overwritten.
735 write_file( $file, {no_clobber => 1}, @data ) ;
739 You can use this option to control how C<write_file> behaves when an
740 error occurs. This option defaults to 'croak'. You can set it to
741 'carp' or to 'quiet' to have no error handling other than the return
742 value. If the first call to C<write_file> fails it will carp and then
743 write to another file. If the second call to C<write_file> fails, it
746 unless ( write_file( $file, { err_mode => 'carp', \$data ) ;
748 # write a different file but croak if not found
749 write_file( $other_file, \$data ) ;
752 =head2 overwrite_file
754 This sub is just a typeglob alias to write_file since write_file
755 always overwrites an existing file. This sub is supported for
756 backwards compatibility with the original version of this module. See
757 write_file for its API and behavior.
761 This sub will write its data to the end of the file. It is a wrapper
762 around write_file and it has the same API so see that for the full
763 documentation. These calls are equivilent:
765 append_file( $file, @data ) ;
766 write_file( $file, {append => 1}, @data ) ;
770 This sub reads all the file names from directory and returns them to
771 the caller but C<.> and C<..> are removed by default.
773 my @files = read_dir( '/path/to/dir' ) ;
775 It croaks if it cannot open the directory.
777 In a list context C<read_dir> returns a list of the entries in the
778 directory. In a scalar context it returns an array reference which has
783 If this boolean option is set, C<.> and C<..> are not removed from the
786 my @all_files = read_dir( '/path/to/dir', keep_dot_dot => 1 ) ;
790 read_file write_file overwrite_file append_file read_dir
794 An article on file slurping in extras/slurp_article.pod. There is
795 also a benchmarking script in extras/slurp_bench.pl.
799 If run under Perl 5.004, slurping from the DATA handle will fail as
800 that requires B.pm which didn't get into core until 5.005.
804 Uri Guttman, E<lt>uri@stemsystems.comE<gt>