view release on metacpan or  search on metacpan

lib/Module/Generic/File/IO.pm  view on Meta::CPAN

    $self->clear_error;
    return if( ( wantarray() && !scalar( @rv ) ) || ( !wantarray() && !defined( $rv[0] ) ) );
    return( wantarray() ? @rv : $rv[0] );
}

# NOTE: DESTROY
sub DESTROY
{
    # <https://perldoc.perl.org/perlobj#Destructors>
    CORE::local( $., $@, $!, $^E, $? );
    CORE::return if( ${^GLOBAL_PHASE} eq 'DESTRUCT' );
    my $self = CORE::shift( @_ );
    CORE::return if( !CORE::defined( $self ) );

    if( ( Scalar::Util::reftype( $self ) // '' ) eq 'GLOB' )
    {
        my $fd = $self->fileno;
        if( $fd )
        {
            my $repo_key = $fd;
            my $repo = Module::Generic::Global->new( 'fd_locks' => CORE::ref( $self ), key => $repo_key );
            $repo->cleanup;
        }
        # NOTE: Storable creates a dummy object as a SCALAR instead of GLOB, so we need to check.
        $self->close if( $self->opened );
    }
}

sub FREEZE
{
    my $self = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class = CORE::ref( $self ) || $self;
    my $args = $self->args;
    # On or before Sereal version 4.023, Sereal did not support multiple values returned
    if( $serialiser eq 'Sereal' )
    {
        require Sereal::Encoder;
        require version;
    
        if( version->parse( Sereal::Encoder->VERSION ) <= version->parse( '4.023' ) )
        {
            CORE::return( [$class, \@$args] );
        }
    }
    CORE::return( $class, \@$args )
}

# NOTE: There cannot be a STORABLE_freeze subroutine, or else Storable would trigger an error "Unexpected object type (8) in store_hook()". So Storable must do it by itself, which means it will die or if $Storable::forgive_me is set to a true value, ...
# sub STORABLE_freeze { return( shift->FREEZE( @_ ) ); }
# 
# sub STORABLE_thaw { return( shift->THAW( @_ ) ); }

# NOTE: STORABLE_freeze_pre_processing called by Storable::Improved
sub STORABLE_freeze_pre_processing
{
    my $self = CORE::shift( @_ );
    my $class = CORE::ref( $self ) || $self;
    my $args = $self->args;
    # We change the glob object into a regular hash-based one to be Storable-friendly
    my $this = CORE::bless( { args => $args, class => $class } => $class );
    CORE::return( $this );
}

sub STORABLE_thaw_post_processing
{
    my $self = CORE::shift( @_ );
    my $args = ( CORE::exists( $self->{args} ) && CORE::ref( $self->{args} ) eq 'ARRAY' )
        ? $self->{args}
        : [];
    my $class = ( CORE::exists( $self->{class} ) && CORE::defined( $self->{class} ) && CORE::length( $self->{class} ) ) 
        ? $self->{class}
        : ( CORE::ref( $self ) || $self );
    # We restore our glob object. Geez that was hard. Not.
    my $obj = $THAW_REOPENS_FILE ? $class->new( @$args ) : $class->new;
    return( $obj );
}

# NOTE: THAW is called by Sereal and CBOR
sub THAW
{
    my( $self, undef, @args ) = @_;
    my $ref = ( CORE::scalar( @args ) == 1 && CORE::ref( $args[0] ) eq 'ARRAY' ) ? CORE::shift( @args ) : \@args;
    my $class = ( CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' && CORE::scalar( @$ref ) > 1 ) ? CORE::shift( @$ref ) : ( CORE::ref( $self ) || $self );
    $ref = ( CORE::scalar( @$ref ) && CORE::ref( $ref->[0] ) eq 'ARRAY' ) ? $ref->[0] : [];
    my $new;
    if( $THAW_REOPENS_FILE && CORE::defined( $ref ) && CORE::ref( $ref ) eq 'ARRAY' )
    {
        $new = $class->new( @$ref );
    }
    else
    {
        $new = $class->new;
    }
    CORE::return( $new );
}

1;
# NOTE: POD
__END__

=encoding utf-8

=head1 NAME

Module::Generic::File::IO - File IO Object Wrapper

=head1 SYNOPSIS

    use Module::Generic::File::IO;
    my $io = Module::Generic::File::IO->new || 
        die( Module::Generic::File::IO->error );

    my $io = Module::Generic::File::IO->new( 'file.txt', '>' ) || 
        die( Module::Generic::File::IO->error );

    my $io = Module::Generic::File::IO->new( fileno => $fileno ) || 
        die( Module::Generic::File::IO->error );

    use Module::Generic::File::IO qw( wraphandle );
    my $io = wraphandle( $fh );