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 my $is_win32 = $^O =~ /win32/i ;
25 # Install subs for various constants that aren't set in older perls
26 # (< 5.005). Fcntl on old perls uses Exporter to define subs without a
27 # () prototype These can't be overridden with the constant pragma or
28 # we get a prototype mismatch. Hence this less than aesthetically
29 # appealing BEGIN block:
32 unless( defined &SEEK_SET ) {
33 *SEEK_SET = sub { 0 };
34 *SEEK_CUR = sub { 1 };
35 *SEEK_END = sub { 2 };
38 unless( defined &O_BINARY ) {
39 *O_BINARY = sub { 0 };
40 *O_RDONLY = sub { 0 };
41 *O_WRONLY = sub { 1 };
44 unless ( defined O_APPEND ) {
46 if ( $^O =~ /olaris/ ) {
47 *O_APPEND = sub { 8 };
48 *O_CREAT = sub { 256 };
49 *O_EXCL = sub { 1024 };
51 elsif ( $^O =~ /inux/ ) {
52 *O_APPEND = sub { 1024 };
53 *O_CREAT = sub { 64 };
54 *O_EXCL = sub { 128 };
56 elsif ( $^O =~ /BSD/i ) {
57 *O_APPEND = sub { 8 };
58 *O_CREAT = sub { 512 };
59 *O_EXCL = sub { 2048 };
64 # print "OS [$^O]\n" ;
66 # print "O_BINARY = ", O_BINARY(), "\n" ;
67 # print "O_RDONLY = ", O_RDONLY(), "\n" ;
68 # print "O_WRONLY = ", O_WRONLY(), "\n" ;
69 # print "O_APPEND = ", O_APPEND(), "\n" ;
70 # print "O_CREAT ", O_CREAT(), "\n" ;
71 # print "O_EXCL ", O_EXCL(), "\n" ;
74 *slurp = \&read_file ;
78 my( $file_name, %args ) = @_ ;
80 if ( !ref $file_name && 0 &&
81 -e $file_name && -s _ < 10000 && ! %args && !wantarray ) {
85 unless( open( FH, $file_name ) ) {
87 @_ = ( \%args, "read_file '$file_name' - sysopen: $!");
91 my $read_cnt = sysread( FH, my $buf, -s _ ) ;
93 unless ( defined $read_cnt ) {
95 # handle the read error
98 "read_file '$file_name' - small sysread: $!");
105 # set the buffer to either the passed in one or ours and init it to the null
109 my $buf_ref = $args{'buf_ref'} || \$buf ;
112 my( $read_fh, $size_left, $blk_size ) ;
114 # check if we are reading from a handle (glob ref or IO:: object)
116 if ( ref $file_name ) {
118 # slurping a handle so use it and don't open anything.
119 # set the block size so we know it is a handle and read that amount
121 $read_fh = $file_name ;
122 $blk_size = $args{'blk_size'} || 1024 * 1024 ;
123 $size_left = $blk_size ;
125 # DEEP DARK MAGIC. this checks the UNTAINT IO flag of a
126 # glob/handle. only the DATA handle is untainted (since it is from
127 # trusted data in the source file). this allows us to test if this is
128 # the DATA handle and then to do a sysseek to make sure it gets
129 # slurped correctly. on some systems, the buffered i/o pointer is not
130 # left at the same place as the fd pointer. this sysseek makes them
131 # the same so slurping with sysread will work.
137 @_ = ( \%args, <<ERR ) ;
138 Can't find B.pm with this Perl: $!.
139 That module is needed to slurp the DATA handle.
144 if ( B::svref_2object( $read_fh )->IO->IoFLAGS & 16 ) {
146 # set the seek position to the current tell.
148 sysseek( $read_fh, tell( $read_fh ), SEEK_SET ) ||
154 # a regular file. set the sysopen mode
156 my $mode = O_RDONLY ;
157 $mode |= O_BINARY if $args{'binmode'} ;
159 #printf "RD: BINARY %x MODE %x\n", O_BINARY, $mode ;
161 # open the file and handle any error
164 unless ( sysopen( $read_fh, $file_name, $mode ) ) {
165 @_ = ( \%args, "read_file '$file_name' - sysopen: $!");
169 # get the size of the file for use in the read loop
171 $size_left = -s $read_fh ;
173 print "SIZE $size_left\n" ;
176 # blk_size is not needed if we have a real file size > 0. for 0 size who cares?
177 # so test this deletion
179 # unless( $size_left ) {
181 # $blk_size = $args{'blk_size'} || 1024 * 1024 ;
182 # $size_left = $blk_size ;
187 # if ( $size_left < 10000 && keys %args == 0 && !wantarray ) {
189 # #print "OPT\n" and $printed++ unless $printed ;
191 # my $read_cnt = sysread( $read_fh, my $buf, $size_left ) ;
193 # unless ( defined $read_cnt ) {
195 # # handle the read error
197 # @_ = ( \%args, "read_file '$file_name' - small2 sysread: $!");
204 # infinite read loop. we exit when we are done slurping
208 # do the read and see how much we got
210 my $read_cnt = sysread( $read_fh, ${$buf_ref},
211 $size_left, length ${$buf_ref} ) ;
213 unless ( defined $read_cnt ) {
215 # handle the read error
217 @_ = ( \%args, "read_file '$file_name' - loop sysread: $!");
221 # good read. see if we hit EOF (nothing left to read)
223 last if $read_cnt == 0 ;
225 # loop if we are slurping a handle. we don't track $size_left then.
229 # count down how much we read and loop if we have more to read.
231 $size_left -= $read_cnt ;
232 last if $size_left <= 0 ;
235 # fix up cr/lf to be a newline if this is a windows text file
237 ${$buf_ref} =~ s/\015\012/\n/g if $is_win32 && !$args{'binmode'} ;
239 # this is the 5 returns in a row. each handles one possible
240 # combination of caller context and requested return type
243 $sep = '\n\n+' if defined $sep && $sep eq '' ;
245 # caller wants to get an array ref of lines
247 # this split doesn't work since it tries to use variable length lookbehind
248 # the m// line works.
249 # return [ split( m|(?<=$sep)|, ${$buf_ref} ) ] if $args{'array_ref'} ;
250 return [ length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : () ]
251 if $args{'array_ref'} ;
253 # caller wants a list of lines (normal list context)
255 # same problem with this split as before.
256 # return split( m|(?<=$sep)|, ${$buf_ref} ) if wantarray ;
257 return length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : ()
260 # caller wants a scalar ref to the slurped text
262 return $buf_ref if $args{'scalar_ref'} ;
264 # caller wants a scalar with the slurped text (normal scalar context)
266 return ${$buf_ref} if defined wantarray ;
268 # caller passed in an i/o buffer by reference (normal void context)
275 my $file_name = shift ;
277 # get the optional argument hash ref from @_ or an empty hash ref.
279 my $args = ( ref $_[0] eq 'HASH' ) ? shift : {} ;
281 my( $buf_ref, $write_fh, $no_truncate, $orig_file_name, $data_is_ref ) ;
283 # get the buffer ref - it depends on how the data is passed into write_file
284 # after this if/else $buf_ref will have a scalar ref to the data.
286 if ( ref $args->{'buf_ref'} eq 'SCALAR' ) {
288 # a scalar ref passed in %args has the data
289 # note that the data was passed by ref
291 $buf_ref = $args->{'buf_ref'} ;
294 elsif ( ref $_[0] eq 'SCALAR' ) {
296 # the first value in @_ is the scalar ref to the data
297 # note that the data was passed by ref
302 elsif ( ref $_[0] eq 'ARRAY' ) {
304 # the first value in @_ is the array ref to the data so join it.
306 ${$buf_ref} = join '', @{$_[0]} ;
310 # good old @_ has all the data so join it.
312 ${$buf_ref} = join '', @_ ;
315 # see if we were passed a open handle to spew to.
317 if ( ref $file_name ) {
319 # we have a handle. make sure we don't call truncate on it.
321 $write_fh = $file_name ;
326 # spew to regular file.
328 if ( $args->{'atomic'} ) {
330 # in atomic mode, we spew to a temp file so make one and save the original
332 $orig_file_name = $file_name ;
333 $file_name .= ".$$" ;
336 # set the mode for the sysopen
338 my $mode = O_WRONLY | O_CREAT ;
339 $mode |= O_BINARY if $args->{'binmode'} ;
340 $mode |= O_APPEND if $args->{'append'} ;
341 $mode |= O_EXCL if $args->{'no_clobber'} ;
343 #printf "WR: BINARY %x MODE %x\n", O_BINARY, $mode ;
345 # open the file and handle any error.
348 unless ( sysopen( $write_fh, $file_name, $mode ) ) {
349 @_ = ( $args, "write_file '$file_name' - sysopen: $!");
354 sysseek( $write_fh, 0, SEEK_END ) if $args->{'append'} ;
357 #print 'WR before data ', unpack( 'H*', ${$buf_ref}), "\n" ;
359 # fix up newline to write cr/lf if this is a windows text file
361 if ( $is_win32 && !$args->{'binmode'} ) {
363 # copy the write data if it was passed by ref so we don't clobber the
365 $buf_ref = \do{ my $copy = ${$buf_ref}; } if $data_is_ref ;
366 ${$buf_ref} =~ s/\n/\015\012/g ;
369 #print 'after data ', unpack( 'H*', ${$buf_ref}), "\n" ;
371 # get the size of how much we are writing and init the offset into that buffer
373 my $size_left = length( ${$buf_ref} ) ;
376 # loop until we have no more data left to write
380 # do the write and track how much we just wrote
382 my $write_cnt = syswrite( $write_fh, ${$buf_ref},
383 $size_left, $offset ) ;
385 unless ( defined $write_cnt ) {
388 @_ = ( $args, "write_file '$file_name' - syswrite: $!");
392 # track much left to write and where to write from in the buffer
394 $size_left -= $write_cnt ;
395 $offset += $write_cnt ;
397 } while( $size_left > 0 ) ;
399 # we truncate regular files in case we overwrite a long file with a shorter file
400 # so seek to the current position to get it (same as tell()).
403 sysseek( $write_fh, 0, SEEK_CUR ) ) unless $no_truncate ;
407 # handle the atomic mode - move the temp file to the original filename.
409 if ( $args->{'atomic'} && !rename( $file_name, $orig_file_name ) ) {
412 @_ = ( $args, "write_file '$file_name' - rename: $!" ) ;
419 # this is for backwards compatibility with the previous File::Slurp module.
420 # write_file always overwrites an existing file
422 *overwrite_file = \&write_file ;
424 # the current write_file has an append mode so we use that. this
425 # supports the same API with an optional second argument which is a
426 # hash ref of options.
430 # get the optional args hash ref
432 if ( ref $args eq 'HASH' ) {
434 # we were passed an args ref so just mark the append mode
436 $args->{append} = 1 ;
440 # no args hash so insert one with the append mode
442 splice( @_, 1, 0, { append => 1 } ) ;
445 # magic goto the main write_file sub. this overlays the sub without touching
451 # basic wrapper around opendir/readdir
455 my ($dir, %args ) = @_;
457 # this handle will be destroyed upon return
461 # open the dir and handle any errors
463 unless ( opendir( DIRH, $dir ) ) {
465 @_ = ( \%args, "read_dir '$dir' - opendir: $!" ) ;
469 my @dir_entries = readdir(DIRH) ;
471 @dir_entries = grep( $_ ne "." && $_ ne "..", @dir_entries )
472 unless $args{'keep_dot_dot'} ;
474 return @dir_entries if wantarray ;
475 return \@dir_entries ;
478 # error handling section
480 # all the error handling uses magic goto so the caller will get the
481 # error message as if from their code and not this module. if we just
482 # did a call on the error code, the carp/croak would report it from
483 # this module since the error sub is one level down on the call stack
484 # from read_file/write_file/read_dir.
494 my( $args, $err_msg ) = @_ ;
496 # get the error function to use
498 my $func = $err_func{ $args->{'err_mode'} || 'croak' } ;
500 # if we didn't find it in our error function hash, they must have set
501 # it to quiet and we don't do anything.
503 return unless $func ;
505 # call the carp/croak function
509 # return a hard undef (in list context this will be a single value of
510 # undef which is not a legal in-band value)
520 File::Slurp - Efficient Reading/Writing of Complete Files
526 my $text = read_file( 'filename' ) ;
527 my @lines = read_file( 'filename' ) ;
529 write_file( 'filename', @lines ) ;
531 use File::Slurp qw( slurp ) ;
533 my $text = slurp( 'filename' ) ;
538 This module provides subs that allow you to read or write entire files
539 with one simple call. They are designed to be simple to use, have
540 flexible ways to pass in or get the file contents and to be very
541 efficient. There is also a sub to read in all the files in a
542 directory other than C<.> and C<..>
544 These slurp/spew subs work for files, pipes and
545 sockets, and stdio, pseudo-files, and DATA.
549 This sub reads in an entire file and returns its contents to the
550 caller. In list context it will return a list of lines (using the
551 current value of $/ as the separator including support for paragraph
552 mode when it is set to ''). In scalar context it returns the entire
553 file as a single scalar.
555 my $text = read_file( 'filename' ) ;
556 my @lines = read_file( 'filename' ) ;
558 The first argument to C<read_file> is the filename and the rest of the
559 arguments are key/value pairs which are optional and which modify the
560 behavior of the call. Other than binmode the options all control how
561 the slurped file is returned to the caller.
563 If the first argument is a file handle reference or I/O object (if ref
564 is true), then that handle is slurped in. This mode is supported so
565 you slurp handles such as C<DATA>, C<STDIN>. See the test handle.t
566 for an example that does C<open( '-|' )> and child process spews data
567 to the parant which slurps it in. All of the options that control how
568 the data is returned to the caller still work in this case.
570 NOTE: as of version 9999.06, read_file works correctly on the C<DATA>
571 handle. It used to need a sysseek workaround but that is now handled
572 when needed by the module itself.
574 You can optionally request that C<slurp()> is exported to your code. This
575 is an alias for read_file and is meant to be forward compatible with
576 Perl 6 (which will have slurp() built-in).
582 If you set the binmode option, then the file will be slurped in binary
585 my $bin_data = read_file( $bin_file, binmode => ':raw' ) ;
587 NOTE: this actually sets the O_BINARY mode flag for sysopen. It
588 probably should call binmode and pass its argument to support other
593 If this boolean option is set, the return value (only in scalar
594 context) will be an array reference which contains the lines of the
595 slurped file. The following two calls are equivalent:
597 my $lines_ref = read_file( $bin_file, array_ref => 1 ) ;
598 my $lines_ref = [ read_file( $bin_file ) ] ;
602 If this boolean option is set, the return value (only in scalar
603 context) will be an scalar reference to a string which is the contents
604 of the slurped file. This will usually be faster than returning the
607 my $text_ref = read_file( $bin_file, scalar_ref => 1 ) ;
611 You can use this option to pass in a scalar reference and the slurped
612 file contents will be stored in the scalar. This can be used in
613 conjunction with any of the other options.
615 my $text_ref = read_file( $bin_file, buf_ref => \$buffer,
617 my @lines = read_file( $bin_file, buf_ref => \$buffer ) ;
621 You can use this option to set the block size used when slurping from an already open handle (like \*STDIN). It defaults to 1MB.
623 my $text_ref = read_file( $bin_file, blk_size => 10_000_000,
628 You can use this option to control how read_file behaves when an error
629 occurs. This option defaults to 'croak'. You can set it to 'carp' or
630 to 'quiet to have no error handling. This code wants to carp and then
631 read abother file if it fails.
633 my $text_ref = read_file( $file, err_mode => 'carp' ) ;
634 unless ( $text_ref ) {
636 # read a different file but croak if not found
637 $text_ref = read_file( $another_file ) ;
640 # process ${$text_ref}
644 This sub writes out an entire file in one call.
646 write_file( 'filename', @data ) ;
648 The first argument to C<write_file> is the filename. The next argument
649 is an optional hash reference and it contains key/values that can
650 modify the behavior of C<write_file>. The rest of the argument list is
651 the data to be written to the file.
653 write_file( 'filename', {append => 1 }, @data ) ;
654 write_file( 'filename', {binmode => ':raw' }, $buffer ) ;
656 As a shortcut if the first data argument is a scalar or array
657 reference, it is used as the only data to be written to the file. Any
658 following arguments in @_ are ignored. This is a faster way to pass in
659 the output to be written to the file and is equivilent to the
660 C<buf_ref> option. These following pairs are equivilent but the pass
661 by reference call will be faster in most cases (especially with larger
664 write_file( 'filename', \$buffer ) ;
665 write_file( 'filename', $buffer ) ;
667 write_file( 'filename', \@lines ) ;
668 write_file( 'filename', @lines ) ;
670 If the first argument is a file handle reference or I/O object (if ref
671 is true), then that handle is slurped in. This mode is supported so
672 you spew to handles such as \*STDOUT. See the test handle.t for an
673 example that does C<open( '-|' )> and child process spews data to the
674 parant which slurps it in. All of the options that control how the
675 data is passes into C<write_file> still work in this case.
677 C<write_file> returns 1 upon successfully writing the file or undef if
678 it encountered an error.
684 If you set the binmode option, then the file will be written in binary
687 write_file( $bin_file, {binmode => ':raw'}, @data ) ;
689 NOTE: this actually sets the O_BINARY mode flag for sysopen. It
690 probably should call binmode and pass its argument to support other
695 You can use this option to pass in a scalar reference which has the
696 data to be written. If this is set then any data arguments (including
697 the scalar reference shortcut) in @_ will be ignored. These are
700 write_file( $bin_file, { buf_ref => \$buffer } ) ;
701 write_file( $bin_file, \$buffer ) ;
702 write_file( $bin_file, $buffer ) ;
706 If you set this boolean option, the file will be written to in an
707 atomic fashion. A temporary file name is created by appending the pid
708 ($$) to the file name argument and that file is spewed to. After the
709 file is closed it is renamed to the original file name (and rename is
710 an atomic operation on most OS's). If the program using this were to
711 crash in the middle of this, then the file with the pid suffix could
716 If you set this boolean option, the data will be written at the end of
719 write_file( $file, {append => 1}, @data ) ;
721 C<write_file> croaks if it cannot open the file. It returns true if it
722 succeeded in writing out the file and undef if there was an
723 error. (Yes, I know if it croaks it can't return anything but that is
724 for when I add the options to select the error handling mode).
728 If you set this boolean option, an existing file will not be overwritten.
730 write_file( $file, {no_clobber => 1}, @data ) ;
734 You can use this option to control how C<write_file> behaves when an
735 error occurs. This option defaults to 'croak'. You can set it to
736 'carp' or to 'quiet' to have no error handling other than the return
737 value. If the first call to C<write_file> fails it will carp and then
738 write to another file. If the second call to C<write_file> fails, it
741 unless ( write_file( $file, { err_mode => 'carp', \$data ) ;
743 # write a different file but croak if not found
744 write_file( $other_file, \$data ) ;
747 =head2 overwrite_file
749 This sub is just a typeglob alias to write_file since write_file
750 always overwrites an existing file. This sub is supported for
751 backwards compatibility with the original version of this module. See
752 write_file for its API and behavior.
756 This sub will write its data to the end of the file. It is a wrapper
757 around write_file and it has the same API so see that for the full
758 documentation. These calls are equivilent:
760 append_file( $file, @data ) ;
761 write_file( $file, {append => 1}, @data ) ;
765 This sub reads all the file names from directory and returns them to
766 the caller but C<.> and C<..> are removed by default.
768 my @files = read_dir( '/path/to/dir' ) ;
770 It croaks if it cannot open the directory.
772 In a list context C<read_dir> returns a list of the entries in the
773 directory. In a scalar context it returns an array reference which has
778 If this boolean option is set, C<.> and C<..> are not removed from the
781 my @all_files = read_dir( '/path/to/dir', keep_dot_dot => 1 ) ;
785 read_file write_file overwrite_file append_file read_dir
789 An article on file slurping in extras/slurp_article.pod. There is
790 also a benchmarking script in extras/slurp_bench.pl.
794 If run under Perl 5.004, slurping from the DATA handle will fail as
795 that requires B.pm which didn't get into core until 5.005.
799 Uri Guttman, E<lt>uri@stemsystems.comE<gt>