view release on metacpan or  search on metacpan

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

##----------------------------------------------------------------------------
## Database Object Interface - ~/lib/DB/Object/Fields/Field.pm
## Version v1.4.0
## Copyright(c) 2026 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <jack@deguest.jp>
## Created 2020/01/01
## 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::Fields::Field;
BEGIN
{
    use strict;
    use warnings;
    use common::sense;
    use parent qw( Module::Generic );
    use vars qw( $VERSION $FIELD_NAMES $EXCEPTION_CLASS );
    use DB::Object::Fields::Overloaded;
    use Scalar::Util qw( weaken );
    use Module::Generic::Array;
    use overload (
        '""'    => 'as_string',
        'bool'  => sub{1},
        '+'     => sub{ &_op_overload( @_, '+' ) },
        '-'     => sub{ &_op_overload( @_, '-' ) },
        '*'     => sub{ &_op_overload( @_, '*' ) },
        '/'     => sub{ &_op_overload( @_, '/' ) },
        '%'     => sub{ &_op_overload( @_, '%' ) },
        '<'     => sub{ &_op_overload( @_, '<' ) },
        '>'     => sub{ &_op_overload( @_, '>' ) },
        '<='    => sub{ &_op_overload( @_, '<=' ) },
        '>='    => sub{ &_op_overload( @_, '>=' ) },
        # In most SQL driver, '<>' is more portable tan '!='
        '!='    => sub{ &_op_overload( @_, '<>' ) },
        '<<'    => sub{ &_op_overload( @_, '<<' ) },
        '>>'    => sub{ &_op_overload( @_, '>>' ) },
        'lt'    => sub{ &_op_overload( @_, '<' ) },
        'gt'    => sub{ &_op_overload( @_, '>' ) },
        'le'    => sub{ &_op_overload( @_, '<=' ) },
        'ge'    => sub{ &_op_overload( @_, '>=' ) },
        'ne'    => sub{ &_op_overload( @_, '<>' ) },
        '&'     => sub{ &_op_overload( @_, '&' ) },
        '^'     => sub{ &_op_overload( @_, '^' ) },
        '|'     => sub{ &_op_overload( @_, '|' ) },
        '=='    => sub{ &_op_overload( @_, '=' ) },
        'eq'    => sub{ &_op_overload( @_, 'IS' ) },
        # Full Text Search operator
        '~~'    => sub{ &_op_overload( @_, '@@' ) },
        fallback => 1,
    );
    use Wanted;
    our $VERSION = 'v1.4.0';
    our $FIELD_NAMES = [qw(
        check_name comment datatype default foreign_name index_name is_array is_check
        is_foreign is_nullable is_primary is_unique name pos prefixed size type
    )];
    our $EXCEPTION_CLASS = $DB::Object::EXCEPTION_CLASS;
};

use strict;
use warnings;

sub init
{
    my $self = shift( @_ );
    $self->{check_name}     = undef;
    $self->{comment}        = undef;
    $self->{datatype}       = undef;
    $self->{default}        = undef;
    $self->{foreign_name}   = undef;
    $self->{index_name}     = undef;
    $self->{is_array}       = undef;
    $self->{is_check}       = undef;
    $self->{is_foreign}     = undef;
    $self->{is_nullable}    = undef;
    $self->{is_primary}     = undef;
    $self->{is_unique}      = undef;
    $self->{name}           = undef;
    $self->{pos}            = undef;

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

    my $next_field;
    foreach my $f ( sort{ $fields->{ $a } <=> $fields->{ $b } } keys( %$fields ) )
    {
        if( $fields->{ $f } == $pos )
        {
            $next_field = $f;
            CORE::last;
        }
    }
    return if( !defined( $next_field ) );
    my $o = $self->table_object->fields_object->_initiate_field_object( $next_field ) ||
    return( $self->pass_error( $self->table_object->fields_object->error ) );
    return( $o );
}

# Ref:
# <https://www.postgresql.org/docs/10/functions-comparison.html>
# <https://www.postgresql.org/docs/10/functions-math.html>
# <https://dev.mysql.com/doc/refman/5.7/en/comparison-operators.html>
# <https://sqlite.org/lang_expr.html>
sub _op_overload
{
    my( $self, $val, $swap, $op ) = @_;
    if( $self->_is_a( $val => [qw( DB::Object::IN DB::Object::LIKE )] ) )
    {
        return( $val->_opt_overload( $self, 1, $op ) );
    }

    my $field = $self->name;
    my $map =
    {
        '!=' => '<>',
        'lt' => '<',
        'gt' => '>',
        'le' => '<=',
        'ge' => '>=',
        # '=' works for all types, but IS does not work with everything.
        # For example:
        # select * from ip_table where ip_addr IS inet '192.168.2.12' OR inet '192.168.2.12' << ip_addr
        # does not work, but
        # select * from ip_table where ip_addr = inet '192.168.2.12' OR inet '192.168.2.12' << ip_addr
        # works better
        '==' => '=',
    };
    $op = $map->{ $op } if( exists( $map->{ $op } ) );
    my $dbo = $self->database_object;
    my $qo = $self->query_object;
    my $placeholder_re = $dbo->_placeholder_regexp;
    my $const = $self->datatype->constant;
    # When the RHS is NULL, SQL requires IS NULL / IS NOT NULL - never = NULL or <> NULL,
    # as those predicates always evaluate to NULL (never TRUE) per the SQL standard.
    if( !ref( $val ) && uc( $val ) eq 'NULL' )
    {
        my $null_expr = $op eq '<>' ? "${field} IS NOT NULL" : "${field} IS NULL";
        my $null_overloaded = DB::Object::Fields::Overloaded->new(
            expression   => $null_expr,
            field        => $self,
            query_object => $qo,
            debug        => $self->debug,
        );
        weaken( $null_overloaded->{query_object} ) if( $null_overloaded && $null_overloaded->{query_object} );
        return( $null_overloaded );
    }
    # If the value specified in the operation is a placeholder, or a field object or a statement object, we do not want to quote process it
    unless( $val =~ /$placeholder_re/ || 
            ( $self->_is_object( $val ) && 
              (
                $val->isa( 'DB::Object::Fields::Field' ) ||
                $val->isa( 'DB::Object::Statement' )
              )
            ) || 
            $dbo->placeholder->has( \$val ) ||
            $self->_is_scalar( $val ) ||
            uc( $val ) eq 'NULL' )
    {
        $val = $dbo->quote( $val, $const ) if( $dbo );
    }

    my $types;
    # If the value is a statement object, stringify it, surround it with parenthesis and use it
    if( $self->_is_a( $val, 'DB::Object::Statement' ) )
    {
        $qo->elements->merge( $val->query_object->elements );
        $val = '(' . $val->as_string . ')';
    }
    elsif( $dbo->placeholder->has( $self->_is_scalar( $val ) ? $val : \$val ) )
    {
        $types = $dbo->placeholder->replace( $self->_is_scalar( $val ) ? $val : \$val );
    }
    # A placeholder (pure: ?) or embedded (e.g. UPPER(?), COALESCE(?,?)):
    # count the number of placeholders in $val and register one empty type per bind slot.
    elsif( $val =~ /$placeholder_re/ )
    {
        my @matches = ( $val =~ /$placeholder_re/g );
        $types = Module::Generic::Array->new( [ ( '' ) x scalar( @matches ) ] );
    }
    elsif( $self->_is_scalar( $val ) )
    {
        $val = $$val;
    }
#     return( DB::Object::Fields::Overloaded->new(
#         expression => 
#             (
#                 $swap
#                     ? "${val} ${op} ${field}" 
#                     : "${field} ${op} ${val}"
#             ),
#         field => $self,
#         # binded => ( $val =~ /^$placeholder_re$/ || $types ) ? 1 : 0,
#         ( $val =~ /^$placeholder_re$/ ? ( placeholder => $val ) : () ),
#         type => $self->type,
#         # query_object => $self->query_object,
#         debug => $self->debug,
#         ( $val !~ /^$placeholder_re$/ ? ( value => $val ) : () ),
#         # binded_offset => ( $val =~ /^$placeholder_re$/ && defined( $+{offset} ) ) ? ( $+{offset} - 1 ) : undef,
#         # types => $types,
#     ) );
    # Capture the placeholder before calling new() - $1 can be clobbered by any
    # subsequent regex match inside the argument list evaluation or inside new() itself.
    my $captured_placeholder = ( $val =~ /($placeholder_re)/ ) ? $1 : undef;
    my $over = DB::Object::Fields::Overloaded->new(
        expression => 
            (
                $swap
                    ? "${val} ${op} ${field}" 
                    : "${field} ${op} ${val}"
            ),
        field        => $self,
        # query_object must be initialised before placeholder, because the placeholder
        # setter calls $self->query_object->database_object->_placeholder_regexp
        query_object => $qo,
        debug        => $self->debug,
        ( defined( $captured_placeholder ) ? ( placeholder => $captured_placeholder ) : () ),
        # Actually type() will return us the actual data type, not the driver constant
        # type => $self->type,
        ( defined( $const ) ? ( type => $const ) : () ),
        ( !defined( $captured_placeholder ) ? ( value => $val ) : () ),
        # binded_offset => ( defined( $captured_placeholder ) && defined( $+{index} ) ) ? ( $+{index} - 1 ) : undef,
        # types => $types,
    );
    weaken( $over->{query_object} ) if( $over && $over->{query_object} );
    return( $over );
}

sub FREEZE
{
    my $self       = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class      = CORE::ref( $self );

    # We keep a strict allow-list to avoid accidentally freezing DBI handles or other
    # process-local state.
    my @props = grep( $_ ne 'datatype', @{$self->{_fields}} );

    my $hash = {};
    foreach my $prop ( @props )
    {
        if( CORE::exists( $self->{ $prop } ) &&
            defined( $self->{ $prop } ) &&
            CORE::ref( $self->{ $prop } ) ne 'CODE' )
        {
            $hash->{ $prop } = $self->{ $prop };
        }
    }

    my $datatype = $self->datatype;
    my $dtype_ref = {};
    if( $datatype )
    {
        $dtype_ref->{alias}     = $datatype->alias;
        $dtype_ref->{constant}  = $datatype->constant;
        $dtype_ref->{name}      = $datatype->name;
        $dtype_ref->{re}        = $datatype->re;
        $dtype_ref->{type}      = $datatype->type;
    }
    $hash->{datatype} = $dtype_ref;

    # Return an array reference rather than a list so this works with Sereal and CBOR.
    # 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, $hash] );
        }
    }

    # But Storable wants 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( @_ ) ); }

sub THAW
{
    # STORABLE_thaw would issue $cloning as the 2nd argument, while CBOR would issue