view release on metacpan or  search on metacpan

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

    }
    else
    {
        $where = $self->{ $prop };
    }

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

# NOTE: For CBOR and Sereal
sub FREEZE
{
    my $self = CORE::shift( @_ );
    my $serialiser = CORE::shift( @_ ) // '';
    my $class = CORE::ref( $self );
    my $hash  = {};
    my @keys  = grep{ !/^binded_/ } @{$self->{query_reset_core_keys}};
    push( @keys, qw( elements table_object ) );
    foreach my $prop ( @keys )
    {
        if( CORE::exists( $self->{ $prop } ) &&
            defined( $self->{ $prop } ) &&
            # Because we cannot reliably freeze code reference, and we do not usually need to.
            CORE::ref( $self->{ $prop } ) ne 'CODE' )
        {
            $hash->{ $prop } = $self->{ $prop };
        }
    }

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

sub STORABLE_thaw_post_processing
{
    my $obj   = shift( @_ );
    my @keys  = %$obj;
    my $class = ref( $obj );
    my $hash  = {};
    @$hash{ @keys } = @$obj{ @keys };
    my $self = bless( $hash => $class );
    return( $self );
}

# 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 ) : {};
    # Since this class is inherited, we also need to load from which we depend, if necessary.
    if( $class ne 'DB::Object::Query' )
    {
        require DB::Object::Query;

        # If inheritance is still missing (or incomplete) for any reason, repair it explicitly.
        no strict 'refs';

        my $stash = \%{"${class}\::"};
        my $isa_ref;
        # We check if the 'ISA' symbol exists in the stash and its ARRAY slot is defined
        if( exists( $stash->{ISA} ) &&
            defined( *{"${class}\::ISA"}{ARRAY} ) )
        {
            $isa_ref = *{"${class}\::ISA"}{ARRAY};
        }
        else
        {
            # # Force creation of @ISA array slot
            # @{"${class}::ISA"} = ();
            # $isa_ref = *{"${class}::ISA"}{ARRAY};
            # But I want it to die, so this can be dealt with, and not swept under the rug.
            die( "Unable to find the \@ISA value in $class. The package contains the following stashes:\n", $self->Module::Generic::dump( $stash ) );
        }
        my $has_qo  = 0;

        foreach my $p ( @$isa_ref )
        {
            $has_qo = 1 if( CORE::defined( $p ) && $p eq 'DB::Object::Query' );
        }

        if( !$has_qo )
        {
            # Same as what we can find in modules DB::Object::(Postgres|SQLite|Mysql)::Query
            @$isa_ref = ( 'DB::Object::Query' );
        }
    }
    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 ) )
        {
            # No, this was a bad idea, because the instance property, such as 'where' bears the same name as the method
            # So, we would be calling the method 'where', but there is no table object or database object...
            # if( my $ref = $self->can( $_ ) )
            # {
            #     $ref->( $self, CORE::delete( $hash->{ $_ } ) );
            # }
            $self->{ $_ } = CORE::delete( $hash->{ $_ } );
        }
        $new = CORE::bless( $self => $class );
    }
    else
    {
        $new = CORE::bless( $hash => $class );
    }
    unless( $new->{elements} )
    {
        $new->{elements} = $new->new_elements;
    }
    CORE::return( $new );
}

1;
# NOTE: POD
__END__

=encoding utf-8

=head1 NAME

DB::Object::Query - Query Object

=head1 SYNOPSIS

    my $q = DB::Object::Query->new;

=head1 VERSION

    v0.10.0

=head1 DESCRIPTION

This is the base class for this L<DB::Object> query formatter.

=head1 METHODS

=head2 alias

Sets or gets an hash of column name to alias.

=head2 as_string

Returns the formatted query as a string.

=head2 attach

    $q->attach( $db_object );

Provided with a L<DB::Object>, or one of its inheriting classes, and this will attach that database object to this query object.

It returns the current query object upon success, or upon error, it set an error an returns an empty list in list context, or C<undef> in scalar context.

=head2 avoid

Takes a list or array reference of column to avoid in the next query. This returns a L<Module::Generic::Array> object.

=head2 binded

Takes a list or array reference of values to bind in the next query in L<DB::Object::Statement/execute>. This returns a L<Module::Generic::Array> object.

=head2 binded_group

This returns the values to bind for the C<group> clause of the query. This returns a L<Module::Generic::Array> object.