view release on metacpan or  search on metacpan

CAB/Format/SQLite.pm  view on Meta::CPAN

## -*- Mode: CPerl -*-
##
## File: DTA::CAB::Format::SQLite.pm
## Author: Bryan Jurish <moocow@cpan.org>
## Description: Datum parser|formatter: SQLite database (for DTA EvalCorpus)

package DTA::CAB::Format::SQLite;
use DTA::CAB::Format;
use DTA::CAB::Datum ':all';
use IO::File;
use Carp;
use strict;

##==============================================================================
## Globals
##==============================================================================

our @ISA = qw(DTA::CAB::Format);

BEGIN {
  DTA::CAB::Format->registerFormat(name=>__PACKAGE__, short=>'sqlite', filenameRegex=>qr/\.(?i:sqlite)(?:\:.*)?$/);
}

##==============================================================================
## Constructors etc.
##==============================================================================

## $fmt = CLASS_OR_OBJ->new(%args)
##  + object structure: assumed HASH
##    (
##     ##---- Input
##     doc => $doc,                    ##-- buffered input document
##     db_user => $user,	       ##-- db user (required?)
##     db_pass => $pass,	       ##-- db password (required?)
##     db_dsn  => $dsn,		       ##-- db dsn (set by fromFile())
##     db_opts => \%dbopts,	       ##-- additional options for DBI->connect() ; default={sqlite_unicode=>1}
##     f_which => $f_which,            ##-- restriction (see fromFile())
##     f_where => $f_where,            ##-- target value for restriction (see fromFile())
##     limit => $limit,		       ##-- sql limit clause (default: undef: none)
##     keep_history => $bool,	       ##-- if true, parse history as well as raw data (default: 1)
##     keep_null => $bool,	       ##-- if true, NULL values from db will be kept as undef (default: false)
##     keep_eps => $bool,	       ##-- if true, empty-string values from db will be kept as undef (default: false)
##     keep_temp => $bool,	       ##-- if true, temporary tables will be kept (default: false)
##
##     ##---- Output
##     #(disabled)
##
##     ##---- Common
##     dbh => $dbh,		       ##-- underlying database handle
##     raw => $bool,		       ##-- if false, will call forceDocument() on doc data
##
##     ##---- INHERITED from DTA::CAB::Format
##     #utf8     => $bool,             ##-- always true
##     #level    => $formatLevel,      ##-- 0:compressed, 1:formatted, ...
##     #outbuf   => $stringBuffer,     ##-- buffered output
##    )
sub new {
  my $that = shift;
  return $that->SUPER::new(
			   ##-- Input
			   #doc => undef,
			   db_user=>undef,
			   db_pass=>undef,
			   db_dsn=>undef,
			   db_opts=>{
				     sqlite_unicode=>1,
				    },
			   f_which=>undef,
			   f_where=>undef,
			   limit=>undef,
			   keep_history=>1,
			   keep_null=>0,
			   keep_eps=>0,
			   keep_temp=>0,

			   ##-- Output
			   #level  => 0,
			   #outbuf => '',

			   ##-- common
			   #utf8 => 1,
			   #dbh  => undef,
			   #raw => 0,

			   ##-- logging
			   trace_level => 'trace',
			   #trace_level => undef,

			   ##-- user args
			   @_
			  );
}

##==============================================================================
## Methods: db stuff
##  + mostly lifted from DbCgi.pm (svn+ssh://odo.dwds.de/home/svn/dev/dbcgi/trunk/DbCgi.pm @ 7672)
##==============================================================================
our $DBI_INITIALIZED = 0; ##-- package-global sentinel: have we loaded DBI ?

## $class_or_object = $class_or_object->dbi_init();
sub dbi_init {
  return 1 if ($DBI_INITIALIZED);
  eval 'use DBI;';
  $_[0]->logconfess("could not 'use DBI': $@") if ($@);
  return $_[0];
}


## $dbh = $fmt->dbh()
##  + returns database handle; implicitly calls $fmt->dbconnect() if not already connected
sub dbh {
  my $fmt = shift;
  return $fmt->{dbh} if (defined($fmt->{dbh}));
  return $fmt->dbconnect();
}

## $fmt = $fmt->dbconnect()
##  + (re-)connect to database; sets $fmt->{dbh}
sub dbconnect {
  my $fmt = shift;
  #print STDERR __PACKAGE__, "::dbconnect(): dsn=$fmt->{db_dsn}; CWD=", getcwd(), "\n";
  $fmt->dbi_init();
  my $dbh = $fmt->{dbh} = DBI->connect(@$fmt{qw(db_dsn db_user db_pass)}, {AutoCommit=>1,RaiseError=>1, %{$fmt->{db_opts}||{}}})
    or $fmt->logconfess("dbconnect(): could not connect to $fmt->{db_dsn}: $!");
  return $fmt;
}