File Coverage

blib/lib/Tie/FileHandle/Base.pm

Criterion	Covered	Total	%
statement	6	44	13.6
branch	0	18	0.0
condition	0	5	0.0
subroutine	2	10	20.0
pod			n/a
total	8	77	10.3

#!/usr/local/bin/perl

=head1 NAME

Tie::FileHandle::Base - a base class to simplify filehandle tie module implementation

=head1 DESCRIPTION

By noting the redundancies inherent in the filehandle tie methods, this
module seeks to aid in implementation of new modules by reducing the number
of required functions.

Care should be taken by classes that use AUTOLOAD.  Make sure to predeclare
subroutines that will be autoloaded - as in:

 sub PRINT;

Otherwise this module will make incorrect presumptions and your module will
not function as you intend.

=head2 OUTPUT FUNCTIONS

Since PRINT, PRINTF, and WRITE are all quite similar in scope, any one of
these can be implemented from any of the others.  So, you only need implement
one of the above.

=head2 INPUT FUNCTIONS

By implementing READ or GETC, you can get the entire complement of READ,
READLINE, and GETC.   Note however that READ and GETC cannot be derived
nicely from READLINE.

=head2 OTHERS

EOF can be implemented crudely if given READ or GETC along
with a backwards supporting SEEK.

=head1 HISTORY

=over 2

=item *

03/09/02 - Robby Walker - did the output stuff - version 0.1

=item *

02/13/02 - Robby Walker - created the file - version 0.001

=back

=head1 METHODS

=over 4

=cut
#----------------------------------------------------------

package Tie::FileHandle::Base;

use vars qw($VERSION %loop);
use strict;

$VERSION = 0.1;
%loop = ();

# ------------------------------------------------------------------------
# METHOD: _fh_error
# ------------------------------------------------------------------------
# Our replacement for 'croak' or 'die' that errors to the proper level
sub _fh_error {
	my $error_string = shift;
	my $i = 1;
	while (my ($package, $filename, $line, $subroutine,
	        undef, undef, undef, undef, undef, undef) = caller($i++) )
	{
		if ( $package ne 'Tie::FileHandle::Base' ) {
			$subroutine =~ s/.*\:([^:]+)/$1/;
			die "Cannot execute filehandle method $subroutine : $error_string at $filename line $line\n";
		}
	}
}

# ------------------------------------------------------------------------
# METHOD: PRINT
# ------------------------------------------------------------------------

=item PRINT

Implements PRINT based on WRITE or PRINTF.

=cut
sub PRINT {
	my $self = shift;
	my $result = 0;

	# guard against loops
	_fh_error( "function not defined" ) if ( $loop{$self} );
	$loop{$self} = 1;

	if ( $self->can('WRITE') != \&WRITE ) {
		# loop over the strings
		$result = 1;
		foreach my $str ( @_ ) {
			# print each string carefully
			my $offset = 0;
			my $ln = length( $str );
			# loop until all characters are printed
			while ( $offset != $ln ) {
				my $ret = $self->WRITE( $str, $ln - $offset, $offset );
				unless ( $ret ) {
					$result = undef;
					last;
				}
			};
			# see if we exited early
			last if $offset != $ln;
		}

	} elsif ( $self->can('PRINTF') != \&PRINTF ) {
		$result = $self->PRINTF( '%s' x (@_+0), @_ );

	} else {
		_fh_error( "function not defined" );
	}

	$loop{$self} = 0;
	1;
}

# ------------------------------------------------------------------------
# METHOD: PRINTF
# ------------------------------------------------------------------------

=item PRINTF

Implements PRINTF based off of PRINT, which may in turn base itself off of WRITE.

=cut
sub PRINTF {
	( shift )->PRINT( sprintf @_[1..$#_] );
}

# ------------------------------------------------------------------------
# METHOD: WRITE
# ------------------------------------------------------------------------

=item WRITE

Implements WRITE based off of PRINT, which may in turn base itself off of PRINTF.

=cut
sub WRITE {
	my ($self, $var, $length, $offset) = @_;
	my $ln = $length || length( $var );
	$self->PRINT( substr $var, $offset || 0, $ln ) && $ln;
}

# ------------------------------------------------------------------------
# METHOD: GETC
# ------------------------------------------------------------------------

=item GETC

=cut
sub GETC {

}

# ------------------------------------------------------------------------
# METHOD: READ
# ------------------------------------------------------------------------

=item READ

=cut
sub READ {

}

# ------------------------------------------------------------------------
# METHOD: READLINE
# ------------------------------------------------------------------------

=item READLINE

=cut
sub READLINE {

}

# ------------------------------------------------------------------------
# METHOD: EOF
# ------------------------------------------------------------------------

=item EOF

Crude EOF implemented using READ and SEEK.

=cut
sub EOF {
	my $self = shift;
	if ( $self->can('SEEK') ) {
		my $temp;
		# test EOF by reading
		return 1 unless $self->READ( $temp, 1 );
		$self->SEEK( 1, -1 ); # go back to where we were
	}
	return 0;
}



1;

__END__