view release on metacpan or  search on metacpan

lib/DB/Object.pm  view on Meta::CPAN

        return( $self->error( "This method must be called by the database object itself." ) );
    }

    # Cannot be called without using a DB::Object
    my $dbo         = $self;
    my $cache_size  = $dbo->cache_size // 0;
    my $cache       = $dbo->{cache};
    # We want to know what kind of cache we are expected to use
    my $cache_query = $opts->{cache_query} // $dbo->cache_query // 1;
    my $cache_dir   = $opts->{cache_dir} // $dbo->cache_dir // $self->sys_tmpdir;
    my $ext         = $opts->{extension} // 'bin';

    my $use_file_cache = ( defined( $cache_query ) && $cache_query eq 'file' ) ? 1 : 0;

    # Not a hard error
    if( $cache_query !~ /^1|0|file$/ )
    {
        warn( "Unknown value for cache_query '$cache_query'" ) if( $self->_is_warnings_enabled( 'DB::Object' ) );
    }

    my $serialiser = $opts->{serialiser} || $self->serialiser || $DB::Object::SERIALISER || 'Storable';
    # If the serialiser selected is the default one, and we have Sereal installed, we use it instead.
    if( $serialiser eq 'Storable' && $self->_load_class( 'Sereal' ) )
    {
        $serialiser = 'Sereal';
    }
    $name = lc( $serialiser ) . "-${name}";

    # We make sure the extension passed to '_get_cache_filepath' is coherent with ours
    my $cache_file = $self->_get_cache_filepath( %$opts, name => $name, extension => $ext, prefix => 'query' ) ||
        return( $self->pass_error );
    my $cache_key = $cache_file->basename( ".${ext}" );

    my $lock;
    my $repo = Module::Generic::Global->new( queries_cache => $base_class,
        max_size    => $cache_size,
        serialiser  => $serialiser,
        key         => $cache_key,
    ) || return( $self->pass_error( Module::Generic::Global->error ) );
    # The lock gets removed automatically when it gets out of scope, so we store it in $lock
    $lock = $repo->lock;

    if( $cache_query eq 'file' )
    {
        # If it is already there, we return immediately. There is nothing more to do.
        if( $cache_file->exists &&
            !$cache_file->is_file )
        {
            return( $self->error( "There already existing a cache file $cache_file, but it is not a file!" ) );
        }
        if( $cache_file->exists &&
            $cache_file->is_file &&
            !$cache_file->is_empty )
        {
            return( $sth );
        }
        $self->Module::Generic::serialise( $sth,
            file       => $cache_file,
            lock       => 1,
            serialiser => $serialiser,
            ( $serialiser eq 'Sereal' ? ( freeze_callbacks => 1 ) : () ),
        ) || return( $self->pass_error );
    }
    elsif( $cache_query )
    {
        $repo->set( $sth );
        $repo->unlock;
    }
    return( $sth );
}

sub cache_size { return( shift->_set_get_scalar( 'cache_size', @_ ) ); }

sub cache_table { return( shift->_set_get_scalar( 'cache_table', @_ ) ); }

sub cache_tables { return( shift->_set_get_object( 'cache_tables', 'DB::Object::Cache::Tables', @_ ) ); }

sub check_driver()
{
    my $self   = shift( @_ );
    my $driver = shift( @_ ) || return( $self->error( "No SQL driver provided to check" ) );
    my $ok     = undef();
    local $_;
    my @drivers = $self->available_drivers();
    foreach( @drivers ) 
    {
        if( m/$driver/s )
        {
            $ok++;
            last;
        }
    }
    return( $ok );
}

sub connect
{
    my $this  = shift( @_ );
    my $class = ref( $this ) || $this;
    my $base_class = $this->base_class;
    my $opts  = $this->_get_args_as_hash( @_ );
    # We pass the arguments so that debug and other init parameters can be set early
    my $that  = ref( $this ) ? $this : $this->Module::Generic::new( debug => $opts->{debug} );
    my $param = $that->_connection_params2hash( $opts ) || return( $this->error( "No valid connection parameters found" ) );
    $param    = $that->_connection_params2hash_driver( $param );
    my $driver2pack = 
    {
        mysql  => 'DB::Object::Mysql',
        Pg     => 'DB::Object::Postgres',
        SQLite => 'DB::Object::SQLite',
    };
    my $pack2driver = +{ map{ $driver2pack->{ $_ } => $_ } keys( %$driver2pack ) };
    my $driver_class;
    if( exists( $param->{driver} ) )
    {
        if( !exists( $driver2pack->{ $param->{driver} } ) )
        {
            return( $this->error( "Driver $param->{driver} is not supported." ) );
        }
        # For example, will make this object a DB::ObjectD::Postgres object
        $driver_class  = $driver2pack->{ $param->{driver} };

lib/DB/Object.pm  view on Meta::CPAN

            # Unexpected file name format; ignore it
            warn( "Ignoring cache file with unexpected name format: '$f'" ) if( $self->_is_warnings_enabled( 'DB::Object' ) );
            return;
        }

        $self->_load_class( $base_class, { force => 1 } ) || return( $self->pass_error );
        $self->_load_class( 'DB::Object::Tables', { force => 1 } ) || return( $self->pass_error );
        $self->_load_class( 'DB::Object::Constraint::Foreign', { force => 1 } ) || return( $self->pass_error );
        $self->_load_class( "${base_class}::Tables", { force => 1 } ) || return( $self->pass_error );
        my $tbl  = $self->Module::Generic::deserialise(
            file => $f,
            lock => 1,
            serialiser => $serialiser,
        ) || return;
        unless( $self->_is_a( $tbl => "${base_class}::Tables" ) )
        {
            warn( "Deserialised object from file '$f' is not a ${base_class}::Tables object, but a '", ref( $tbl ), " object." ) if( $self->_is_warnings_enabled( 'DB::Object' ) );
            return;
        }

        # bless( $tbl => $table_class );
        $tbl->attach( $dbo ) || return( $self->pass_error( $tbl->error ) );
        return( $tbl );
    };

    # The caller wants the whole shebang
    if( !defined( $table ) )
    {
        # The caller wants all the table objects for that host and database
        my @files = $cache_dir->glob( "${prefix}-[a-zA-Z0-9_][a-zA-Z0-9_\\-\\.]*.bin" );
        my $cache = {};
        foreach my $f ( @files )
        {
            my $table  = $deserialise_from_file->( $f ) || next;
            my $name   = $f->basename( '.bin' );
            if( index( $name, $prefix ) != 0 )
            {
                # Unexpected file name format; ignore it
                warn( "Ignoring cache file with unexpected name format: '$f'" ) if( $self->_is_warnings_enabled( 'DB::Object' ) );
                next;
            }
            $name = [split( /-/, $name )]->[-1];
            $cache->{ $name } = $table;
        }
        return( $cache );
    }
    # We are given a table object, we store it in the repository. This is mutator mode
    elsif( $self->_is_a( $table => "${base_class}::Tables" ) )
    {
        my $name = $table->name || 
            return( $self->error( "No table name associated with this table object." ) );
        if( $name !~ /^\w+[\w\-\.]*$/ )
        {
            return( $self->error( "The table name '$name' contains illegal characters." ) );
        }
        my $file = $cache_dir->child( "${prefix}-${name}.bin" );
        my $tbl  = $self->Module::Generic::serialise( $table,
            file => $file,
            lock => 1,
            serialiser => $serialiser,
            ( $serialiser eq 'Sereal' ? ( freeze_callbacks => 1 ) : () ),
        ) || return( $self->pass_error );
        return(1);
    }
    # The user has provided a table name, and thus expects the related cloned table object from the cache table repository.
    # This is accessor mode.
    elsif( !ref( $table ) || ( ref( $table ) && $self->_can_overload( $table => '""' ) ) )
    {
        $table = "$table";
        if( $table !~ /^\w+[\w\-\.]*$/ )
        {
            return( $self->error( "The table name '$table' contains illegal characters." ) );
        }
        my $cache_file = $cache_dir->child( "${prefix}-${table}.bin" );
        if( !$cache_file->exists || $cache_file->is_empty || !$cache_file->is_file )
        {
            return( '' );
        }
        my $tbl = $deserialise_from_file->( $cache_file ) || return( '' );
        return( $tbl );
    }
    else
    {
        return( $self->error( "I do not understand the value provided for the 'table' option -> ", $self->_str_val( $table ) ) );
    }
}

sub _cache_this
{
    my $self    = shift( @_ );
    # When this method is accessed by method from package DB::Object::Statement, they CAN NOT
    # implicitly pass the statement string or they would risk to modify the previous stored
    # query object they represent.
    # For instance:
    # $obj->select->join( 'some_table', { 'parameter', 'list' } )->fetchrow_hashref()
    # here the first query is prepared and cached and its resulting object is passed on to join
    # here join will rebuild the query, but will search first if there was one already cached
    # if join passes implictly the statement string, this means it will modify the cached query select()
    # has just previously stored... This is why method such as join must pass explicitly the query string
    my $q           = shift( @_ );
    my $query       = ( ref( $q ) && $q->isa( 'DB::Object::Query' ) ) ? $q->as_string : $q;
    my $dbo         = $self->{dbo} || $self->{database_object} || $self;
    my $base_class  = $self->base_class;
    my $cache       = $dbo->{cache};
    my $bind        = $dbo->{bind};
    my $cache_dir   = $dbo->cache_dir // $self->new_tempdir;
    my $cache_query = $dbo->cache_query;
    my $cache_size  = $dbo->cache_size // 0;
    my $serialiser  = $dbo->serialiser || $DB::Object::SERIALISER || 'Storable';

    my $use_file_cache  = ( defined( $cache_query ) && $cache_query eq 'file' ) ? 1 : 0;

    my( $repo, $sth, $cache_file, $checksum, $cache_key );
    my $cached_sth = '';
    my $host     = $dbo->host;
    my $database = $dbo->database;
    my $table    = ( ref( $q ) && $dbo->_is_a( $q => "${base_class}::Query" ) && $q->table_object ) ? $q->table_object->name : '';

    # Compute cache_file (and cache key) early when caching is enabled and cache_dir exists.
    # Even if cache_query is "file", we also want a small hot cache in memory.
    if( $cache )