view release on metacpan or  search on metacpan

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

        {
            if( $cwd eq $dir )
            {
                my $updir = Cwd::abs_path( File::Spec->updir );
                warnings::warn( "You currently are inside a directory to remove ($dir), moving you up to $updir\n" ) if( warnings::enabled() );
                CORE::chdir( $updir ) || do
                {
                    warnings::warn( "Unable to move to directory '$updir' above current directory: $!\n" ) if( warnings::enabled() );
                    next;
                };
            }
            CORE::rmdir( $dir ) || do
            {
                warnings::warn( "Unable to remove directory $dir: $!\n" ) if( warnings::enabled() );
            };
        }
    }
};

# NOTE: For CBOR and Sereal
sub FREEZE
{
    my $self = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class = CORE::ref( $self );
    my %hash  = %$self;
    CORE::delete( @hash{ qw( opened _handle ) } );
    # Return an array reference rather than a list so this works with Sereal and CBOR
    # On or before Sereal version 4.023, Sereal did not support multiple values returned
    CORE::return( [$class, \%hash] ) if( $serialiser eq 'Sereal' && Sereal::Encoder->VERSION <= version->parse( '4.023' ) );
    # But Storable want a list with the first element being the serialised element
    CORE::return( $class, \%hash );
}

sub STORABLE_freeze { return( shift->FREEZE( @_ ) ); }

sub STORABLE_thaw { return( shift->THAW( @_ ) ); }

# NOTE: CBOR will call the THAW method with the stored classname as first argument, the constant string CBOR as second argument, and all values returned by FREEZE as remaining arguments.
# NOTE: Storable calls it with a blessed object it created followed with $cloning and any other arguments initially provided by STORABLE_freeze
sub THAW
{
    # STORABLE_thaw would issue $cloning as the 2nd argument, while CBOR would issue
    # 'CBOR' as the second value.
    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 );
    my $hash = CORE::ref( $ref ) eq 'ARRAY' ? CORE::shift( @$ref ) : {};
    my $new;
    # Storable pattern requires to modify the object it created rather than returning a new one
    if( CORE::ref( $self ) )
    {
        foreach( CORE::keys( %$hash ) )
        {
            $self->{ $_ } = CORE::delete( $hash->{ $_ } );
        }
        $new = $self;
    }
    else
    {
        $new = CORE::bless( $hash => $class );
    }
    CORE::return( $new );
}

sub TO_JSON { return( shift->filepath ); }

# NOTE: IO::File class modification
{
    package
        IO::File;
    
    sub flock { CORE::flock( shift( @_ ), shift( @_ ) ); }
}

# NOTE: Module::Generic::File::Map class
{
    package
        Module::Generic::File::Map;
    BEGIN
    {
        use strict;
        use warnings;
        use parent qw( Tie::Scalar );
    };
    
    sub TIESCALAR
    {
        my $this = shift( @_ );
        my $class = ref( $this ) || $this;
        my $opts = shift( @_ );
        if( ref( $opts ) ne 'HASH' )
        {
            warn( "I was expecting an hash reference of options, but got instead '$opts'\n" );
            return;
        }

        my( $io, $file );
        if( !( $io = $opts->{fh} ) )
        {
            warn( "No file handle provided\n" );
            return;
        }
        if( !( $file = $opts->{file} ) )
        {
            warn( "No file path was provided.\n" );
            return;
        }
        no strict 'refs';
        my $ref = \$file;
        ${$$ref} = $opts;
        return( bless( $ref => $class ) );
    }
    
    sub FETCH
    {
        my $self = shift( @_ );
        no strict 'refs';
        my $fh;
        if( !( $fh = ${$$self}->{fh} ) )
        {
            warn( "Filehandle is gone!\n" );
            return;
        }
        my $parent  = ${$$self}->{me};
        my $data    = $parent->load;
        # Initial variable length, if any, because initially the file may be padded with nulls
        # and we do not want them. We could use unpack( 'A*', $data );, but the variable data
        # itself could have some nulls too, so we cannot rely on this.
        my $var_len = ${$$self}->{length} // 0;
        # $data =~ s/\0+$//gs;
        # $data = unpack( 'A*', $data );
        return( substr( $data, 0, $var_len ) ) if( $var_len );
        #$data = unpack( 'Z*', $data );
        $data =~ s/\0+$//g;
        return( $data );
    }
    
    sub STORE
    {
        my $self = shift( @_ );
        no strict 'refs';
        my $fh;
        if( !( $fh = ${$$self}->{fh} ) )
        {
            warn( "Filehandle is gone!\n" );
            return;
        }
        my $size   = ${$$self}->{size};
        my $parent = ${$$self}->{me};
        unless( $fh->opened )
        {
            warn( "filehandle is not opened for file \"", $parent->filename, "\".\n" );
        }
        $parent->lock( shared => 1 );
        $fh->seek(0,0) || do
        {
            warn( "Unable to set position at beginning in file \"", $parent->filename, "\": $!\n" );
            # return;
        };
        # This needs to be print and not syswrite, because we cannot mix syswrite and read/print
        if( !$fh->print( $_[0] ) )
        {
            warn( "Unable to write ", CORE::length( $_[0] // '' ), " byte(s) to file \"", $parent->filename, "\": $!\n" );
            return;
        }
        $parent->unlock;
        $fh->sync;
        $fh->flush;
        # $fh->print( "\000" x ( $size - length( $_[0] ) ) );
        if( !CORE::defined( $fh->truncate( $fh->tell ) ) )
        {