view release on metacpan or  search on metacpan

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

# -*- perl -*-
##----------------------------------------------------------------------------
## Database Object Interface - ~/lib/DB/Object.pm
## Version v1.10.0
## Copyright(c) 2026 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2017/07/19
## Modified 2026/03/27
## All rights reserved
## 
## 
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
## This is the subclassable module for driver specific ones.
package DB::Object;
BEGIN
{
    require 5.16.0;
    use strict;
    use warnings;
    use warnings::register;
    use parent qw( Module::Generic DBI );
    use vars qw(
        $VERSION $AUTOLOAD $CACHE_DIR $CACHE_SIZE $DRIVER2PACK
        $ERROR $DEBUG $MOD_PERL $USE_BIND $USE_CACHE $PLACEHOLDER_REGEXP $SERIALISER
        $SERIALISATION_VERSION $EXCEPTION_CLASS
    );
    use Regexp::Common;
    use Scalar::Util qw( blessed weaken );
    use DB::Object::Cache::Tables;
    use DBI;
    use JSON;
    use Module::Generic::File qw( sys_tmpdir );
    use Module::Generic::Global qw( :const );
    use POSIX ();
    use Wanted;
    our $PLACEHOLDER_REGEXP = qr/(?<![?\w])\?(?![?\w])/;
    our $EXCEPTION_CLASS    = 'DB::Object::Exception';
    our $VERSION = 'v1.10.0';
};

use strict;
use warnings;

our $DEBUG         = 0;
# A global setting variable. This is not changed dynamically, and can be set by the user
our $CACHE_SIZE    = 10;
our $USE_BIND      = 0;
our $USE_CACHE     = 0;
our $MOD_PERL      = 0;
# A global variable that can be set by the user to serve as a default value
our $CACHE_DIR     = '';
if( $INC{ 'Apache/DBI.pm' } && 
    substr( $ENV{GATEWAY_INTERFACE} || '', 0, 8 ) eq 'CGI-Perl' )
{
    $MOD_PERL++;
}
# Global constant
our $DRIVER2PACK = 
{
    mysql  => 'DB::Object::Mysql',
    Pg     => 'DB::Object::Postgres',
    SQLite => 'DB::Object::SQLite',
};
# Default value
our $SERIALISER = 'Storable';
our $SERIALISATION_VERSION = 1;

sub new
{
    my $that  = shift( @_ );
    my $class = ref( $that ) || $that;
    my $self  = {};
    bless( $self, $class );
    return( $self->init( @_ ) );
}

sub init
{
    my $self = shift( @_ );
    $self->{cache_connections}  = 1;
    $self->{cache_dir}          = sys_tmpdir();
    # Cache query on file ? Only works if 'cache_dir' is set too.
    $self->{cache_query}        = 0;
    $self->{cache_size}         = $CACHE_SIZE;
    $self->{cache_table}        = 0;
    $self->{driver}             = '';
    # Auto-decode json data into perl hash
    $self->{auto_decode_json}   = 1;

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

    my $args = ( scalar( @_ ) == 1 && ref( $_[0] ) eq 'ARRAY' ) ? [ @{$_[0]} ] : [ @_ ];
    return( $class->new(
        debug => $self->debug,
        query_object => $q,
        value => $args,
    ) );
}

sub _param2hash
{
    my $self = shift( @_ );
    my $opts = {};
    if( scalar( @_ ) )
    {
        if( $self->_is_hash( $_[0] => 'strict' ) )
        {
            $opts = shift( @_ );
        }
        elsif( !( scalar( @_ ) % 2 ) )
        {
            $opts = { @_ };
        }
        else
        {
            return( $self->error( "Uneven number of parameters. I was expecting a hash or a hash reference." ) );
        }
    }
    return( $opts );
}

sub _placeholder_regexp { return( $PLACEHOLDER_REGEXP ) }

# NOTE: _query_object_add needs to reside in DB::Object (called indirectly by no_bind)
sub _query_object_add
{
    my $self = shift( @_ );
    my $obj  = shift( @_ ) || return( $self->error( "No query object was provided" ) );
    my $base = $self->base_class;
    return( $self->error( "Object provided is not a query object class" ) ) if( ref( $obj ) !~ /^${base}\::Query$/ );
    $self->query_object( $obj );
    return( $obj );
}

# NOTE: _query_object_create needs to reside in DB::Object (called indirectly by no_bind)
sub _query_object_create
{
    my $self = shift( @_ );
    my $base = $self->base_class;
    my $query_class = "${base}::Query";
    $self->_load_class( $query_class ) ||
        return( $self->error( "Unable to load Query builder module $query_class: ", $self->error->message ) );
    my $o = $query_class->new;
    $o->debug( $self->debug );
    $o->enhance( $self->{enhance} ) if( CORE::length( $self->{enhance} ) );
    if( $self->isa( 'DB::Object::Tables' ) )
    {
        $o->table_object( $self ) || return( $self->pass_error( $o->error ) );
        # Weaken the back-reference from the Query object to its owning Table to break
        # the circular reference cycle (Table -> query_object -> Query -> table_object -> Table)
        # that prevents Perl's garbage collector from reclaiming old Query objects.
        weaken( $o->{table_object} );
        $o->database_object( $self->database_object ) || return( $self->pass_error( $o->error ) );
        # Also weaken the database_object reference - the dbo is a long-lived singleton
        # and does not own Query objects, so a weak reference is safe here.
        weaken( $o->{database_object} );
        # Set the table alias if any has been set
        if( my $table_alias = $self->as )
        {
            $o->table_alias( $table_alias ) if( defined( $table_alias ) );
        }
    }
    elsif( $self->isa( 'DB::Object' ) )
    {
        $o->database_object( $self ) || return( $self->pass_error( $o->error ) );
    }
    return( $o );
}

# NOTE: _query_object_current needs to reside in DB::Object (called indirectly by no_bind)
sub _query_object_current { return( shift->{query_object} ); }

# NOTE: _query_object_get_or_create needs to reside in DB::Object (called indirectly by no_bind)
# If the stack is empty, we create an object, add it and resend it
sub _query_object_get_or_create
{
    my $self = shift( @_ );
    my $obj  = $self->query_object;
    if( $obj && $obj->dirty )
    {
        $self->_query_object_remove( $obj );
        undef( $obj );
    }
    if( !$obj )
    {
        $obj = $self->_query_object_create || return( $self->pass_error );
        $self->query_object( $obj );
    }
    return( $obj );
}

# NOTE: _query_object_remove needs to reside in DB::Object (called indirectly by no_bind)
sub _query_object_remove
{
    my $self = shift( @_ );
    my $obj  = shift( @_ ) || return( $self->error( "No query object was provided" ) );
    my $base = $self->base_class;
    # return( $self->error( "Object provided is not a query object class" ) ) if( ref( $obj ) !~ /^${base}\::Query$/ );
    return( $self->error( "Object provided is not a query object class" ) ) if( !$obj->isa( "DB::Object::Query" ) );
    $self->query_object( undef );
    return( $obj );
}

# NOTE: A query object can be owned by a table object, but also by a database object, such as when instantiating operators like ALL, AND, OR
sub _reset_query
{
    my $self = shift( @_ );

    if( !$self->{query_reset} )
    {
        $self->{query_reset} = 1;
        $self->{enhance} = 1;

        my $obj = $self->query_object;

        # If current query object is dirty, detach it right away.