File Coverage

blib/lib/File/Slurp.pm

Criterion	Covered	Total	%
statement	240	260	92.3
branch	111	124	89.5
condition	34	45	75.5
subroutine	22	22	100.0
pod	7	7	100.0
total	414	458	90.3

package File::Slurp;

use strict;
use warnings ;

our $VERSION = '9999.30';
$VERSION = eval $VERSION;

use Carp ;
use Exporter qw(import);
use Fcntl qw( :DEFAULT ) ;
use File::Basename ();
use File::Spec;
use File::Temp qw(tempfile);
use IO::Handle ();
use POSIX qw( :fcntl_h ) ;
use Errno ;

my @std_export = qw(
	read_file
	write_file
	overwrite_file
	append_file
	read_dir
) ;

my @edit_export = qw(
	edit_file
	edit_file_lines
) ;

my @abbrev_export = qw(
	rf
	wf
	ef
	efl
) ;

our @EXPORT_OK = (
	@edit_export,
	@abbrev_export,
	qw(
		slurp
		prepend_file
	),
) ;

our %EXPORT_TAGS = (
	'all'	=> [ @std_export, @edit_export, @abbrev_export, @EXPORT_OK ],
	'edit'	=> [ @edit_export ],
	'std'	=> [ @std_export ],
	'abr'	=> [ @abbrev_export ],
) ;

our @EXPORT = @std_export ;

my $max_fast_slurp_size = 1024 * 100 ;

my $is_win32 = $^O =~ /win32/i ;

*slurp = \&read_file ;
*rf = \&read_file ;

sub read_file {
	my $file_name = shift;
	my $opts = (ref $_[0] eq 'HASH') ? shift : {@_};
	# options we care about:
	# array_ref binmode blk_size buf_ref chomp err_mode scalar_ref

	# let's see if we have a stringified object before doing anything else
	# We then only have to deal with when we are given a file handle/globref
	if (ref($file_name)) {
		my $ref_result = _check_ref($file_name, $opts);
		if (ref($ref_result)) {
			@_ = ($opts, $ref_result);
			goto &_error;
		}
		$file_name = $ref_result if $ref_result;
		# we have now stringified $file_name if possible. if it's still a ref
		# then we probably have a file handle
	}

	my $fh;
	if (ref($file_name)) {
		$fh = $file_name;
	}
	else {
		# to keep with the old ways, read in :raw by default
		unless (open $fh, "<:raw", $file_name) {
			@_ = ($opts, "read_file '$file_name' - open: $!");
			goto &_error;
		}
		# even though we set raw, let binmode take place here (busted)
		if (my $bm = $opts->{binmode}) {
			binmode $fh, $bm;
		}
	}

	# we are now sure to have an open file handle. Let's slurp it in the same
	# way that File::Slurper does.
	my $buf;
	my $buf_ref = $opts->{buf_ref} || \$buf;
	${$buf_ref} = '';
	my $blk_size = $opts->{blk_size} || 1024 * 1024;
	if (my $size = -s $fh) {
		$blk_size = $size if $size < $blk_size;
		my ($pos, $read) = 0;
		do {
			unless(defined($read = read $fh, ${$buf_ref}, $blk_size, $pos)) {
				@_ = ($opts, "read_file '$file_name' - read: $!");
				goto &_error;
			}
			$pos += $read;
		} while ($read && $pos < $size);
	}
	else {
		${$buf_ref} = do { local $/; <$fh> };
	}
	seek($fh, $opts->{_data_tell}, SEEK_SET) if $opts->{_is_data} && $opts->{_data_tell};

	# line endings if we're on Windows
	${$buf_ref} =~ s/\015\012/\012/g if $is_win32 && !$opts->{binmode};

	# we now have a buffer filled with the file content. Figure out how to
	# return it to the user
	my $want_array = wantarray; # let's only ask for this once
	if ($want_array || $opts->{array_ref}) {
		use re 'taint';
		my $sep = $/;
		$sep = '\n\n+' if defined $sep && $sep eq '';
		# split the buffered content into lines
		my @lines = length(${$buf_ref}) ?
			${$buf_ref} =~ /(.*?$sep|.+)/sg : ();
		chomp @lines if $opts->{chomp};
		return \@lines if $opts->{array_ref};
		return @lines;
	}
	return $buf_ref if $opts->{scalar_ref};
	# if the function was called in scalar context, return the contents
	return ${$buf_ref} if defined $want_array;
	# if we were called in void context, return nothing
	return;
}

# errors in this sub are returned as scalar refs
# a normal IO/GLOB handle is an empty return
# an overloaded object returns its stringified as a scalarfilename

sub _check_ref {

	my( $handle, $opts ) = @_ ;

# check if we are reading from a handle (GLOB or IO object)

	if ( eval { $handle->isa( 'GLOB' ) || $handle->isa( 'IO' ) } ) {

# we have a handle. deal with seeking to it if it is DATA

		my $err = _seek_data_handle( $handle, $opts ) ;

# return the error string if any

		return \$err if $err ;

# we have good handle
		return ;
	}

	eval { require overload } ;

# return an error if we can't load the overload pragma
# or if the object isn't overloaded

	return \"Bad handle '$handle' is not a GLOB or IO object or overloaded"
		 if $@ || !overload::Overloaded( $handle ) ;

# must be overloaded so return its stringified value

	return "$handle" ;
}

sub _seek_data_handle {

	my( $handle, $opts ) = @_ ;
	# store some meta-data about the __DATA__ file handle
	$opts->{_is_data} = 0;
	$opts->{_data_tell} = 0;

# DEEP DARK MAGIC. this checks the UNTAINT IO flag of a
# glob/handle. only the DATA handle is untainted (since it is from
# trusted data in the source file). this allows us to test if this is
# the DATA handle and then to do a sysseek to make sure it gets
# slurped correctly. on some systems, the buffered i/o pointer is not
# left at the same place as the fd pointer. this sysseek makes them
# the same so slurping with sysread will work.

	eval{ require B } ;

	if ( $@ ) {

		return <
Can't find B.pm with this Perl: $!.
That module is needed to properly slurp the DATA handle.
ERR
	}

	if ( B::svref_2object( $handle )->IO->IoFLAGS & 16 ) {

		# we now know we have the data handle. Let's store its original
		# location in the file so that we can put it back after the read.
		# this is only done for Bugwards-compatibility in some dists such as
		# CPAN::Index::API that made use of the oddity where sysread was in use
		# before
		$opts->{_is_data} = 1;
		$opts->{_data_tell} = tell($handle);
# set the seek position to the current tell.

		# unless( sysseek( $handle, tell( $handle ), SEEK_SET ) ) {
		# 	return "read_file '$handle' - sysseek: $!" ;
		# }
	}

# seek was successful, return no error string

	return ;
}

*wf = \&write_file ;

sub write_file {
	my $file_name = shift;
	my $opts = (ref $_[0] eq 'HASH') ? shift : {};
	# options we care about:
	# append atomic binmode buf_ref err_mode no_clobber perms

	my $fh;
	my $no_truncate = 0;
	my $orig_filename;
	# let's see if we have a stringified object or some sort of handle
	# or globref before doing anything else
	if (ref($file_name)) {
		my $ref_result = _check_ref($file_name, $opts);
		if (ref($ref_result)) {
			# some error happened while checking for a ref
			@_ = ($opts, $ref_result);
			goto &_error;
		}
		if ($ref_result) {
			# we have now stringified $file_name from the overloaded obj
			$file_name = $ref_result;
		}
		else {
			# we now have a proper handle ref
			# make sure we don't call truncate on it
			$fh = $file_name;
			$no_truncate = 1;
			# can't do atomic or permissions on a file handle
			delete $opts->{atomic};
			delete $opts->{perms};
		}
	}

	# open the file for writing if we were given a filename
	unless ($fh) {
		$orig_filename = $file_name;
		my $perms = defined($opts->{perms}) ? $opts->{perms} : 0666;
		# set the mode for the sysopen
		my $mode = O_WRONLY | O_CREAT;
		$mode |= O_APPEND if $opts->{append};
		$mode |= O_EXCL if $opts->{no_clobber};
		if ($opts->{atomic}) {
			# in an atomic write, we must open a new file in the same directory
			# as the original to account for ACLs. We must also set the new file
			# to the same permissions as the original unless overridden by the
			# caller's request to set a specified permission set.
			my $dir = File::Spec->rel2abs(File::Basename::dirname($file_name));
			if (!defined($opts->{perms}) && -e $file_name && -f _) {
				$perms = 07777 & (stat $file_name)[2];
			}
			# we must ensure we're using a good temporary filename (doesn't already
			# exist). This is slower, but safer.
			{
				local $^W = 0; # AYFKM
				(undef, $file_name) = tempfile('.tempXXXXX', DIR => $dir, OPEN => 0);
			}
		}
		$fh = local *FH;
		unless (sysopen($fh, $file_name, $mode, $perms)) {
			@_ = ($opts, "write_file '$file_name' - sysopen: $!");
			goto &_error;
		}
	}
	# we now have an open file handle as well as data to write to that handle
	if (my $binmode = $opts->{binmode}) {
		binmode($fh, $binmode);
	}

	# get the data to print to the file
	# get the buffer ref - it depends on how the data is passed in
	# after this if/else $buf_ref will have a scalar ref to the data
	my $buf_ref;
	my $data_is_ref = 0;
	if (ref($opts->{buf_ref}) eq 'SCALAR') {
		# a scalar ref passed in %opts has the data
		# note that the data was passed by ref
		$buf_ref = $opts->{buf_ref};
		$data_is_ref = 1;
	}
	elsif (ref($_[0]) eq 'SCALAR') {
		# the first value in @_ is the scalar ref to the data
		# note that the data was passed by ref
		$buf_ref = shift;
		$data_is_ref = 1;
	}
	elsif (ref($_[0]) eq 'ARRAY') {
		# the first value in @_ is the array ref to the data so join it.
		${$buf_ref} = join '', @{$_[0]};
	}
	else {
		# good old @_ has all the data so join it.
		${$buf_ref} = join '', @_;
	}

	# seek and print
	seek($fh, 0, SEEK_END) if $opts->{append};
	print {$fh} ${$buf_ref};
	truncate($fh, tell($fh)) unless $no_truncate;
	close($fh);

	if ($opts->{atomic} && !rename($file_name, $orig_filename)) {
		@_ = ($opts, "write_file '$file_name' - rename: $!");
		goto &_error;
	}

	return 1;
}

# this is for backwards compatibility with the previous File::Slurp module.
# write_file always overwrites an existing file
*overwrite_file = \&write_file ;

# the current write_file has an append mode so we use that. this
# supports the same API with an optional second argument which is a
# hash ref of options.

sub append_file {

# get the optional opts hash ref
	my $opts = $_[1] ;
	if ( ref $opts eq 'HASH' ) {

# we were passed an opts ref so just mark the append mode

		$opts->{append} = 1 ;
	}
	else {

# no opts hash so insert one with the append mode

		splice( @_, 1, 0, { append => 1 } ) ;
	}

# magic goto the main write_file sub. this overlays the sub without touching
# the stack or @_

	goto &write_file
}

# prepend data to the beginning of a file

sub prepend_file {

	my $file_name = shift ;

#print "FILE $file_name\n" ;

	my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ;

# delete unsupported options

	my @bad_opts =
		grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ;

	delete @{$opts}{@bad_opts} ;

	my $prepend_data = shift ;
	$prepend_data = '' unless defined $prepend_data ;
	$prepend_data = ${$prepend_data} if ref $prepend_data eq 'SCALAR' ;

#print "PRE [$prepend_data]\n" ;

	my $err_mode = delete $opts->{err_mode} ;
	$opts->{ err_mode } = 'croak' ;
	$opts->{ scalar_ref } = 1 ;

	my $existing_data = eval { read_file( $file_name, $opts ) } ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"prepend_file '$file_name' - read_file: $!" ) ;
		goto &_error ;
	}

#print "EXIST [$$existing_data]\n" ;

	$opts->{atomic} = 1 ;
	my $write_result =
		eval { write_file( $file_name, $opts,
		       $prepend_data, $$existing_data ) ;
	} ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"prepend_file '$file_name' - write_file: $!" ) ;
		goto &_error ;
	}

	return $write_result ;
}

# edit a file as a scalar in $_

*ef = \&edit_file ;

sub edit_file(&$;$) {

	my( $edit_code, $file_name, $opts ) = @_ ;
	$opts = {} unless ref $opts eq 'HASH' ;

# 	my $edit_code = shift ;
# 	my $file_name = shift ;
# 	my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ;

#print "FILE $file_name\n" ;

# delete unsupported options

	my @bad_opts =
		grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ;

	delete @{$opts}{@bad_opts} ;

# keep the user err_mode and force croaking on internal errors

	my $err_mode = delete $opts->{err_mode} ;
	$opts->{ err_mode } = 'croak' ;

# get a scalar ref for speed and slurp the file into a scalar

	$opts->{ scalar_ref } = 1 ;
	my $existing_data = eval { read_file( $file_name, $opts ) } ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"edit_file '$file_name' - read_file: $!" ) ;
		goto &_error ;
	}

#print "EXIST [$$existing_data]\n" ;

	my( $edited_data ) = map { $edit_code->(); $_ } $$existing_data ;

	$opts->{atomic} = 1 ;
	my $write_result =
		eval { write_file( $file_name, $opts, $edited_data ) } ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"edit_file '$file_name' - write_file: $!" ) ;
		goto &_error ;
	}

	return $write_result ;
}

*efl = \&edit_file_lines ;

sub edit_file_lines(&$;$) {

	my( $edit_code, $file_name, $opts ) = @_ ;
	$opts = {} unless ref $opts eq 'HASH' ;

# 	my $edit_code = shift ;
# 	my $file_name = shift ;
# 	my $opts = ( ref $_[0] eq 'HASH' ) ? shift : {} ;

#print "FILE $file_name\n" ;

# delete unsupported options

	my @bad_opts =
		grep $_ ne 'err_mode' && $_ ne 'binmode', keys %{$opts} ;

	delete @{$opts}{@bad_opts} ;

# keep the user err_mode and force croaking on internal errors

	my $err_mode = delete $opts->{err_mode} ;
	$opts->{ err_mode } = 'croak' ;

# get an array ref for speed and slurp the file into lines

	$opts->{ array_ref } = 1 ;
	my $existing_data = eval { read_file( $file_name, $opts ) } ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"edit_file_lines '$file_name' - read_file: $!" ) ;
		goto &_error ;
	}

#print "EXIST [$$existing_data]\n" ;

	my @edited_data = map { $edit_code->(); $_ } @$existing_data ;

	$opts->{atomic} = 1 ;
	my $write_result =
		eval { write_file( $file_name, $opts, @edited_data ) } ;

	if ( $@ ) {

		@_ = ( { err_mode => $err_mode },
			"edit_file_lines '$file_name' - write_file: $!" ) ;
		goto &_error ;
	}

	return $write_result ;
}

# basic wrapper around opendir/readdir

sub read_dir {

	my $dir = shift ;
	my $opts = ( ref $_[0] eq 'HASH' ) ? shift : { @_ } ;

# this handle will be destroyed upon return

	local(*DIRH);

# open the dir and handle any errors

	unless ( opendir( DIRH, $dir ) ) {

		@_ = ( $opts, "read_dir '$dir' - opendir: $!" ) ;
		goto &_error ;
	}

	my @dir_entries = readdir(DIRH) ;

	@dir_entries = grep( $_ ne "." && $_ ne "..", @dir_entries )
		unless $opts->{'keep_dot_dot'} ;

	if ( $opts->{'prefix'} ) {

		$_ = File::Spec->catfile($dir, $_) for @dir_entries;
	}

	return @dir_entries if wantarray ;
	return \@dir_entries ;
}

# error handling section
#
# all the error handling uses magic goto so the caller will get the
# error message as if from their code and not this module. if we just
# did a call on the error code, the carp/croak would report it from
# this module since the error sub is one level down on the call stack
# from read_file/write_file/read_dir.


my %err_func = (
	'carp'	=> \&carp,
	'croak'	=> \&croak,
) ;

sub _error {

	my( $opts, $err_msg ) = @_ ;

# get the error function to use

 	my $func = $err_func{ $opts->{'err_mode'} || 'croak' } ;

# if we didn't find it in our error function hash, they must have set
# it to quiet and we don't do anything.

	return unless $func ;

# call the carp/croak function

	$func->($err_msg) if $func ;

# return a hard undef (in list context this will be a single value of
# undef which is not a legal in-band value)

	return undef ;
}

1;
__END__