view release on metacpan or  search on metacpan

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

# -*- perl -*-
##----------------------------------------------------------------------------
## Database Object Interface - ~/lib/DB/Object/Query.pm
## Version v0.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.
##----------------------------------------------------------------------------
package DB::Object::Query;
BEGIN
{
    use strict;
    use warnings;
    use parent qw( DB::Object );
    use vars qw( $VERSION $DEBUG $EXCEPTION_CLASS );
    use DB::Object::Query::Clause;
    use DB::Object::Query::Elements;
    use DB::Object::Query::Element;
    use Scalar::Util qw( weaken );
    use Wanted;
    our $DEBUG           = 0;
    our $EXCEPTION_CLASS = $DB::Object::EXCEPTION_CLASS;
    our $VERSION = 'v0.10.0';
};

use strict;
use warnings;

sub init
{
    my $self = shift( @_ );
    $self->{alias}          = {} unless( CORE::exists( $self->{alias} ) );
    $self->{avoid}          = [] unless( CORE::exists( $self->{avoid} ) );
    $self->{binded}         = [] unless( CORE::exists( $self->{binded} ) );
    # $self->{binded_group}   = [] unless( CORE::exists( $self->{binded_group} ) );
    # $self->{binded_limit}   = [] unless( CORE::exists( $self->{binded_limit} ) );
    # $self->{binded_order}   = [] unless( CORE::exists( $self->{binded_order} ) );
    $self->{binded_types}   = [] unless( CORE::exists( $self->{binded_types} ) );
    $self->{binded_values}  = [] unless( CORE::exists( $self->{binded_values} ) );
    $self->{binded_where}   = [] unless( CORE::exists( $self->{binded_where} ) );
    $self->{dirty}          = 0;
    $self->{elements}       = undef unless( CORE::exists( $self->{elements} ) );
    $self->{enhance}        = 0 unless( CORE::exists( $self->{enhance} ) );
    $self->{from_table}     = [] unless( CORE::exists( $self->{from_table} ) );
    $self->{from_unixtime}  = [] unless( CORE::exists( $self->{from_unixtime} ) );
    $self->{group_by}       = '' unless( CORE::exists( $self->{group_by} ) );
    $self->{having}         = '' unless( CORE::exists( $self->{having} ) );
    $self->{join_fields}    = '' unless( CORE::exists( $self->{join_fields} ) );
    $self->{left_join}      = {} unless( CORE::exists( $self->{left_join} ) );
    $self->{limit}          = '' unless( CORE::exists( $self->{limit} ) );
    $self->{local}          = {} unless( CORE::exists( $self->{local} ) );
    $self->{order_by}       = '' unless( CORE::exists( $self->{order_by} ) );
    $self->{prepare_options}= {} unless( CORE::exists( $self->{prepare_options} ) );
    $self->{query_values}   = undef unless( CORE::exists( $self->{query_values} ) );
    $self->{reverse}        = '' unless( CORE::exists( $self->{reverse} ) );
    $self->{sorted}         = [] unless( CORE::exists( $self->{sorted} ) );
    $self->{table_alias}    = '' unless( CORE::exists( $self->{table_alias} ) );
    $self->{table_object}   = '' unless( CORE::exists( $self->{table_object} ) );
    $self->{unix_timestamp} = [] unless( CORE::exists( $self->{unix_timestamp} ) );
    $self->{where}          = '' unless( CORE::exists( $self->{where} ) );
    $self->{_init_strict_use_sub} = 1;
    $self->{_exception_class}     = $EXCEPTION_CLASS;
    $self->SUPER::init( @_ ) || return( $self->pass_error );
    $self->{constant}       = {};
    $self->{query}          = '';
    $self->{query_reset}    = 0;
    $self->{query_reset_core_keys} = [qw(
        alias binded binded_group binded_limit binded_order binded_types binded_values
        binded_where dirty from_unixtime group_by having limit local order_by reverse
        sorted table_alias unix_timestamp where
        from_table join_fields join_tables left_join prepare_options query_values constant
        query selected_fields tie_order
    )];
    $self->{selected_fields} = '';
    $self->{table_object}   = '';
    $self->{tie_order}      = [];
    unless( $self->{elements} )
    {
        $self->{elements} = $self->new_elements;

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

sub limit
{
    my $self  = shift( @_ );
    my $limit = $self->{limit};
    if( @_ )
    {
        # Returns a DB::Object::Query::Clause
        $limit = $self->_process_limit( @_ ) ||
            return( $self->pass_error );
        if( CORE::length( $limit->metadata->limit // '' ) )
        {
            $limit->generic( CORE::length( $limit->metadata->offset // '' ) ? 'LIMIT ?, ?' : 'LIMIT ?' );
            # %s works for integer, and also for numbered placeholders like $1 or ?1, or regular placeholder like ?
            $limit->value(
                CORE::length( $limit->metadata->offset // '' )
                    ?  sprintf( "LIMIT %s, %s", $limit->metadata->offset, $limit->metadata->limit )
                    : sprintf( "LIMIT %s", $limit->metadata->limit )
            );
        }
    }

    if( !$limit && want( 'OBJECT' ) )
    {
        return( $self->new_null( type => 'object' ) );
    }
    return( $limit );
}

sub local
{
    my $self = shift( @_ );
    $self->{local} ||= {};
    my $local = $self->{local};
    if( @_ )
    {
        my $data = $self->_get_args_as_hash( @_ );
        my $str  = '';
        if( scalar( keys( %$data ) ) )
        {
            my @keys = keys( %$data );
            @$local{ @keys } = @$data{ @keys };
        }
    }
    return( wantarray() ? () : undef() ) if( !$local || !%$local );
    return( %$local ) if( wantarray() );
    my $str = join( ', ', map{ "\@${_} = '" . $local->{ $_ } . "'" } keys( %$local ) );
    # return( "SET $str" );
    return( $str );
}

sub new_clause
{
    my $self = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    $opts->{debug} = $self->debug if( !exists( $opts->{debug} ) );
    $opts->{query_object} = $self;
    my $o = DB::Object::Query::Clause->new( %$opts ) ||
        return( $self->error( "Unable to create a DB::Object::Query::Clause object: ", DB::Object::Query::Clause->error ) );
    # Weaken the back-reference to the query object to prevent circular reference memory leaks.
    weaken( $o->{query_object} ) if( $o->{query_object} );
    return( $o );
}

sub new_element
{
    my $self = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    $opts->{debug} = $self->debug if( !exists( $opts->{debug} ) );
    $opts->{query_object} = $self;
    my $elem = DB::Object::Query::Element->new( %$opts ) ||
        return( $self->pass_error( DB::Object::Query::Element->error ) );
    # Weaken the back-reference to the query object to prevent circular reference memory leaks.
    weaken( $elem->{query_object} ) if( $elem->{query_object} );
    return( $elem );
}

sub new_elements
{
    my $self = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    $opts->{debug} = $self->debug if( !exists( $opts->{debug} ) );
    $opts->{query_object} = $self;
    my $e = DB::Object::Query::Elements->new( %$opts ) ||
        return( $self->pass_error( DB::Object::Query::Elements->error ) );
    # Weaken the back-reference to the query object to prevent circular reference memory leaks.
    weaken( $e->{query_object} ) if( $e->{query_object} );
    return( $e );
}

sub order { return( shift->_group_order( 'order', 'order_by', @_ ) ); }

sub pass_error
{
    my $self = shift( @_ );

    # Propagating an error also taints this query object.
    $self->{dirty} = 1 if( ref( $self ) );

    return( $self->SUPER::pass_error( @_ ) );
}

sub prepare_options { return( shift->_set_get_hash_as_mix_object( 'prepare_options', @_ ) ); }

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

sub query_reset { return( shift->_set_get_boolean( 'query_reset', @_ ) ); }

sub query_reset_core_keys { return( shift->_set_get_array_as_object( 'query_reset_core_keys', @_ ) ); }

sub query_reset_keys { return( shift->_set_get_array_as_object( 'query_reset_keys', @_ ) ); }

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

sub query_values { return( shift->_set_get_scalar_as_object( 'query_values', @_ ) ); }

sub replace { return( shift->error( "The replace sql query is not supported by this driver." ) ); }

sub reset
{
    my $self = shift( @_ );
    if( !$self->{query_reset} )
    {
        my $core_keys = $self->query_reset_core_keys;
        my $keys      = $self->query_reset_keys;
        # Make sure the driver's list of keys for query reset is complete by merging this base class keys with the diver's one
        unless( $core_keys == $keys )
        {
            my $new_keys = $keys->merge( $core_keys )->unique->sort;
            $keys = $self->query_reset_keys( $new_keys );
        }
        CORE::delete( @$self{ @$keys } );
        # elements is not in query_reset_core_keys because CORE::delete would leave it undef
        # and there is no re-init pass after reset(). We clear it explicitly here instead,
        # so that _save_bind() on each fresh select() starts from an empty element stack.
        $self->{elements} = $self->new_elements;
        $self->{query_reset}++;
        $self->{enhance} = 1;
    }
    return( $self );
}

sub reset_bind
{
    my $self = shift( @_ );
    my @f = qw( binded binded_group binded_limit binded_order binded_types binded_where );
    foreach my $field ( @f )