From: Uri Guttman <uri@quad.(none)>
Date: Fri, 8 May 2009 06:02:53 +0000 (-0400)
Subject: added checking the result of atomic rename in write_file
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e2c51d31d5bcdbbe99f9443e4908c912554bd061;p=urisagit%2FPerl-Docs.git

added checking the result of atomic rename in write_file
---

diff --git a/lib/File/Slurp.pm b/lib/File/Slurp.pm
index b958f3b..6c078bf 100755
--- a/lib/File/Slurp.pm
+++ b/lib/File/Slurp.pm
@@ -1,12 +1,25 @@
 package File::Slurp;
 
+my $printed ;
+
 use strict;
 
 use Carp ;
-use POSIX qw( :fcntl_h ) ;
 use Fcntl qw( :DEFAULT ) ;
+use POSIX qw( :fcntl_h ) ;
 use Symbol ;
 
+use base 'Exporter' ;
+use vars qw( %EXPORT_TAGS @EXPORT_OK $VERSION @EXPORT ) ;
+
+%EXPORT_TAGS = ( 'all' => [
+	qw( read_file write_file overwrite_file append_file read_dir ) ] ) ;
+
+@EXPORT = ( @{ $EXPORT_TAGS{'all'} } );
+@EXPORT_OK = qw( slurp ) ;
+
+$VERSION = '9999.13';
+
 my $is_win32 = $^O =~ /win32/i ;
 
 # Install subs for various constants that aren't set in older perls
@@ -57,16 +70,6 @@ BEGIN {
 # print "O_CREAT   ", O_CREAT(), "\n" ;
 # print "O_EXCL   ", O_EXCL(), "\n" ;
 
-use base 'Exporter' ;
-use vars qw( %EXPORT_TAGS @EXPORT_OK $VERSION @EXPORT ) ;
-
-%EXPORT_TAGS = ( 'all' => [
-	qw( read_file write_file overwrite_file append_file read_dir ) ] ) ;
-
-@EXPORT = ( @{ $EXPORT_TAGS{'all'} } );
-@EXPORT_OK = qw( slurp ) ;
-
-$VERSION = '9999.12';
 
 *slurp = \&read_file ;
 
@@ -74,6 +77,39 @@ sub read_file {
 
 	my( $file_name, %args ) = @_ ;
 
+#	my $file_size = -s $file_name ;
+
+	if ( !ref $file_name && -s $file_name < 10000 && ! %args && !wantarray ) {
+
+		local( *FH ) ;
+
+#		open( FH, $file_name ) ;
+
+		unless( open( FH, $file_name ) ) {
+
+			@_ = ( \%args, "read_file '$file_name' - sysopen: $!");
+			goto &_error ;
+		}
+
+#print "OPT\n" and $printed++ unless $printed ;
+
+# 		sysread( FH, my $buf, -s _ ) ;
+# 		return $buf ;
+
+# 	}
+		my $read_cnt = sysread( FH, my $buf, -s _ ) ;
+
+		unless ( defined $read_cnt ) {
+
+# handle the read error
+
+			@_ = ( \%args, "read_file '$file_name' - sysread: $!");
+			goto &_error ;
+		}
+
+		return $buf ;
+	}
+
 # set the buffer to either the passed in one or ours and init it to the null
 # string
 
@@ -142,11 +178,33 @@ ERR
 
 		$size_left = -s $read_fh ;
 
-		unless( $size_left ) {
+### TEST
+# blk_size is not needed if we have a real file size > 0. for 0 size who cares?
+# so test this deletion
+###
+# 		unless( $size_left ) {
 
-			$blk_size = $args{'blk_size'} || 1024 * 1024 ;
-			$size_left = $blk_size ;
+# 			$blk_size = $args{'blk_size'} || 1024 * 1024 ;
+# 			$size_left = $blk_size ;
+# 		}
+	}
+
+
+	if ( $size_left < 10000 && keys %args == 0 && !wantarray ) {
+
+#print "OPT\n" and $printed++ unless $printed ;
+
+		my $read_cnt = sysread( $read_fh, my $buf, $size_left ) ;
+
+		unless ( defined $read_cnt ) {
+
+# handle the read error
+
+			@_ = ( \%args, "read_file '$file_name' - sysread: $!");
+			goto &_error ;
 		}
+
+		return $buf ;
 	}
 
 # infinite read loop. we exit when we are done slurping
@@ -158,26 +216,26 @@ ERR
 		my $read_cnt = sysread( $read_fh, ${$buf_ref},
 				$size_left, length ${$buf_ref} ) ;
 
-		if ( defined $read_cnt ) {
+		unless ( defined $read_cnt ) {
+
+# handle the read error
+
+			@_ = ( \%args, "read_file '$file_name' - sysread: $!");
+			goto &_error ;
+		}
 
 # good read. see if we hit EOF (nothing left to read)
 
-			last if $read_cnt == 0 ;
+		last if $read_cnt == 0 ;
 
 # loop if we are slurping a handle. we don't track $size_left then.
 
-			next if $blk_size ;
+		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 ;
+		$size_left -= $read_cnt ;
+		last if $size_left <= 0 ;
 	}
 
 # fix up cr/lf to be a newline if this is a windows text file
@@ -354,7 +412,12 @@ sub write_file {
 
 # handle the atomic mode - move the temp file to the original filename.
 
-	rename( $file_name, $orig_file_name ) if $args->{'atomic'} ;
+	if ( $args->{'atomic'} && !rename( $file_name, $orig_file_name ) ) {
+
+
+		@_ = ( $args, "write_file '$file_name' - rename: $!" ) ;
+		goto &_error ;
+	}
 
 	return 1 ;
 }