DB-Object

 view release on metacpan or  search on metacpan

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

sub ALL { return( shift->_operator_object_create( 'DB::Object::ALL', @_ ) ); }

sub AND { return( shift->_operator_object_create( 'DB::Object::AND', @_ ) ); }

sub ANY { return( shift->_operator_object_create( 'DB::Object::ANY', @_ ) ); }

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

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

sub attribute($;$@)
{
    my $self = shift( @_ );
    # $h->{AttributeName} = ...;    # set/write
    # ... = $h->{AttributeName};    # get/read
    # 1 means that the attribute may be modified
    # 0 mneas that the attribute may only be read
    my $name  = shift( @_ ) if( @_ == 1 );
    my %arg   = ( @_ );
    my %attr =
    (

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

            if( exists( $attr{ $name } ) && 
                defined( $value ) && 
                $attr{ $name } )
            {
                $self->{dbh}->{ $name } = $value;
            }
        }
    }
}

sub available_drivers(@)
{
    my $self = shift( @_ );
    my $class = ref( $self ) || $self;
    # @ary = DBI->available_drivers( $quiet );
    return( $class->SUPER::available_drivers( 1 ) );
}

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

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

    my $self = shift( @_ );
    my $name = shift( @_ ) || return( $self->error( "No name for this query cache was provided." ) );
    my $sth  = shift( @_ ) || return( $self->error( "No statement handler was provided." ) );
    return( $QUERIES_CACHE->{ $name } = $sth );
}

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

sub cache_tables { return( shift->_set_get_object( 'cache_tables', 'DB::Object::Cache::Tables', @_ ) ); }

sub check_driver()
{
    my $self   = shift( @_ );
    my $driver = shift( @_ ) || return( $self->error( "No SQL driver provided to check" ) );
    my $ok     = undef();
    local $_;
    my @drivers = $self->available_drivers();
    foreach( @drivers ) 
    {
        if( m/$driver/s )
        {

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

    @$ref{ @$keys } = @$opts{ @$keys };
    return(0) if( !scalar( keys( %$ref ) ) );
    $self->insert( $ref );
    return(1);
}

sub create_db { return( shift->error( "The driver has not implemented the create database method create_db." ) ); }

sub create_table { return( shift->error( "The driver has not implemented the create table method create_table." ) ); }

sub data_sources($;\%)
{
    my $self  = shift( @_ );
    my $class = ref( $self ) || $self;
    my $opt;
    $opt = shift( @_ ) if( @_ );
    my $driver = $self->{driver} || return( $self->error( "No driver to to use to check for data sources." ) );
    return( $class->SUPER::data_sources( $driver, $opt ) );
}

sub data_type

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

# Returns an hash of SQL constant name to its value
sub datatypes
{
    my $self = shift( @_ );
    my $dict = $self->datatype_dict || return( $self->pass_error );
    my $ref = +{ map{ $_ => $dict->{ $_ }->{constant} } keys( %$dict ) };
    return( $ref );
}

sub disconnect($)
{
    my $self = shift( @_ );
    # my( $pack, $file, $line ) = caller();
    # print( STDERR "disconnect() called from package '$pack' in file '$file' at line '$line'.\n" );
    my $rc = $self->{dbh}->disconnect( @_ );
    return( $rc );
}

sub do($;$@)
{
    my $self = shift( @_ );
    # $rc  = $dbh->do( $statement )           || die( $dbh->errstr );
    # $rc  = $dbh->do( $statement, \%attr )   || die( $dbh->errstr );
    # $rv  = $dbh->do( $statement, \%attr, @bind_values ) || ...
    # my( $rows_deleted ) = $dbh->do( 
    # q{
    #     DELETE FROM table WHERE status = ?
    # }, undef(), 'DONE' ) || die( $dbh->errstr );
    my $query     = shift( @_ );

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

sub driver { return( shift->_set_get( 'driver' ) ); }

sub enhance
{
    my $self = shift( @_ );
    my $prev = $self->{enhance};
    $self->{enhance} = shift( @_ ) if( @_ );
    return( $prev );
}

sub err(@)
{
    my $self = shift( @_ );
    # $rv = $h->err;
    if( defined( $self->{sth} ) )
    {
        return( $self->{sth}->err() );
    }
    elsif( $self->{dbh} )
    {
        return( $self->{dbh}->err() );

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

sub errno
{
    goto( &err );
}

sub errmesg
{
    goto( &errstr );
}

sub errstr(@)
{
    my $self = shift( @_ );
    if( !ref( $self ) )
    {
        return( $DBI::errstr || $DB_ERRSTR );
    }
    elsif( defined( $self->{sth} ) && $self->{sth}->errstr() )
    {
        return( $self->{sth}->errstr() );
    }

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

        my $sth = $dbh->prepare( $query ) ||
        return( $self->error( "Unable to set options '", CORE::join( ', ', @query ), "'" ) );
        $sth->execute();
        $sth->finish();
        return( $self );
    }
}

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

sub ping(@)
{
    #return( shift->{ 'dbh' }->ping );
    my $self = shift( @_ );
    return( $self->{dbh}->ping );
}

sub ping_select(@)
{
    my $self = shift( @_ );
    # $rc = $dbh->ping;
    # Some new ping method replacement.... See Apache::DBI
    # my( $dbh ) = @_;
    my $ret = 0;
    eval 
    {
        local( $SIG{__DIE__}  ) = sub{ return( 0 ); };
        local( $SIG{__WARN__} ) = sub{ return( 0 ); };

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

    my $opts = $self->_get_args_as_hash( @_ );
    $opts->{debug} = $self->debug if( !exists( $opts->{debug} ) );
    my $obj = DB::Object::Placeholder->new( %$opts ) ||
        return( $self->pass_error( DB::Object::Placeholder->error ) );
    return( $obj );
}

sub port { return( shift->_set_get_number( 'port', @_ ) ); }

# Gateway to DB::Object::Statement
sub prepare($;$)
{
    my $self    = shift( @_ );
    my $class   = ref( $self ) || $self;
    my $query   = shift( @_ );
    my $opt_ref = shift( @_ ) || undef();
    my $base_class = $self->base_class;
    my $q;
    if( $self->_is_a( $query => 'DB::Object::Query' ) )
    {
        $q = $query;

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

        return( $self->_make_sth( "${base_class}::Statement", $data ) );
    }
    else
    {
        my $err = $@ || $self->{dbh}->errstr() || 'Unknown error while cache preparing query.';
        $self->{query} = $query;
        return( $self->error( $err ) );
    }
}

sub query($$)
{
    my $self = shift( @_ );
    my $sth  = $self->prepare( @_ );
    my $result;
    if( $sth && !( $result = $sth->execute() ) )
    {
        return;
    }
    else
    {

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

    {
        return( exists( $ref->{ $type } ) ? $ref->{ $type } : undef() );
    }
    else
    {
        return( wantarray() ? () : undef() ) if( !%$ref );
        return( wantarray() ? %$ref : $ref );
    }
}

sub state(@)
{
    my $self = shift( @_ );
    # $str = $h->state;
    if( !ref( $self ) )
    {
        return( $DBI::state );
    }
    else
    {
        return( $self->SUPER::state() );

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

sub init
{
    my $self = shift( @_ );
    $self->SUPER::init( @_ );
    $self->{ 'driver' } = 'mysql';
    return( $self );
}
# End of generic routines 

# ROUTINES PROPRIETAIRE 
sub attribute($;$@)
{
    my $self = shift( @_ );
    # $h->{AttributeName} = ...;    # set/write
    # ... = $h->{AttributeName};    # get/read
    # 1 means that the attribute may be modified
    # 0 mneas that the attribute may only be read
    my $name  = shift( @_ ) if( @_ == 1 );
    my %arg   = ( @_ );
    my %attr  = 
    (

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

            if( exists( $attr{ $name } ) && 
                defined( $value ) && 
                $attr{ $name } )
            {
                $self->{dbh}->{ $name } = $value;
            }
        }
    }
}

sub begin_work($;$@)
{
    my $self = shift( @_ );
    $self->{transaction} = 1;
    $self->{AutoCommit_previous} = $self->{dbh}->{AutoCommit};
    $self->{dbh}->{AutoCommit} = 0;
    return( $self );
}

sub commit($;$@)
{
    my $self = shift( @_ );
    $self->{transaction} = 0;
    $self->{dbh}->commit( @_ );
    $self->{dbh}->{AutoCommit} = $self->{AutoCommit_previous} if( length( $self->{AutoCommit_previous} ) );
    return( $self );
}

sub connect
{

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

    return( $self );
}

# Get/set alias
# sub alias

# sub as_string

# sub avoid

sub attribute($;$@)
{
    my $self = shift( @_ );
    # $h->{AttributeName} = ...;    # set/write
    # ... = $h->{AttributeName};    # get/read
    # 1 means that the attribute may be modified
    # 0 mneas that the attribute may only be read
    my $name  = shift( @_ ) if( @_ == 1 );
    my %arg   = ( @_ );
    my %attr =
    (

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

                $attr{ $name } )
            {
                $self->{dbh}->{ $name } = $value;
            }
        }
    }
}

# sub available_drivers(@)

sub begin_work($;$@)
{
    my $self = shift( @_ );
    $self->{transaction} = 1;
    return( $self->{dbh}->begin_work( @_ ) );
}

# This method is common to DB::Object and DB::Object::Statement
# sub bind

# sub cache

# sub check_driver(@;$@)

sub commit($;$@)
{
    my $self = shift( @_ );
    $self->{transaction} = 0;
    return( $self->{dbh}->commit( @_ ) );
}

# Inherited by DB::Object, however, DB::Object::connect() will call our subroutine 
# _dbi_connect which format in a particular way the dsn.
sub connect
{

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

    {
        $dbh->pg_notifies;
    };
    if( $@ )
    {
        return( $self->error( "Error calling PostgreSQL function pg_notifies: $@" ) );
    }
    return( $ref );
}

sub pg_ping(@)
{
    return( shift->{dbh}->pg_ping );
}

# See DB::Object
# sub ping(@)

# See DB::Object
# sub prepare($;$)

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

    my $self  = shift( @_ );
    my $q = $self->_reset_query;
    return( $q->returning( @_ ) );
}

sub rollback
{
    return( shift->{dbh}->rollback() );
}

sub rollback_to(@)
{
    return( shift->{dbh}->pg_rollback_to( @_ ) );
}

sub savepoint(@)
{
    return( shift->{dbh}->pg_savepoint( @_ ) );
}

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

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

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

    my $all = $sth->fetchall_arrayref( {} );
    return( $all );
}

# See DB::Object
# sub tables_refresh

# See DB::Object
# sub tie

sub trace($;@)
{
    my $self = shift( @_ );
    # Value is a numeric level; see parse_trace_flag.
    return( $self->error( "Trace can only be used on active connection. Use connect first." ) ) if( !$self->{dbh} );
    if( @_ )
    {
        # my( $opt, $filename ) = @_;
        $self->{dbh}->trace( @_ );
    }
    return( $self->{dbh}->trace );
}

sub trace_msg(@)
{
    my $self = shift( @_ );
    return( $self->error( "Trace can only be used on active connection. Use connect first." ) ) if( !$self->{dbh} );
    # $dbh->trace_msg( $message_text, $min_level );
    return( $self->{dbh}->trace_msg( @_ ) );
}

# sub unix_timestamp

sub unlock

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

    return( $self );
}

# Get/set alias
# sub alias

# sub as_string

# sub avoid

sub attribute($;$@)
{
    my $self = shift( @_ );
    # $h->{AttributeName} = ...;    # set/write
    # ... = $h->{AttributeName};    # get/read
    # 1 means that the attribute may be modified
    # 0 mneas that the attribute may only be read
    my $name  = shift( @_ ) if( @_ == 1 );
    my %arg   = ( @_ );
    my %attr =
    (

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

                $attr{ $name } )
            {
                $self->{dbh}->{ $name } = $value;
            }
        }
    }
}

# sub available_drivers(@)

sub begin_work($;$@)
{
    my $self = shift( @_ );
    $self->{transaction} = 1;
    return( $self->{dbh}->begin_work( @_ ) );
}

# This method is common to DB::Object and DB::Object::Statement
# sub bind

# sub cache

sub can_update_delete_limit { return( shift->has_compile_option( 'ENABLE_UPDATE_DELETE_LIMIT' ) ); }

# sub check_driver(@;$@)

sub commit($;$@)
{
    my $self = shift( @_ );
    $self->{transaction} = 0;
    return( $self->{dbh}->commit( @_ ) );
}

sub compile_options
{
    my $self = shift( @_ );
    return( [ @$COMPILE_OPTIONS ] ) if( scalar( @$COMPILE_OPTIONS ) );

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

}

sub executed
{
    my $self = shift( @_ );
    # For hand made query to avoid clash when executing generic routine such as fetchall_arrayref...
    return( 1 ) if( !exists( $self->{query} ) );
    return( exists( $self->{executed} ) && $self->{executed} );
}

sub fetchall_arrayref($@)
{
    my $self  = shift( @_ );
    my $slice = shift( @_ ) || [];
    my $dbo   = $self->database_object;
    my $sth   = $self->{sth};
    if( !$self->executed() )
    {
        $self->execute() || return;
    }
    # Ensure we set the cache of field names and types. We will need them to post process the query results with _convert_datetime2object()

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

        warn( "fetchall_arrayref($mode) invalid" );
    }
    # return( \@rows );
    return( \@rows ) if( !$need_post_processing );
    my $data = \@rows;
    $data = $self->_convert_json2hash({ statement => $sth, data => $data }) if( $dbo->auto_decode_json );
    $data = $self->_convert_datetime2object({ statement => $sth, data => $data }) if( $dbo->auto_convert_datetime_to_object );
    return( $data );
}

sub fetchcol($;$)
{
    my $self = shift( @_ );
    # @arr = $sth->fetchcol( $col_number );
    my $col_num = shift( @_ );
    if( !$self->executed() )
    {
        $self->execute() || return( $self->pass_error );
    }
    # $self->_cleanup();
    # return( $h->fetchcol( $COL_NUM ) );
    my @col;
    # $self->dataseek( 0 );
    my $ref;
    while( $ref = $self->{sth}->fetchrow_arrayref() )
    {
        push( @col, $ref->[ $col_num ] );
    }
    return( @col );
}

sub fetchhash(@)
{
    my $self = shift( @_ );
    my $dbo  = $self->database_object;
    if( !$self->executed() )
    {
        $self->execute() || return( $self->pass_error );
    }
    # Ensure we set the cache of field names and types. We will need them to post process the query results with _convert_datetime2object()
    # This is necessary for MySQL whose object lose that information, while the PostgreSQL or SQLite driver keep the information.
    if( $dbo->auto_decode_json || $dbo->auto_convert_datetime_to_object )

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

            $ref = $self->_convert_datetime2object({ statement => $sth, data => $ref }) if( $dbo->auto_convert_datetime_to_object );
        }
        return( %$ref );
    }
    else
    {
        return( () );
    }
}

sub fetchrow(@)
{
    my $self = shift( @_ );
    if( !$self->executed() )
    {
        $self->execute() || return( $self->pass_error );
    }
    # $self->_cleanup();
    # @arr = $sth->fetchrow;        # Array context
    # $firstcol = $sth->fetchrow;   # Scalar context
    # return( $h->fetchrow );

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

    my $self = shift( @_ );
    if( $self->{sth} && $self->param( 'autocommit' ) )
    {
        my $sth = $self->prepare( "ROLLBACK" ) || return( $self->error( "An error occurred while preparing query to rollback: ", $self->error ) );
        $sth->execute() || return( $self->error( "Error occurred while executing query to rollback: ", $sth->error ) );
        $sth->finish();
    }
    return( $self );
}

sub rows(@)
{
    my $self = shift( @_ );
    if( !$self->executed() )
    {
        $self->execute() || return( $self->pass_error );
    }
    # $self->_cleanup();
    # $rv = $sth->rows;
    if( !ref( $self ) )
    {

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

    $o->prefixed( $self->{prefixed} );
    $self->messagec( 5, "Saving fields object whose table object has name {green}", $o->table_object->name, "{/} and alias {green}", $o->table_object->as, "{/}. Fields object has debug value '", $o->debug, "'" );
    $self->{fields_object} = $o;
    return( $o );
}

sub fo { return( shift->fields_object( @_ ) ); }

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

sub format_statement($;\%\%@) { return( shift->_method_to_query( 'format_statement', @_ ) ); }

sub format_update($;%) { return( shift->_method_to_query( 'format_update', @_ ) ); }

sub from_unixtime { return( shift->_method_to_query( 'from_unixtime', @_ ) ); }

sub get_query_object { return( shift->_reset_query ); }

sub group { return( shift->_method_to_query( 'group', @_ ) ); }

# sub indexes { return( shift->_set_get_class_array_object( 'indexes', {
#     is_primary => { type => 'boolean' },
#     is_unique => { type => 'boolean' },