view release on metacpan or  search on metacpan

lib/Data/Handle.pm  view on Meta::CPAN

my %datastash;
use Symbol qw( gensym );
use Scalar::Util qw( weaken );
use parent qw( IO::File );
use Package::Stash 0.15;    # has_symbol
use Carp ();
use Data::Handle::Exception;
use Data::Handle::IO;
use Try::Tiny qw( try catch );









sub new {
  my ( $class, $targetpackage ) = @_;

  _e('NoSymbol')->throw("$targetpackage has no DATA symbol")
    if ( !$class->_has_data_symbol($targetpackage) );

  if ( !$class->_is_valid_data_tell($targetpackage) ) {
    _e('BadFilePos')
      ->throw( "$targetpackage has a DATA symbol, but the filepointer"
        . " is well beyond the __DATA__ section.\n"
        . " We can't work out safely where it is.\n"
        . $class->_stringify_metadata($targetpackage)
        . "\n" );
  }

  my $sym  = gensym();
  my $xsym = $sym;
  weaken($xsym);

  ## no critic( ProhibitTies )
  tie *{$sym}, 'Data::Handle::IO', { self => $xsym };
  ${ *{$sym} }{stash} = {};
  bless $sym, $class;
  $sym->_stash->{start_offset}   = $class->_get_start_offset($targetpackage);
  $sym->_stash->{targetpackage}  = $targetpackage;
  $sym->_stash->{current_offset} = $class->_get_start_offset($targetpackage);
  $sym->_stash->{filehandle}     = $class->_get_data_symbol($targetpackage);
  return $sym;

}

sub _has_data_symbol {
  my ( undef, $package ) = @_;
  my $rval = undef;
  try {
    my $stash = Package::Stash->new($package);
    return unless $stash->has_symbol('DATA');
    my $fh = $stash->get_symbol('DATA');
    $rval = defined fileno *{$fh};
  }
  catch {
    if (/is not a module name/) {
      $rval = undef;
      return;
    }
    ## no critic (RequireCarping)
    die $_;
  };
  return $rval;
}

sub _get_data_symbol {
  my ( $self, $package ) = @_;
  if ( !$self->_has_data_symbol($package) ) {
    _e('Internal::BadGet')->throw('_get_data_symbol was called when there is no data_symbol to get');
  }
  return Package::Stash->new($package)->get_symbol('DATA');
}

sub _get_start_offset {
  my ( $self, $package ) = @_;

  return $datastash{$package}->{offset}
    if ( exists $datastash{$package}->{offset} );

  if ( !$self->_has_data_symbol($package) ) {
    _e('Internal::BadGet')->throw('_get_start_offset was called when there is no data_symbol to get');
  }
  my $fd       = $self->_get_data_symbol($package);
  my $position = tell $fd;

  $datastash{$package}->{offset} = $position;

  return $position;
}

sub _is_valid_data_tell {
  my ( $self, $package ) = @_;