Tie::FileHandle::Base - a base class to simplify filehandle tie module implementation
Index
Code Index:
NAME
Tie::FileHandle::Base - a base class to simplify filehandle tie module implementation
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.
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.
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.
OTHERS
EOF can be implemented crudely if given READ or GETC along
with a backwards supporting SEEK.
HISTORY
- 03/09/02 - Robby Walker - did the output stuff - version 0.1
- 02/13/02 - Robby Walker - created the file - version 0.001
METHODS
- PRINT
-
Implements PRINT based on WRITE or PRINTF.
- PRINTF
-
Implements PRINTF based off of PRINT, which may in turn base itself off of WRITE.
- WRITE
-
Implements WRITE based off of PRINT, which may in turn base itself off of PRINTF.
- GETC
- READ
- READLINE
- EOF
-
Crude EOF implemented using READ and SEEK.
TODO
BUGS
This is a new module and has not been thoroughly tested.
AUTHORS AND COPYRIGHT
Written by Robby Walker ( robwalker@cpan.org ) for Point Writer ( http://www.pointwriter.com/ ).
You may redistribute/modify/etc. this module under the same terms as Perl itself.
#!/usr/local/bin/perl
#----------------------------------------------------------
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
# ------------------------------------------------------------------------
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
# ------------------------------------------------------------------------
sub PRINTF {
( shift )->PRINT( sprintf @_[1..$#_] );
}
# ------------------------------------------------------------------------
# METHOD: WRITE
# ------------------------------------------------------------------------
sub WRITE {
my ($self, $var, $length, $offset) = @_;
my $ln = $length || length( $var );
$self->PRINT( substr $var, $offset || 0, $ln ) && $ln;
}
# ------------------------------------------------------------------------
# METHOD: GETC
# ------------------------------------------------------------------------
sub GETC {
}
# ------------------------------------------------------------------------
# METHOD: READ
# ------------------------------------------------------------------------
sub READ {
}
# ------------------------------------------------------------------------
# METHOD: READLINE
# ------------------------------------------------------------------------
sub READLINE {
}
# ------------------------------------------------------------------------
# METHOD: EOF
# ------------------------------------------------------------------------
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__