File Coverage

blib/lib/ORM/Db/DBI/SQLite.pm

Criterion	Covered	Total	%
statement	72	78	92.3
branch	21	32	65.6
condition	2	5	40.0
subroutine	12	13	92.3
pod	0	10	0.0
total	107	138	77.5

#
# DESCRIPTION
#   PerlORM - Object relational mapper (ORM) for Perl. PerlORM is Perl
#   library that implements object-relational mapping. Its features are
#   much similar to those of Java's Hibernate library, but interface is
#   much different and easier to use.
#
# AUTHOR
#   Alexey V. Akimov
#
# COPYRIGHT
#   Copyright (C) 2005-2006 Alexey V. Akimov
#
#   This library is free software; you can redistribute it and/or
#   modify it under the terms of the GNU Lesser General Public
#   License as published by the Free Software Foundation; either
#   version 2.1 of the License, or (at your option) any later version.
#
#   This library is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#   Lesser General Public License for more details.
#
#   You should have received a copy of the GNU Lesser General Public
#   License along with this library; if not, write to the Free Software
#   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
#

package ORM::Db::DBI::SQLite;

$VERSION = 0.8;

use base 'ORM::Db::DBI';

##
## CONSTRUCTORS
##

sub new
{
    my $class = shift;
    my %arg   = @_;

    $arg{driver} = 'SQLite';
    $class->SUPER::new( %arg );
}

##
## CLASS METHODS
##

sub qc
{
    my $self = shift;
    my $str  = shift;

    if( defined $str )
    {
        $str =~ s/\'/\'\'/g;
        $str = "'$str'";
    }
    else
    {
        $str = 'NULL';
    }

    return $str;
}

sub qi
{
    my $self = shift;
    my $str  = shift;

    $str =~ s/\[/\\\[/g;
    $str =~ s/\]/\\\]/g;
    $str = "[$str]";

    return $str;
}

sub qt { $_[0]->qi( $_[1] ); }
sub qf { $_[0]->qi( $_[1] ); }

##
## OBJECT METHODS
##


sub begin_transaction
{
    my $self  = shift;
    my %arg   = @_;

    $self->{ta} = 1;
    $self->do( query=>"BEGIN TRANSACTION", error=>$arg{error} );
}

sub commit_transaction
{
    my $self  = shift;
    my %arg   = @_;

    delete $self->{ta};
    $self->do( query=>"COMMIT TRANSACTION", error=>$arg{error} );
}

sub rollback_transaction
{
    my $self  = shift;
    my %arg   = @_;

    delete $self->{ta};
    unless( $self->{lost_connection} )
    {
        $self->do( query=>"ROLLBACK TRANSACTION", error=>$arg{error} );
    }
}

## use: $id = $db->insertid()
##
sub insertid
{
    my $self = shift;
    $self->_db_handler ? $self->_db_handler->func( 'last_insert_rowid' ) : undef;
}

sub table_struct
{
    my $self   = shift;
    my %arg    = @_;
    my $error  = ORM::Error->new;
    my %field;
    my %defaults;
    my $res;

    ## Fetch table structure
    $res = $self->select
    (
        query => "SELECT sql FROM sqlite_master WHERE type='table' and name=".$self->qc($arg{table}),
        error => $error,
    );
    unless( $error->fatal )
    {
        my $data;

        $data = $res->next_row;
        $data = $data ? $data->{sql} : '';
        $data =~ /^CREATE TABLE [^\(]+\((.+)\)/ism;
        $data = $1 || '';
        $data =~ s/[\r\n]/ /g;

        my @rows = split /,/, $data if( $data );

        for $row ( @rows )
        {
            if( $row =~ /^\s*([^\s]+)\s+([^\s]+)(.*?\s+default (NULL|\'[^\']*\'))?/i )
            {
            	last if $1 =~ /PRIMARY|UNIQUE|CHECK/;
                my $name = $1;
                my $type = $2;
                my $def  = $4;

                $name = $1 if( $name =~ /^\[(.+)\]$/ );
                $name = $2 if( $name =~ /^(['"])(.+)\1$/ );

                if( ! defined $def )
                {
                }
                elsif( $def eq 'NULL' )
                {
                    $def = undef;
                }
                else
                {
                    $def = substr $def, 1, (length $def) - 2;
                }

                $defaults{ $name } = $def;
                $field{ $name }    = $arg{class}->_db_type_to_class( $name, $type );
            }
            else
            {
                $error->add_fatal( "Can't detect columns for table '$arg{table}'" );
                last;
            }
        }
    }

    ## Fetch class references
    if( scalar( %field ) )
    {
        $res = $self->select
        (
            error => $error,
            query => 'SELECT * FROM '.$self->qt('_ORM_refs').' WHERE class='.$self->qc( $arg{class} ),
        );
        unless( $error->fatal )
        {
            while( $data = $res->next_row )
            {
                if( exists $field{$data->{prop}} )
                {
                    $field{$data->{prop}} = $data->{ref_class};
                }
            }
        }
    }

    $error->upto( $arg{error} );
    return \%field, \%defaults;
}

sub _ta_select { ''; }

sub _lost_connection
{
    my $self = shift;
    my $err  = shift;

    defined $err && ( $err == 2006 || $err == 2013 );
}

##
## SQL FUNCTIONS
##