view release on metacpan or  search on metacpan

inc/File/Slurp.pm  view on Meta::CPAN

$VERSION = '9999.12';

*slurp = \&read_file ;

sub read_file {

	my( $file_name, %args ) = @_ ;

# set the buffer to either the passed in one or ours and init it to the null
# string

	my $buf ;
	my $buf_ref = $args{'buf_ref'} || \$buf ;
	${$buf_ref} = '' ;

	my( $read_fh, $size_left, $blk_size ) ;

# check if we are reading from a handle (glob ref or IO:: object)

	if ( ref $file_name ) {

# slurping a handle so use it and don't open anything.
# set the block size so we know it is a handle and read that amount

		$read_fh = $file_name ;
		$blk_size = $args{'blk_size'} || 1024 * 1024 ;
		$size_left = $blk_size ;

# 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 ( $@ ) {

			@_ = ( \%args, <<ERR ) ;
Can't find B.pm with this Perl: $!.
That module is needed to slurp the DATA handle.
ERR
			goto &_error ;
		}

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

# set the seek position to the current tell.

			sysseek( $read_fh, tell( $read_fh ), SEEK_SET ) ||
				croak "sysseek $!" ;
		}
	}
	else {

# a regular file. set the sysopen mode

		my $mode = O_RDONLY ;
		$mode |= O_BINARY if $args{'binmode'} ;

#printf "RD: BINARY %x MODE %x\n", O_BINARY, $mode ;

# open the file and handle any error

		$read_fh = gensym ;
		unless ( sysopen( $read_fh, $file_name, $mode ) ) {
			@_ = ( \%args, "read_file '$file_name' - sysopen: $!");
			goto &_error ;
		}

# get the size of the file for use in the read loop

		$size_left = -s $read_fh ;

		unless( $size_left ) {

			$blk_size = $args{'blk_size'} || 1024 * 1024 ;
			$size_left = $blk_size ;
		}
	}

# infinite read loop. we exit when we are done slurping

	while( 1 ) {

# do the read and see how much we got

		my $read_cnt = sysread( $read_fh, ${$buf_ref},
				$size_left, length ${$buf_ref} ) ;

		if ( defined $read_cnt ) {

# good read. see if we hit EOF (nothing left to read)

			last if $read_cnt == 0 ;

# loop if we are slurping a handle. we don't track $size_left then.

			next if $blk_size ;

# count down how much we read and loop if we have more to read.
			$size_left -= $read_cnt ;
			last if $size_left <= 0 ;
			next ;
		}

# handle the read error

		@_ = ( \%args, "read_file '$file_name' - sysread: $!");
		goto &_error ;
	}

# fix up cr/lf to be a newline if this is a windows text file

	${$buf_ref} =~ s/\015\012/\n/g if $is_win32 && !$args{'binmode'} ;

# this is the 5 returns in a row. each handles one possible
# combination of caller context and requested return type

	my $sep = $/ ;
	$sep = '\n\n+' if defined $sep && $sep eq '' ;

# caller wants to get an array ref of lines

# this split doesn't work since it tries to use variable length lookbehind
# the m// line works.
#	return [ split( m|(?<=$sep)|, ${$buf_ref} ) ] if $args{'array_ref'}  ;
	return [ length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : () ]
		if $args{'array_ref'}  ;

# caller wants a list of lines (normal list context)

# same problem with this split as before.
#	return split( m|(?<=$sep)|, ${$buf_ref} ) if wantarray ;
	return length(${$buf_ref}) ? ${$buf_ref} =~ /(.*?$sep|.+)/sg : ()
		if wantarray ;

# caller wants a scalar ref to the slurped text

	return $buf_ref if $args{'scalar_ref'} ;

# caller wants a scalar with the slurped text (normal scalar context)

	return ${$buf_ref} if defined wantarray ;

# caller passed in an i/o buffer by reference (normal void context)

	return ;
}

sub write_file {

	my $file_name = shift ;

# get the optional argument hash ref from @_ or an empty hash ref.

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

	my( $buf_ref, $write_fh, $no_truncate, $orig_file_name, $data_is_ref ) ;

# get the buffer ref - it depends on how the data is passed into write_file
# after this if/else $buf_ref will have a scalar ref to the data.

	if ( ref $args->{'buf_ref'} eq 'SCALAR' ) {

# a scalar ref passed in %args has the data
# note that the data was passed by ref

		$buf_ref = $args->{'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 '', @_ ;
	}

# see if we were passed a open handle to spew to.

	if ( ref $file_name ) {

# we have a handle. make sure we don't call truncate on it.

		$write_fh = $file_name ;
		$no_truncate = 1 ;
	}
	else {

# spew to regular file.

		if ( $args->{'atomic'} ) {

# in atomic mode, we spew to a temp file so make one and save the original
# file name.
			$orig_file_name = $file_name ;
			$file_name .= ".$$" ;
		}

# set the mode for the sysopen

		my $mode = O_WRONLY | O_CREAT ;
		$mode |= O_BINARY if $args->{'binmode'} ;
		$mode |= O_APPEND if $args->{'append'} ;
		$mode |= O_EXCL if $args->{'no_clobber'} ;

#printf "WR: BINARY %x MODE %x\n", O_BINARY, $mode ;

# open the file and handle any error.

		$write_fh = gensym ;
		unless ( sysopen( $write_fh, $file_name, $mode ) ) {
			@_ = ( $args, "write_file '$file_name' - sysopen: $!");
			goto &_error ;
		}
	}

	sysseek( $write_fh, 0, SEEK_END ) if $args->{'append'} ;


#print 'WR before data ', unpack( 'H*', ${$buf_ref}), "\n" ;

# fix up newline to write cr/lf if this is a windows text file

	if ( $is_win32 && !$args->{'binmode'} ) {

# copy the write data if it was passed by ref so we don't clobber the
# caller's data
		$buf_ref = \do{ my $copy = ${$buf_ref}; } if $data_is_ref ;
		${$buf_ref} =~ s/\n/\015\012/g ;
	}

#print 'after data ', unpack( 'H*', ${$buf_ref}), "\n" ;

# get the size of how much we are writing and init the offset into that buffer

	my $size_left = length( ${$buf_ref} ) ;
	my $offset = 0 ;

# loop until we have no more data left to write

	do {

# do the write and track how much we just wrote

		my $write_cnt = syswrite( $write_fh, ${$buf_ref},
				$size_left, $offset ) ;

		unless ( defined $write_cnt ) {

# the write failed
			@_ = ( $args, "write_file '$file_name' - syswrite: $!");
			goto &_error ;
		}

# track much left to write and where to write from in the buffer

		$size_left -= $write_cnt ;
		$offset += $write_cnt ;

	} while( $size_left > 0 ) ;

# we truncate regular files in case we overwrite a long file with a shorter file
# so seek to the current position to get it (same as tell()).

	truncate( $write_fh,
		  sysseek( $write_fh, 0, SEEK_CUR ) ) unless $no_truncate ;

	close( $write_fh ) ;

# handle the atomic mode - move the temp file to the original filename.

	rename( $file_name, $orig_file_name ) if $args->{'atomic'} ;

	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.