Rose::DB::SQLite - SQLite driver class for Rose::DB.

  use Rose::DB;

  Rose::DB->register_db(
    domain   => 'development',
    type     => 'main',
    driver   => 'sqlite',
    database => '/path/to/some/file.db',
  );




  Rose::DB->default_domain('development');
  Rose::DB->default_type('main');
  ...

  # Set max length of varchar columns used to emulate the array data type
  Rose::DB::SQLite->max_array_characters(128);

  $db = Rose::DB->new; # $db is really a Rose::DB::SQLite-derived object
  ...

    Type        Format
    ---------   ------------------------------
    DATE        YYYY-MM-DD
    DATETIME    YYYY-MM-DD HH:MM::SS
    TIMESTAMP   YYYY-MM-DD HH:MM::SS.NNNNNNNNN

package Rose::DB::SQLite;

use strict;

use Carp();

use Rose::DB;
use SQL::ReservedWords::SQLite();

our $VERSION = '0.759';

#our $Debug = 0;

use Rose::Class::MakeMethods::Generic
(
  inheritable_scalar => 'coerce_autoincrement_to_serial',
);

__PACKAGE__->coerce_autoincrement_to_serial(1);

#
# Object methods
#

sub build_dsn
{
  my($self_or_class, %args) = @_;

  my %info;

  $info{'dbname'} = $args{'db'} || $args{'database'};

  return
    "dbi:SQLite:" . 
    join(';', map { "$_=$info{$_}" } grep { defined $info{$_} } qw(dbname));
}

sub dbi_driver { 'SQLite' }

sub init_dbh
{
  my($self) = shift;

  my $database = $self->database;

  unless($self->auto_create || -e $database)
  {
    Carp::croak "Refusing to create non-existent SQLite database ",
                "file: '$database'";
  }

  my $method = ref($self)->parent_class . '::init_dbh';

  no strict 'refs';
  return $self->$method(@_);
}

sub last_insertid_from_sth { shift->dbh->func('last_insert_rowid') }

sub supports_multi_column_count_distinct { 0 }

sub validate_date_keyword
{
  no warnings;
  !ref $_[1] && (lc $_[1] eq 'current_timestamp' ||
    ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/));
}

sub validate_datetime_keyword
{
  no warnings;
  !ref $_[1] && (lc $_[1] eq 'current_timestamp' ||
    ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/));
}

sub validate_timestamp_keyword
{
  no warnings;
  !ref $_[1] && (lc $_[1] eq 'current_timestamp' ||
    ($_[0]->keyword_function_calls && $_[1] =~ /^\w+\(.*\)$/));
}

sub should_inline_date_keyword      { 1 }
sub should_inline_datetime_keyword  { 1 }
sub should_inline_time_keyword      { 1 }
sub should_inline_timestamp_keyword { 1 }

sub parse_date
{
  my($self, $value) = @_;

  if(UNIVERSAL::isa($value, 'DateTime') || 
    $self->validate_date_keyword($value))
  {
    return $value;
  }

  my($dt, $error);

  TRY:
  {
    local $@;
    eval { $dt = Rose::DateTime::Util::parse_date($value) };
    $error = $@;
  }

  if($error)
  {
    $self->error("Could not parse date '$value' - $error");
    return undef;
  }

  return $dt;
}

sub parse_datetime
{
  my($self, $value) = @_;

  if(UNIVERSAL::isa($value, 'DateTime') || 
    $self->validate_datetime_keyword($value))
  {
    return $value;
  }

  my($dt, $error);

  TRY:
  {
    local $@;
    eval { $dt = Rose::DateTime::Util::parse_date($value) };
    $error = $@;
  }

  if($error)
  {
    $self->error("Could not parse datetime '$value' - $error");
    return undef;
  }

  return $dt;
}

sub parse_timestamp
{
  my($self, $value) = @_;

  if(UNIVERSAL::isa($value, 'DateTime') || 
    $self->validate_timestamp_keyword($value))
  {
    return $value;
  }

  my($dt, $error);

  TRY:
  {
    local $@;
    eval { $dt = Rose::DateTime::Util::parse_date($value) };
    $error = $@;
  }

  if($error)
  {
    $self->error("Could not parse timestamp '$value' - $error");
    return undef;
  }

  return $dt;
}

sub format_bitfield 
{
  my($self, $vec, $size) = @_;
  $vec = Bit::Vector->new_Bin($size, $vec->to_Bin)  if($size);
  return q(b') . $vec->to_Bin . q(');
}

sub refine_dbi_column_info
{
  my($self, $col_info) = @_;

  my $method = ref($self)->parent_class . '::refine_dbi_column_info';

  no strict 'refs';
  $self->$method($col_info);

  if($col_info->{'TYPE_NAME'} eq 'bit')
  {
    $col_info->{'TYPE_NAME'} = 'bits';
  }

  elsif($col_info->{'TYPE_NAME'} eq 'datetime' && defined $col_info->{'COLUMN_DEF'})
  {
    if(lc $col_info->{'COLUMN_DEF'} eq 'current_timestamp')
    {
      # Translate "current time" value into something that our date parser
      # will understand.
      $col_info->{'COLUMN_DEF'} = 'now';

      # ...or let the database handle this?
      #$col_info->{'COLUMN_DEF'} = undef;
    }
  }

  return;
}

sub likes_implicit_joins { 1 }

*is_reserved_word = \&SQL::ReservedWords::SQLite::is_reserved;

sub quote_column_name 
{
  my $name = $_[1];
  $name =~ s/"/""/g;
  return qq("$name");
}

sub quote_table_name
{
  my $name = $_[1];
  $name =~ s/"/""/g;
  return qq("$name");
}

#
# Introspection
#

sub list_tables
{
  my($self, %args) = @_;

  my $types = $args{'include_views'} ? q('table', 'view') : q('table');

  my(@tables, $error);

  TRY:
  {
    local $@;

    eval
    {
      my $dbh = $self->dbh or die $self->error;

      local $dbh->{'RaiseError'} = 1;

      my $sth = $dbh->prepare("SELECT name FROM sqlite_master WHERE type IN($types)");
      $sth->execute;

      my $name;
      $sth->bind_columns(\$name);

      while($sth->fetch)
      {
        push(@tables, $name);
      }
    };

    $error = $@;
  }

  if($error)
  {
    Carp::croak "Could not list tables from ", $self->dsn, " - $error";
  }

  return wantarray ? @tables : \@tables;
}

sub _get_primary_key_column_names
{
  my($self, $catalog, $schema, $table) = @_;
  my $pk_columns = ($self->_table_info($table))[1] || [];
  return $pk_columns;
}

sub _table_info
{
  my($self, $table) = @_;

  my $dbh = $self->dbh or Carp::croak $self->error;

  my $table_unquoted = $self->unquote_table_name($table);

  my $sth = $dbh->prepare("SELECT sql FROM sqlite_master WHERE type = 'table' AND name = ?");
  my $sql;

  $sth->execute($table_unquoted);
  $sth->bind_columns(\$sql);
  $sth->fetch;
  $sth->finish;

  return $self->_info_from_sql($sql);
}

## Yay!  A Giant Wad o' Regexes "parser"!  Yeah, this is lame, but I really
## don't want to load an actual parser, or even a regex lib or helper...

our $Paren_Depth   = 15;
our $Nested_Parens = '\(' . '([^()]|\(' x $Paren_Depth . '[^()]*' . '\))*' x $Paren_Depth . '\)';

# This doesn't seem to work...
#$Nested_Parens = qr{\( (?: (?> [^()]+ ) | (??{ $Nested_Parens }) )* \)}x;

our $Quoted =   
  qr{(?: ' (?: [^'] | '' )+ '
          | " (?: [^"] | "" )+ "
          | ` (?: [^`] | `` )+ `)}six;

our $Name = qr{(?: $Quoted | \w+ )}six;

our $Type = 
  qr{\w+ (?: \s* \( \s* \d+ \s* (?: , \s* \d+ \s*)? \) )?}six;

our $Conflict_Algorithm = 
  qr{(?: ROLLBACK | ABORT | FAIL | IGNORE | REPLACE )}six;

our $Conflict_Clause =
  qr{(?: ON \s+ CONFLICT \s+ $Conflict_Algorithm )}six;

our $Sort_Order = 
  qr{(?: COLLATE \s+ \S+ \s+)? (?:ASC | DESC)}six;

our $Column_Constraint = 
  qr{(?: NOT \s+ NULL (?: \s+ $Conflict_Clause)?
          | PRIMARY \s+ KEY (?: \s+ $Sort_Order)? (?: \s+ $Conflict_Clause)? (?: \s+ AUTOINCREMENT)? 
          | UNIQUE (?: \s+ $Conflict_Clause)? 
          | CHECK \s* $Nested_Parens (?: \s+ $Conflict_Clause)?
          | REFERENCES \s+ $Name \s* \( \s* $Name \s* \)
          | DEFAULT \s+ (?: $Name | \w+ \s* $Nested_Parens | [^,)]+ )
          | COLLATE \s+ \S+)}six;

our $Table_Constraint =
  qr{(?: (?: PRIMARY \s+ KEY | UNIQUE | CHECK ) \s* $Nested_Parens 
          | FOREIGN \s+ KEY \s+ (?: $Name \s+ )? $Nested_Parens \s+ REFERENCES \s+ $Name \s+ $Nested_Parens )}six;

our $Column_Def =
  qr{($Name) (?:\s+ ($Type))? ( (?: \s+ (?:CONSTRAINT \s+ $Name \s+)? $Column_Constraint )* )}six;

# SQLite allows C comments to be unterminated if they're at the end of the 
# input stream.  Crazy, but true: http://www.sqlite.org/lang_comment.html
our $C_Comment_Cont = qr{/\*.*$}six;
our $C_Comment      = qr{/\*[^*]*\*+(?:[^/*][^*]*\*+)*/}six;
our $SQL_Comment    = qr{--[^\r\n]*(\r?\n)}six;
our $Comment        = qr{($Quoted)|($C_Comment|$SQL_Comment|$C_Comment_Cont)}six;

# These constants are from the DBI documentation.  Is there somewhere 
# I can load these from?
use constant SQL_NO_NULLS => 0;
use constant SQL_NULLABLE => 1;

sub _info_from_sql
{
  my($self, $sql) = @_;

  my(@col_info, @pk_columns, @uk_info);

  my($new_sql, $pos);

  my $class = ref($self) || $self;

  # Remove comments
  while($sql =~ /\G((.*?)$Comment)/sgix)
  {
    $pos = pos($sql);

    if(defined $4) # caught comment
    {
      no warnings 'uninitialized';
      $new_sql .= "$2$3";
    }
    else
    {
      $new_sql .= $1;
    }
  }

  $sql = $new_sql . substr($sql, $pos) if(defined $new_sql);

  # Remove the start and end
  $sql =~ s/^\s* CREATE \s+ (?:TEMP(?:ORARY)? \s+)? TABLE \s+ $Name \s*\(\s*//sgix;
  $sql =~ s/\s*\)\s*$//six;

  # Remove leading space from lines
  $sql =~ s/^\s+//mg;

  my $i = 1;

  # Column definitions
  while($sql =~ s/^$Column_Def (?:\s*,\s*|\s*$)//six)
  {
    my $col_name    = _unquote_name($1);
    my $col_type    = $2 || 'scalar';
    my $constraints = $3;

    unless(defined $col_name)
    {
      Carp::croak "Could not extract column name from SQL: $sql";
    }

    my %col_info =
    (
      COLUMN_NAME      => $col_name,
      TYPE_NAME        => $col_type,
      ORDINAL_POSITION => $i++,
    );

    if($col_type =~ /^(\w+) \s* \( \s* (\d+) \s* \)$/x)
    {
      $col_info{'TYPE_NAME'}         = $1;
      $col_info{'COLUMN_SIZE'}       = $2;
      $col_info{'CHAR_OCTET_LENGTH'} = $2;
    }
    elsif($col_type =~ /^\s* (\w+) \s* \( \s* (\d+) \s* , \s* (\d+) \s* \) \s*$/x)
    {
      $col_info{'TYPE_NAME'}      = $1;
      $col_info{'DECIMAL_DIGITS'} = $2;
      $col_info{'COLUMN_SIZE'}    = $3;
    }

    while($constraints =~ s/^\s* (?:CONSTRAINT \s+ $Name \s+)? ($Column_Constraint) \s*//six)
    {
      local $_ = $1;

      if(/^DEFAULT \s+ ( $Name | \w+ \s* $Nested_Parens | [^,)]+ )/six)
      {
        $col_info{'COLUMN_DEF'} = _unquote_name($1);
      }
      elsif(/^PRIMARY (?: \s+ KEY )? \b (?: .*? (AUTOINCREMENT) )?/six)
      {
        push(@pk_columns, $col_name);

        if($1 && $class->coerce_autoincrement_to_serial)
        {
          $col_info{'TYPE_NAME'} = 'serial';
        }
      }
      elsif(/^\s* UNIQUE (?: \s+ KEY)? \b/six)
      {
        push(@uk_info, [ $col_name ]);
      }
      elsif(/^NOT \s+ NULL \b/six)
      {
        $col_info{'NULLABLE'} = SQL_NO_NULLS;
      }
    }

    $col_info{'NULLABLE'} = SQL_NULLABLE  unless(defined $col_info{'NULLABLE'});

    push(@col_info, \%col_info);
  }

  while($sql =~ s/^($Table_Constraint) (?:\s*,\s*|\s*$)//six)
  {
    my $constraint = $1;

    if($constraint =~ /^\s* PRIMARY \s+ KEY \s* ($Nested_Parens)/six)
    {
      @pk_columns = ();

      my $columns = $1;
      $columns =~ s/^\(\s*//;
      $columns =~ s/\s*\)\s*$//;

      while($columns =~ s/^\s* ($Name) (?:\s*,\s*|\s*$)//six)
      {
        push(@pk_columns, _unquote_name($1));
      }
    }
    elsif($constraint =~ /^\s* UNIQUE \s* ($Nested_Parens)/six)
    {
      my $columns = $1;
      $columns =~ s/^\(\s*//;
      $columns =~ s/\s*\)\s*$//;

      my @uk_columns;

      while($columns =~ s/^\s* ($Name) (?:\s*,\s*|\s*$)//six)
      {
        push(@uk_columns, _unquote_name($1));
      }

      push(@uk_info, \@uk_columns);
    }
  }

  return(\@col_info, \@pk_columns, \@uk_info);
}

sub _unquote_name
{
  my $name = shift;

  if($name =~ s/^(['`"]) ( (?: [^\1]+ | \1\1 )+ ) \1 $/$2/six)
  {
    my $q = $1;
    $name =~ s/$q$q/$q/g;
  }

  return $name;
}

1;

__END__