view release on metacpan or  search on metacpan

lib/FileHandle/Unget.pm  view on Meta::CPAN

package FileHandle::Unget;

use strict;
use Symbol;
use FileHandle;
use Exporter;
use Scalar::Util qw( weaken );

use 5.005;

use vars qw( @ISA $VERSION $AUTOLOAD @EXPORT @EXPORT_OK );

@ISA = qw( Exporter FileHandle );

$VERSION = sprintf "%d.%02d%02d", q/0.16.34/ =~ /(\d+)/g;

@EXPORT = @FileHandle::EXPORT;
@EXPORT_OK = @FileHandle::EXPORT_OK;

# Based on dump_methods from this most helpful post by MJD:
# http://groups.google.com/groups?selm=20020621182734.15920.qmail%40plover.com
# We can't just use AUTOLOAD because AUTOLOAD is not called for inherited
# methods
sub wrap_methods
{
  no strict 'refs'; ## no critic (strict)

  my $class = shift or return;
  my $seen = shift || {};

  # Locate methods in this class
  my $symtab = \%{"$class\::"};
  my @names = keys %$symtab;
  for my $method (keys %$symtab) 
  { 
    my $fullname = "$class\::$method";

    next unless defined &$fullname;
    next if defined &{__PACKAGE__ . "::$method"};
    next if $method eq 'import';

    unless ($seen->{$method})
    {
      $seen->{$method} = $fullname;

      *{$method} = sub
        {
          my $self = $_[0];

          if (ref $self eq __PACKAGE__)
          {
            shift @_;
            my $super = "SUPER::$method";
            $self->$super(@_);
          }
          else
          {
            $method = "FileHandle::$method";
            &$method(@_);
          }
        };
    }
  }

  # Traverse parent classes of this one
  my @ISA = @{"$class\::ISA"};
  for my $class (@ISA)
  {
    wrap_methods($class, $seen);
  }
}

wrap_methods('FileHandle');

#-------------------------------------------------------------------------------

sub DESTROY
{
}

#-------------------------------------------------------------------------------

sub new
{
  my $class = shift;

  my $self;

  if (defined $_[0] && defined fileno $_[0])
  {
    $self = shift;
  }
  else
  {
    $self = $class->SUPER::new(@_);
    return undef unless defined $self; ## no critic (ProhibitExplicitReturnUndef)
  }

  my $values =
    {
      'fh' => $self,
      'eof_called' => 0,
      'filehandle_unget_buffer' => '',
    };

  weaken($values->{'fh'});
  
  tie *$self, "${class}::Tie", $values;

  bless $self, $class;
  return $self;
}

#-------------------------------------------------------------------------------

sub new_from_fd
{
  my $class = shift;

  my $self;

#  if (defined $_[0] && defined fileno $_[0])
#  {
#    $self = shift;
#  }
#  else
  {
    $self = $class->SUPER::new_from_fd(@_);
    return undef unless defined $self; ## no critic (ProhibitExplicitReturnUndef)
  }

  my $values =
    {
      'fh' => $self,
      'eof_called' => 0,
      'filehandle_unget_buffer' => '',
    };

  weaken($values->{'fh'});
  
  tie *$self, "${class}::Tie", $values;

  bless $self, $class;
  return $self;
}

#-------------------------------------------------------------------------------

sub ungetc
{
  my $self = shift;
  my $ord = shift;

  substr(tied(*$self)->{'filehandle_unget_buffer'},0,0) = chr($ord);
}

#-------------------------------------------------------------------------------

sub ungets
{
  my $self = shift;
  my $string = shift;

  substr(tied(*$self)->{'filehandle_unget_buffer'},0,0) = $string;
}

#-------------------------------------------------------------------------------

sub buffer
{
  my $self = shift;

  tied(*$self)->{'filehandle_unget_buffer'} = shift if @_;
  return tied(*$self)->{'filehandle_unget_buffer'};
}

#-------------------------------------------------------------------------------

sub input_record_separator
{
  my $self = shift;

  if(@_)
  {
    tied(*$self)->{'input_record_separator'} = shift;
  }

  return undef unless exists tied(*$self)->{'input_record_separator'}; ## no critic (ProhibitExplicitReturnUndef)
  return tied(*$self)->{'input_record_separator'};
}

#-------------------------------------------------------------------------------

sub clear_input_record_separator
{
  my $self = shift;

  delete tied(*$self)->{'input_record_separator'};
}