1#!/usr/local/bin/perl -ws 2 3use strict ; 4use warnings ; 5use Carp ; 6use Config ; 7use Fcntl qw( :seek ) ; 8use File::Temp qw( tempfile ); 9use Test::More ; 10 11use File::ReadBackwards ; 12 13# NOTE: much of this code was taken from the core perl test script 14# ops/lfs.t. it was modified to test File::ReadBackwards and large files 15 16my (undef, $test_file) = tempfile('bw-XXXXXX', SUFFIX => '.data', TMPDIR => 1, CLEANUP => 1); 17 18my @test_lines = ( 19 "3rd from last line\n", 20 "2nd from last\n", 21 "last line\n", 22) ; 23 24my $test_text = join '', @test_lines ; 25 26 27sub skip_all_tests { 28 29 my( $skip_text ) = @_ ; 30 31# unlink $test_file ; 32 plan skip_all => $skip_text ; 33} 34 35if( $Config{lseeksize} < 8 ) { 36 skip_all_tests( "no 64-bit file offsets\n" ) ; 37} 38 39unless( $Config{uselargefiles} ) { 40 skip_all_tests( "no large file support\n" ) ; 41} 42 43unless ( have_sparse_files() ) { 44 skip_all_tests( "no sparse file support\n" ) ; 45} 46 47# run the long seek code below in a subprocess in case it exits with a 48# signal 49 50my $rc = system $^X, '-e', <<"EOF"; 51open(BIG, ">$test_file"); 52seek(BIG, 5_000_000_000, 0); 53print BIG "$test_text" ; 54exit 0; 55EOF 56 57if( $rc ) { 58 59 my $error = 'signal ' . ($rc & 0x7f) ; 60 skip_all_tests( "seeking past 2GB failed: $error" ) ; 61} 62 63open(BIG, ">$test_file"); 64 65unless( seek(BIG, 5_000_000_000, 0) ) { 66 skip_all_tests( "seeking past 2GB failed: $!" ) ; 67} 68 69 70# Either the print or (more likely, thanks to buffering) the close will 71# fail if there are are filesize limitations (process or fs). 72 73my $print = print BIG $test_text ; 74my $close = close BIG; 75 76unless ($print && $close) { 77 78 print "# print failed: $!\n" unless $print; 79 print "# close failed: $!\n" unless $close; 80 81 if( $! =~/too large/i ) { 82 skip_all_tests( 'writing past 2GB failed: process limits?' ) ; 83 } 84 85 if( $! =~ /quota/i ) { 86 skip_all_tests( 'filesystem quota limits?' ) ; 87 } 88 89 skip_all_tests( "large file error: $!" ) ; 90} 91 92plan tests => 2 ; 93 94my $bw = File::ReadBackwards->new( $test_file ) or 95 die "can't open $test_file: $!" ; 96 97my $line = $bw->readline() ; 98is( $line, $test_lines[-1], 'last line' ) ; 99 100$line = $bw->readline() ; 101is( $line, $test_lines[-2], 'next to last line' ) ; 102 103unlink $test_file ; 104 105exit ; 106 107 108######## subroutines 109 110# this is lifted wholesale from t/op/lfs.t in perl. Also, Uri is the 111# wind beneath my wings. 112sub have_sparse_files { 113 114 # don't even try for spare files on some OSs 115 return 0 if { 116 map { $_ => 1 } qw( MSWin32 NetWare VMS unicos ) 117 }->{ $^O }; 118 # take that, readability. 119 120 my (undef,$big0) = tempfile(); 121 my (undef,$big1) = tempfile(); 122 my (undef,$big2) = tempfile(); 123 124 # We'll start off by creating a one megabyte file which has 125 # only three "true" bytes. If we have sparseness, we should 126 # consume less blocks than one megabyte (assuming nobody has 127 # one megabyte blocks...) 128 129 open(BIG, ">$big1") or 130 die "open $big1 failed: $!"; 131 binmode(BIG) or 132 die "binmode $big1 failed: $!"; 133 seek(BIG, 1_000_000, SEEK_SET) or 134 die "seek $big1 failed: $!"; 135 print BIG "big" or 136 die "print $big1 failed: $!"; 137 close(BIG) or 138 die "close $big1 failed: $!"; 139 140 my @s1 = stat($big1); 141 142 # diag "s1 = @s1"; 143 144 open(BIG, ">$big2") or 145 die "open $big2 failed: $!"; 146 binmode(BIG) or 147 die "binmode $big2 failed: $!"; 148 seek(BIG, 2_000_000, SEEK_SET) or 149 die "seek $big2 failed: $!"; 150 print BIG "big" or 151 die "print $big2 failed: $!"; 152 close(BIG) or 153 die "close $big2 failed: $!"; 154 155 my @s2 = stat($big2); 156 157# diag "s2 = @s2"; 158 159 unless ( 160 $s1[7] == 1_000_003 && $s2[7] == 2_000_003 && 161 $s1[11] == $s2[11] && $s1[12] == $s2[12] && 162 $s1[12] > 0 ) { 163# diag 'no sparse files. sad face.'; 164 return 0; 165 } 166 167# diag 'we seem to have sparse files...'; 168 169 return 1 ; 170} 171 172 173 174