#!/usr/bin/perl

use strict ;

use warnings ;

use Getopt::Long ;

use Benchmark qw( timethese cmpthese ) ;

use Carp ;

use FileHandle ;

use Fcntl qw( :DEFAULT :seek );

use File::Slurp () ;

use FileSlurp_12 () ;

my $file_name = 'slurp_data' ;

my( @lines, $text ) ;

my %opts ;

parse_options() ;

run_benchmarks() ;

unlink $file_name ;

exit ;

sub run_benchmarks {

	foreach my $size ( @{$opts{size_list}} ) {

		@lines = ( 'a' x 80 . "\n") x ( $size / 81 + 1 ) ;

		$text = join( '', @lines ) ;

		my $overage = length($text) - $size ;

		substr( $text, -$overage, $overage, '' ) ;

		substr( $lines[-1], -$overage, $overage, '' ) ;

		if ( $opts{slurp} ) {

			File::Slurp::write_file( $file_name, $text ) ;

			bench_list_slurp( $size ) if $opts{list} ;

	 		bench_scalar_slurp( $size ) if $opts{scalar} ;

		}

		if ( $opts{spew} ) {

			bench_spew_list( $size ) if $opts{list} ;

	 		bench_scalar_spew( $size ) if $opts{scalar} ;

		}

	}

}

##########################################

##########################################

sub bench_scalar_slurp {

	my ( $size ) = @_ ;

	print "\n\nReading (Slurp) into a scalar: Size = $size bytes\n\n" ;

	my $buffer ;

	my $result = timethese( $opts{iterations}, {

		'FS::read_file' =>

	    		sub { my $text = File::Slurp::read_file( $file_name ) },

		'FS12::read_file' =>

	    		sub { my $text = FileSlurp_12::read_file( $file_name ) },

		'FS::read_file_buf_ref' =>

	    		sub { my $text ;

			   File::Slurp::read_file( $file_name, buf_ref => \$text ) },

		'FS::read_file_buf_ref2' =>

	    		sub { 

			   File::Slurp::read_file( $file_name, buf_ref => \$buffer ) },

		'FS::read_file_scalar_ref' =>

	    		sub { my $text =

			    File::Slurp::read_file( $file_name, scalar_ref => 1 ) },

		old_sysread_file =>

	    		sub { my $text = old_sysread_file( $file_name ) },

		old_read_file =>

	    		sub { my $text = old_read_file( $file_name ) },

		orig_read_file =>

			sub { my $text = orig_read_file( $file_name ) },

		orig_slurp =>

			sub { my $text = orig_slurp_scalar( $file_name ) },

		file_contents =>

			sub { my $text = file_contents( $file_name ) },

		file_contents_no_OO =>

			sub { my $text = file_contents_no_OO( $file_name ) },

	} ) ;

	cmpthese( $result ) ;

}

##########################################

sub bench_list_slurp {

	my ( $size ) = @_ ;

	print "\n\nReading (Slurp) into a list: Size = $size bytes\n\n" ;

	my $result = timethese( $opts{iterations},  {

		'FS::read_file' =>

	    		sub { my @lines = File::Slurp::read_file( $file_name ) },

		'FS::read_file_array_ref' =>

	    		sub { my $lines_ref =

			     File::Slurp::read_file( $file_name, array_ref => 1 ) },

		'FS::read_file_scalar' =>

	    		sub { my $lines_ref =

			     [ File::Slurp::read_file( $file_name ) ] },

		old_sysread_file =>

	    		sub { my @lines = old_sysread_file( $file_name ) },

		old_read_file =>

	    		sub { my @lines = old_read_file( $file_name ) },

		orig_read_file =>

			sub { my @lines = orig_read_file( $file_name ) },

		orig_slurp_array =>

			sub { my @lines = orig_slurp_array( $file_name ) },

		orig_slurp_array_ref =>

			sub { my $lines_ref = orig_slurp_array( $file_name ) },

	} ) ;

	cmpthese( $result ) ;

}

######################################

# uri's old fast slurp

sub old_read_file {

	my( $file_name ) = shift ;

	local( *FH ) ;

	open( FH, $file_name ) || carp "can't open $file_name $!" ;

	return <FH> if wantarray ;

	my $buf ;

	read( FH, $buf, -s FH ) ;

	return $buf ;

}

sub old_sysread_file {

	my( $file_name ) = shift ;

	local( *FH ) ;

	open( FH, $file_name ) || carp "can't open $file_name $!" ;

	return <FH> if wantarray ;

	my $buf ;

	sysread( FH, $buf, -s FH ) ;

	return $buf ;

}

######################################

# from File::Slurp.pm on cpan

sub orig_read_file

{

	my ($file) = @_;

	local($/) = wantarray ? $/ : undef;

	local(*F);

	my $r;

	my (@r);

	open(F, "<$file") || croak "open $file: $!";

	@r = <F>;

	close(F) || croak "close $file: $!";

	return $r[0] unless wantarray;

	return @r;

}

######################################

# from Slurp.pm on cpan

sub orig_slurp { 

    local( $/, @ARGV ) = ( wantarray ? $/ : undef, @_ ); 

    return <ARGV>;

}

sub orig_slurp_array {

    my @array = orig_slurp( @_ );

    return wantarray ? @array : \@array;

}

sub orig_slurp_scalar {

    my $scalar = orig_slurp( @_ );

    return $scalar;

}

######################################

# very slow slurp code used by a client

sub file_contents {

    my $file = shift;

    my $fh = new FileHandle $file or

        warn("Util::file_contents:Can't open file $file"), return '';

    return join '', <$fh>;

}

# same code but doesn't use FileHandle.pm

sub file_contents_no_OO {

    my $file = shift;

	local( *FH ) ;

	open( FH, $file ) || carp "can't open $file $!" ;

    return join '', <FH>;

}

##########################################

##########################################

sub bench_spew_list {

	my( $size ) = @_ ;

	print "\n\nWriting (Spew) a list of lines: Size = $size bytes\n\n" ;

	my $result = timethese( $opts{iterations}, {

 		'FS::write_file'	=> sub { unlink $file_name if $opts{unlink} ; 

			File::Slurp::write_file( $file_name, @lines ) },

 		'FS::write_file Aref'	=> sub { unlink $file_name if $opts{unlink} ; 

			File::Slurp::write_file( $file_name, \@lines ) },

		'print'			=> sub { unlink $file_name if $opts{unlink} ; 

			print_file( $file_name, @lines ) },

		'print/join'		=> sub { unlink $file_name if $opts{unlink} ; 

			print_join_file( $file_name, @lines ) },

		'syswrite/join'		=> sub { unlink $file_name if $opts{unlink} ;

			syswrite_join_file( $file_name, @lines ) },

		'original write_file'	=> sub {  unlink $file_name if $opts{unlink} ; 

			orig_write_file( $file_name, @lines ) },

	} ) ;

	cmpthese( $result ) ;

}

sub print_file {

	my( $file_name ) = shift ;

	local( *FH ) ;

	open( FH, ">$file_name" ) || carp "can't create $file_name $!" ;

	print FH @_ ;

}

sub print_join_file {

	my( $file_name ) = shift ;

	local( *FH ) ;

	open( FH, ">$file_name" ) || carp "can't create $file_name $!" ;

	print FH join( '', @_ ) ;

}

sub syswrite_join_file {

	my( $file_name ) = shift ;

	local( *FH ) ;

	open( FH, ">$file_name" ) || carp "can't create $file_name $!" ;

	syswrite( FH, join( '', @_ ) ) ;

}

sub sysopen_syswrite_join_file {

	my( $file_name ) = shift ;

	local( *FH ) ;

	sysopen( FH, $file_name, O_WRONLY | O_CREAT ) ||

				carp "can't create $file_name $!" ;

	syswrite( FH, join( '', @_ ) ) ;

}

sub orig_write_file

{

	my ($f, @data) = @_;

	local(*F);

	open(F, ">$f") || croak "open >$f: $!";

	(print F @data) || croak "write $f: $!";

	close(F) || croak "close $f: $!";

	return 1;

}

##########################################

sub bench_scalar_spew {

	my ( $size ) = @_ ;

	print "\n\nWriting (Spew) a scalar: Size = $size bytes\n\n" ;

	my $result = timethese( $opts{iterations}, {

		'FS::write_file'	=> sub { unlink $file_name if $opts{unlink} ;

			File::Slurp::write_file( $file_name, $text ) },

		'FS::write_file Sref'	=> sub { unlink $file_name if $opts{unlink} ; 

			File::Slurp::write_file( $file_name, \$text ) },

		'print'			=> sub { unlink $file_name if $opts{unlink} ; 

			print_file( $file_name, $text ) },

		'syswrite_file'		=> sub { unlink $file_name if $opts{unlink} ; 

			syswrite_file( $file_name, $text ) },

		'syswrite_file_ref'	=> sub { unlink $file_name if $opts{unlink} ; 

			syswrite_file_ref( $file_name, \$text ) },

		'orig_write_file'	=> sub { unlink $file_name if $opts{unlink} ; 

			orig_write_file( $file_name, $text ) },

	} ) ;

	cmpthese( $result ) ;

}

sub syswrite_file {

	my( $file_name, $text ) = @_ ;

	local( *FH ) ;

	open( FH, ">$file_name" ) || carp "can't create $file_name $!" ;

	syswrite( FH, $text ) ;

}

sub syswrite_file_ref {

	my( $file_name, $text_ref ) = @_ ;

	local( *FH ) ;

	open( FH, ">$file_name" ) || carp "can't create $file_name $!" ;

	syswrite( FH, ${$text_ref} ) ;

}

sub parse_options {

	my $result = GetOptions (\%opts, qw(

		iterations|i=s

		direction|d=s

		context|c=s

		sizes|s=s

		unlink|u

		legend|key|l|k

		help|usage

	) ) ;

	usage() unless $result ;

	usage() if $opts{help} ;

	legend() if $opts{legend} ;

# set defaults

	$opts{direction} ||= 'both' ;

	$opts{context} ||= 'both' ;

	$opts{iterations} ||= -2 ;

	$opts{sizes} ||= '512,10k,1m' ;

	if ( $opts{direction} eq 'both' ) {

		$opts{spew} = 1 ;

		$opts{slurp} = 1 ;

	}

	elsif ( $opts{direction} eq 'in' ) {

		$opts{slurp} = 1 ;

	}

	elsif ( $opts{direction} eq 'out' ) {

		$opts{spew} = 1 ;

	}

	else {

		usage( "Unknown direction: $opts{direction}" ) ;

	}

	if ( $opts{context} eq 'both' ) {

		$opts{list} = 1 ;

		$opts{scalar} = 1 ;

	}

	elsif ( $opts{context} eq 'scalar' ) {

		$opts{scalar} = 1 ;

	}

	elsif ( $opts{context} eq 'list' ) {

		$opts{list} = 1 ;

	}

	else {

		usage( "Unknown context: $opts{context}" ) ;

	}

	if ( $opts{context} eq 'both' ) {

		$opts{list} = 1 ;

		$opts{scalar} = 1 ;

	}

	elsif ( $opts{context} eq 'scalar' ) {

		$opts{scalar} = 1 ;

	}

	elsif ( $opts{context} eq 'list' ) {

		$opts{list} = 1 ;

	}

	else {

		usage( "Unknown context: $opts{context}" ) ;

	}

	foreach my $size ( split ',', ( $opts{sizes} ) ) {

# check for valid size and suffix. grab both.

		usage( "Illegal size: $size") unless $size =~ /^(\d+)([km])?$/ ;

# handle suffix multipliers

		$size =  $1 * (( $2 eq 'k' ) ? 1024 : 1024*1024) if $2 ;

		push( @{$opts{size_list}}, $size ) ;

	}

#use Data::Dumper ;

#print Dumper \%opts ;

}

sub legend {

	die <<'LEGEND' ;

--------------------------------------------------------------------------

Legend for the Slurp Benchmark Entries

In all cases below 'FS' or 'F::S' means the current File::Slurp module

is being used in the benchmark. The full name and description will say

which options are being used.

--------------------------------------------------------------------------

These benchmarks write a list of lines to a file. Use the direction option

of 'out' or 'both' and the context option is 'list' or 'both'.

	Key			Description/Source

	-----			--------------------------

	FS::write_file		Current F::S write_file

	FS::write_file Aref	Current F::S write_file on array ref of data

	print			Open a file and call print() on the list data

	print/join		Open a file and call print() on the joined list

				data

	syswrite/join		Open a file, call syswrite on joined list data

	sysopen/syswrite	Sysopen a file, call syswrite on joined list

				data

	original write_file	write_file code from original File::Slurp

				(pre-version 9999.*)

--------------------------------------------------------------------------

These benchmarks write a scalar to a file. Use the direction option

of 'out' or 'both' and the context option is 'scalar' or 'both'.

	Key			Description/Source

	-----			--------------------------

	FS::write_file		Current F::S write_file

	FS::write_file Sref	Current F::S write_file of scalar ref of data

	print			Open a file and call print() on the scalar data

	syswrite_file		Open a file, call syswrite on scalar data

	syswrite_file_ref	Open a file, call syswrite on scalar ref of

				data

	orig_write_file		write_file code from original File::Slurp

				(pre-version 9999.*)

--------------------------------------------------------------------------

These benchmarks slurp a file into an array. Use the direction option

of 'in' or 'both' and the context option is 'list' or 'both'.

	Key				Description/Source

	-----				--------------------------

	FS::read_file			Current F::S read_file - returns array

	FS::read_file_array_ref		Current F::S read_file - returns array

					ref in any context

	FS::read_file_scalar		Current F::S read_file - returns array

					ref in scalar context

	old_sysread_file		My old fast slurp - calls sysread

	old_read_file			My old fast slurp - calls read

	orig_read_file			Original File::Slurp on CPAN 

	orig_slurp_array		Slurp.pm on CPAN - returns array

	orig_slurp_array_ref		Slurp.pm on CPAN - returns array ref

--------------------------------------------------------------------------

These benchmarks slurp a file into a scalar. Use the direction option

of 'in' or 'both' and the context option is 'scalar' or 'both'.

	Key				Description/Source

	-----				--------------------------

	FS::read_file			Current F::S read_file - returns scalar

	FS12::read_file			F::S .12 slower read_file -

					returns scalar

	FS::read_file_buf_ref		Current F::S read_file - returns

					via buf_ref argument - new buffer

	FS::read_file_buf_ref2		Current F::S read_file - returns

					via buf_ref argument - uses

					existing buffer

	FS::read_file_scalar_ref	Current F::S read_file - returns a 

					scalar ref

	old_sysread_file		My old fast slurp - calls sysread

	old_read_file			My old fast slurp - calls read

	orig_read_file			Original File::Slurp on CPAN 

	orig_slurp			Slurp.pm on CPAN

	file_contents			Very slow slurp code done by a client

	file_contents_no_OO		Same code but doesn't use FileHandle.pm 

--------------------------------------------------------------------------

LEGEND

}

sub usage {

	my( $err ) = @_ ;

	$err ||= '' ;

	die <

$err

Usage: $0 [--iterations=<iter>] [--direction=<dir>] [--context=<con>] 

          [--sizes=<size_list>] [--legend] [--help]

	--iterations=<iter>	Run the benchmarks this many iterations

	-i=<iter>		A positive number is iteration count,

				a negative number is minimum CPU time in

				seconds. Default is -2 (run for 2 CPU seconds).

	--direction=<dir>	Which direction to slurp: 'in', 'out' or 'both'.

	-d=<dir>		Default is 'both'.

	--context=<con>		Which context is used for slurping: 'list',

	-c=<con>		'scalar' or 'both'. Default is 'both'.

	--sizes=<size_list>	What sizes will be used in slurping (either

	-s=<size_list>		direction). This is a comma separated list of

				integers. You can use 'k' or 'm' as suffixes

				for 1024 and 1024**2. Default is '512,10k,1m'.

	--unlink		Unlink the written file before each time

	-u			a file is written

	--legend		Print out a legend of all the benchmark entries.

	--key

	-l

	-k

	--help			Print this help text

	--usage

DIE

}

__END__