view release on metacpan or  search on metacpan

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

    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())) {
      $attr->{sqlite_open_flags} |= DBD::SQLeet::OPEN_READWRITE() | DBD::SQLeet::OPEN_CREATE();
    }
  }

  # To avoid unicode and long file name problems on Windows,
  # convert to the shortname if the file (or parent directory) exists.
  if ($^O =~ /MSWin32/ and $real ne ':memory:' and $real ne '' and $real !~ /^file:/ and !-f $real) {
    require File::Basename;
    my ($file, $dir, $suffix) = File::Basename::fileparse($real);
    # We are creating a new file.
    # Does the directory it's in at least exist?
    if (-d $dir) {
      require Win32;
      $real = join '', grep { defined } Win32::GetShortPathName($dir), $file, $suffix;
    } else {
      # SQLite can't do mkpath anyway.
      # So let it go through as it and fail.
    }
  }

  # Hand off to the actual login function
  DBD::SQLeet::db::_login($dbh, $real, $user, $auth, $attr) or return undef;

  # Register the on-demand collation installer, REGEXP function and
  # perl tokenizer
  if (DBD::SQLeet::NEWAPI) {
    $dbh->sqlite_collation_needed( \&install_collation );
    $dbh->sqlite_create_function( "REGEXP", 2, \&regexp );
    $dbh->sqlite_register_fts3_perl_tokenizer();
  } else {
    $dbh->func(\&install_collation, "collation_needed");
    $dbh->func("REGEXP", 2, \&regexp, "create_function");
    $dbh->func("register_fts3_perl_tokenizer");
  }

  # HACK: Since PrintWarn = 0 doesn't seem to actually prevent warnings
  # in DBD::SQLeet we set Warn to false if PrintWarn is false.

  # NOTE: According to the explanation by timbunce,
  # "Warn is meant to report on bad practices or problems with
  # the DBI itself (hence always on by default), while PrintWarn
  # is meant to report warnings coming from the database."
  # That is, if you want to disable an ineffective rollback warning
  # etc (due to bad practices), you should turn off Warn,
  # and to silence other warnings, turn off PrintWarn.
  # Warn and PrintWarn are independent, and turning off PrintWarn
  # does not silence those warnings that should be controlled by
  # Warn.

  # unless ( $attr->{PrintWarn} ) {
  #     $attr->{Warn} = 0;
  # }

  return $dbh;
}

sub install_collation {
  my $dbh = shift;
  my $name = shift;
  my $collation = $DBD::SQLeet::COLLATION{$name};
  unless ($collation) {
    warn "Can't install unknown collation: $name" if $dbh->{PrintWarn};
    return;
  }
  if (DBD::SQLeet::NEWAPI) {