view release on metacpan or  search on metacpan

lib/CCCP/SQLiteWrap.pm  view on Meta::CPAN

package CCCP::SQLiteWrap;

use 5.010000;
use strict;

our $VERSION = '0.01';

use DBI;
use File::Temp;
use File::Copy;
use Data::UUID;
use Digest::MD5 qw(md5_hex);    
    
    $CCCP::SQLiteWrap::OnlyPrint = 0;

use warnings;
    
    my $t_create_pattern = 'CREATE TABLE IF NOT EXISTS %s (%s)';
    my $i_create_pattern = 'CREATE INDEX %s ON %s(%s)';
    my $tr_create_pattern = ['DROP TRIGGER IF EXISTS %s','CREATE TRIGGER IF NOT EXISTS %s %s %s ON %s FOR EACH ROW BEGIN %s; END;'];

# one argument - abs path to sqolite base
sub connect {
    my ($class,$path) = @_;    
    
    if (ref $class) {
        # reconnect
        $class->{db} = DBI->connect('dbi:SQLite:dbname='.$class->path, '', '',{RaiseError => 1, InactiveDestroy => 1});
    } else {
        # init new handler
        my $obj = bless( 
            {
                db => DBI->connect('dbi:SQLite:dbname='.$path, '', '',{RaiseError => 1, InactiveDestroy => 1}),
                path => $path  
            },
            $class
        );
        
        # check connect error
        if ($DBI::errstr) {
            die $DBI::errstr;
        };
        
        return $obj;
    }
}

sub check {
    my ($obj) = @_;    
        
    # check live connection
    unless ($obj->db->ping()) {
        return "Can't ping SQLite base from ".$obj->path."\n";
    };
    
    # check database structure
    my $need_rebackup = 0;
    my @table = $obj->show_tables;
    foreach my $table (@table) {
        next unless $table;
        eval{$obj->db->selectall_arrayref("SELECT * FROM $table LIMIT 1")};
        if ($DBI::errstr) {
            $need_rebackup++;
            last;
        };
    };
    if ($need_rebackup) {
        return "SQLite base from ".$obj->path." return error like 'database disk image is malformed' and goto re-dump";
        return "Bug in re-dump SQLite" unless $obj->redump();       
    };
    
    return;    
}

sub db {$_[0]->{'db'}}
sub path {$_[0]->{'path'}}

# return [{'field1'=>'some_value1',...},{'field1'=>'some_value2',...}]
sub select2arhash {
    my ($obj,$query,@param) = @_;
    my $sth = $obj->db->prepare($query);
    $sth->execute(@param);
    return $sth->fetchall_arrayref({});
}

sub create_table {
    my $obj = shift;
    return unless (@_ or scalar @_ % 2 == 0);
    
    my $exisis_table = $obj->show_tables;
    my @new_table = ();
    my @create_table = ();
    my $can_fk = $obj->db->selectrow_arrayref('PRAGMA foreign_keys');
    while (my ($name,$param) = splice(@_,0,2)) {
        next if (not $name or ref $name or not $param or ref $param ne 'HASH' or not exists $param->{fields}); 
        $name = lc($name);
        next if $exisis_table->{$name}++;
        
        my $desc = ''; my @index = ();
        if (exists $param->{meta}) {
            # set default value         
            if (exists $param->{meta}->{default} and scalar @{$param->{meta}->{default}} % 2) {
                while (my ($fild,$defval) = splice(@{$param->{meta}->{default}},0,2)) {
                    if (exists $param->{fields}->{$fild}) {                       
                       $param->{fields}->{$fild} .= ' DEFAULT '.$obj->db->quote($defval);
                    };
                }
            };
            
            # set not null
            if (exists $param->{meta}->{not_null}) {
                map {
                    if (exists $param->{fields}->{$_}) {                       
                       $param->{fields}->{$_} .= ' NOT NULL';
                    };
                } @{$param->{meta}->{not_null}}; 
            };
            
            # set unique
            if (exists $param->{meta}->{unique}) {
                map {
                    if (exists $param->{fields}->{$_}) {                       
                       $param->{fields}->{$_} .= ' UNIQUE';
                    };
                } @{$param->{meta}->{unique}}; 
            };