view release on metacpan or  search on metacpan

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

};

# NOTE: Storable hooks
# We intentionally do NOT freeze DBI handles (dbh/sth) or back-references (dbo/table_object)
# because they are process-local and cannot be safely restored.
# NOTE: For CBOR and Sereal
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.
    # 2026-01-29: I removed 'query_object' in an effort to reduce memory consumption. Let's see...
    my @props = qw(
        as_string bind cache params query query_object selected_fields
        table tie tie_order _fields _cache_field_names _cache_field_types
    );

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

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

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 ) : {};

    my $sv = CORE::delete( $hash->{_serial_version} ) // 0;
    if( $sv != $DB::Object::SERIALISATION_VERSION )
    {
        require( $EXCEPTION_CLASS );
        die( $EXCEPTION_CLASS->new({
            code    => 409, # Conflict
            message => sprintf(
                "Serialisation version mismatch in %s: expected %d, got %d. Please purge the cache.",
                $class,
                $DB::Object::SERIALISATION_VERSION,
                $sv,
            )
        }) );
    }

    # Since this class is inherited, we also need to load from which we depend, if necessary.
    if( $class ne 'DB::Object::Statement' )
    {
        require DB::Object;
        require DB::Object::Statement;
        my @supported_classes = CORE::values( %$DB::Object::DRIVER2PACK );
        push( @supported_classes, 'DB::Object' );
        my $ok_classes = CORE::join( '|', CORE::map{ CORE::quotemeta( $_ ) } @supported_classes );
        my $base_class = ( $class =~ /^($ok_classes)/ )[0];
        eval( "require $base_class;" );
        if( $@ )
        {
            require( $EXCEPTION_CLASS );
            die( $EXCEPTION_CLASS->new( "Failure to load $base_class: $@" ) );
        }

        # 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_stmt = 0;
        my $has_base = 0;

        foreach my $p ( @$isa_ref )
        {
            # Same as what we can find in modules DB::Object::(Postgres|SQLite|Mysql)::Statement
            $has_stmt = 1 if( CORE::defined( $p ) && $p eq 'DB::Object::Statement' );
            $has_base = 1 if( CORE::defined( $p ) && $p eq $base_class );
        }

        if( !$has_stmt || !$has_base )
        {
            @$isa_ref = ( 'DB::Object::Statement', $base_class );
        }
    }
    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 ) )
        {
            $self->{ $_ } = CORE::delete( $hash->{ $_ } );
        }
        $new = $self;
    }
    else
    {
        $new = CORE::bless( $hash => $class );
    }
    CORE::return( $new );
}

1;
# NOTE: POD
__END__

=encoding utf-8

=head1 NAME

DB::Object::Statement - Statement Object

=head1 SYNOPSIS

    say $sth->as_string;
    $sth->bind_param( 2, $binded_value );
    $sth->bind_param( 2, $binded_value, $binded_type );
    $sth->commit;
    my $dbh = $sth->database_object;
    $sth->distinct;
    say $sth->dump;
    say $sth->execute;
    $sth->execute( $val1, $val2 ) || die( $sth->error );
    # explicitly specify types
    # Here in this mixed example, $val1 and $val3 have known types
    $tbl->where( $dbh->AND(
        $tbl->fo->name == '?',
        $tbl->fo->city == '?',
        '?' == $dbh->ANY( $tbl->fo->alias )
    ) );
    my $sth = $tbl->select || die( $tbl->error );
    $sth->execute( $val1, $val2, { $val3 => 'varchar' } ) || die( $sth->error );
    my $ref = $sth->fetchall_arrayref;
    my $val = $sth->fetchcol;
    my %hash = $sth->fetchhash;
    my @values = $sth->fetchrow;
    my $ref = $sth->fetchrow_hashref;
    my $obj = $sth->fetchrow_object;
    $sth->finish;
    $sth->ignore;
    $sth->join( $join_condition );
    my $qo = $sth->query_object;
    $sth->rollback;
    my $rows = $sth->rows;
    my $dbi_sth = $sth->sth;
    my $tbl = $sth->table_object;

=head1 VERSION

v0.9.0

=head1 DESCRIPTION

This is the statement object package from which other driver specific packages inherit from.

=head1 METHODS

=head2 as_string