view release on metacpan or  search on metacpan

lib/DBD/SQLeet.pm  view on Meta::CPAN

package DBD::SQLeet;

use 5.006;
use strict;
use warnings;

use DBI 1.57 ();
use DynaLoader ();

our $VERSION = '0.26.0';
our @ISA = 'DynaLoader';

# sqlite_version cache (set in the XS bootstrap)
our ($sqlite_version, $sqlite_version_number);

# not sure if we still need these...
our ($err, $errstr);

__PACKAGE__->bootstrap($VERSION);

# New or old API?
use constant NEWAPI => ($DBI::VERSION >= 1.608);

# global registry of collation functions, initialized with 2 builtins
our %COLLATION;
tie %COLLATION, 'DBD::SQLeet::_WriteOnceHash';
$COLLATION{perl} = sub { $_[0] cmp $_[1] };
$COLLATION{perllocale} = sub { use locale; $_[0] cmp $_[1] };

our $drh;
my $methods_are_installed = 0;

sub driver {
  return $drh if $drh;

  if (!$methods_are_installed && DBD::SQLeet::NEWAPI ) {
    DBI->setup_driver('DBD::SQLeet');

    DBD::SQLeet::db->install_method('sqlite_last_insert_rowid');
    DBD::SQLeet::db->install_method('sqlite_busy_timeout');
    DBD::SQLeet::db->install_method('sqlite_create_function');
    DBD::SQLeet::db->install_method('sqlite_create_aggregate');
    DBD::SQLeet::db->install_method('sqlite_create_collation');
    DBD::SQLeet::db->install_method('sqlite_collation_needed');
    DBD::SQLeet::db->install_method('sqlite_progress_handler');
    DBD::SQLeet::db->install_method('sqlite_commit_hook');
    DBD::SQLeet::db->install_method('sqlite_rollback_hook');
    DBD::SQLeet::db->install_method('sqlite_update_hook');
    DBD::SQLeet::db->install_method('sqlite_set_authorizer');
    DBD::SQLeet::db->install_method('sqlite_backup_from_file');
    DBD::SQLeet::db->install_method('sqlite_backup_to_file');
    DBD::SQLeet::db->install_method('sqlite_enable_load_extension');
    DBD::SQLeet::db->install_method('sqlite_load_extension');
    DBD::SQLeet::db->install_method('sqlite_register_fts3_perl_tokenizer');
    DBD::SQLeet::db->install_method('sqlite_trace', { O => 0x0004 });
    DBD::SQLeet::db->install_method('sqlite_profile', { O => 0x0004 });
    DBD::SQLeet::db->install_method('sqlite_table_column_metadata', { O => 0x0004 });
    DBD::SQLeet::db->install_method('sqlite_db_filename', { O => 0x0004 });
    DBD::SQLeet::db->install_method('sqlite_db_status', { O => 0x0004 });
    DBD::SQLeet::st->install_method('sqlite_st_status', { O => 0x0004 });
    DBD::SQLeet::db->install_method('sqlite_create_module');

    $methods_are_installed++;
  }

  $drh = DBI::_new_drh( "$_[0]::dr", {
    Name => 'SQLite',
    Version => $VERSION,
    Attribution => 'DBD::SQLeet by Dimitar D. Mitov et al',
  } );

  return $drh;
}

sub CLONE {
  undef $drh;
}


package # hide from PAUSE
  DBD::SQLeet::dr;

sub connect {
  my ($drh, $dbname, $user, $auth, $attr) = @_;

  # Default PrintWarn to the value of $^W
  # unless ( defined $attr->{PrintWarn} ) {
  #    $attr->{PrintWarn} = $^W ? 1 : 0;
  # }

  my $dbh = DBI::_new_dbh( $drh, {
    Name => $dbname,
  } );

  my $real = $dbname;
  if ($dbname =~ /=/) {
    foreach my $attrib (split(/;/, $dbname)) {
      my ($key, $value) = split(/=/, $attrib, 2);
      if ($key =~ /^(?:db(?:name)?|database)$/) {
        $real = $value;
      } elsif ($key eq 'uri') {
        $real = $value;
        $attr->{sqlite_open_flags} |= DBD::SQLeet::OPEN_URI();
      } else {
        $attr->{$key} = $value;
      }
    }
  }

  if (my $flags = $attr->{sqlite_open_flags}) {
    unless ($flags & (DBD::SQLeet::OPEN_READONLY() | DBD::SQLeet::OPEN_READWRITE())) {