File Coverage

blib/lib/Metabase/Backend/SQL.pm

Criterion	Covered	Total	%
statement	58	60	96.6
branch	3	6	50.0
condition			n/a
subroutine	11	12	91.6
pod			n/a
total	72	78	92.3

use 5.008001;
use strict;
use warnings;

package Metabase::Backend::SQL;
# ABSTRACT: Metabase backend role for SQL-based backends

our $VERSION = '1.001';

use Class::Load qw/load_class try_load_class/;
use SQL::Translator::Schema;
use Storable qw/nfreeze/;

use Moose::Role;

has [qw/dsn db_user db_pass db_type/] => (
  is => 'ro',
  isa => 'Str',
  lazy_build => 1,
);

has dbis => (
  is => 'ro',
  isa => 'DBIx::Simple',
  lazy_build => 1,
  handles => [qw/dbh/],
);

has schema => (
  is => 'ro',
  isa => 'SQL::Translator::Schema',
  lazy_build => 1,
);

has '_blob_field_params' => (
  is => 'ro',
  isa => 'HashRef',
  lazy_build => 1,
);

has '_guid_field_params' => (
  is => 'ro',
  isa => 'HashRef',
  lazy_build => 1,
);

#--------------------------------------------------------------------------#
# to be implemented by Metabase::Backend::${DBNAME}
#--------------------------------------------------------------------------#

requires '_build_dsn';
requires '_build_db_user';
requires '_build_db_pass';
requires '_build_db_type';
requires '_fixup_sql_diff';
requires '_build__blob_field_params';
requires '_build__guid_field_params';
requires '_munge_guid';
requires '_unmunge_guid';


#--------------------------------------------------------------------------#

sub _build_dbis {
  my ($self) = @_;
  my @connect = map { $self->$_ } qw/dsn db_user db_pass/;
  my $dbis = eval { DBIx::Simple->connect(@connect, {PrintWarn => 0}) }
    or die "Could not connect via " . join(":",map { qq{'$_'} } @connect[0,1],"...")
    . " because: $@\n";
  return $dbis;
}

sub _build_schema {
  my $self = shift;
  return SQL::Translator::Schema->new(
    name => 'Metabase',
    database => $self->db_type,
  );
}

sub _deploy_schema {
  my ($self) = @_;

  my $schema = $self->schema;

  # Blow up if this doesn't seem OK
  $schema->is_valid or die "Could not validate schema: $schema->error";
#  use Data::Dumper;
#  warn "Schema: " . Dumper($schema);

  my $db_type = $self->db_type;
  # See what we already have
  my $existing = SQL::Translator->new(
    parser => 'DBI',
    parser_args => {
      dbh => $self->dbh,
    },
    producer => $db_type,
    show_warnings => 0, # suppress warning from empty DB
  );
  {
    # shut up P::RD when there is no text -- the SQL::Translator parser
    # forces things on when loaded.  Gross.
    no warnings 'once';
    load_class( "SQL::Translator::Parser::" . $db_type );
    load_class( "SQL::Translator::Producer::" . $db_type );
    local *main::RD_ERRORS;
    local *main::RD_WARN;
    local *main::RD_HINT;
    my $existing_sql = $existing->translate();
#    warn "*** Existing schema: " . $existing_sql;
  }

  # Convert our target schema
  my $fake = SQL::Translator->new(
    parser => 'Storable',
    producer => $db_type,
  );
  my $fake_sql = $fake->translate( \( nfreeze($schema) ) );
#  warn "*** Fake schema: $fake_sql";

  my $diff = SQL::Translator::Diff::schema_diff(
    $existing->schema, $db_type, $fake->schema, $db_type
  );

  $diff = $self->_fixup_sql_diff($diff);

  # DBIx::RunSQL requires a file (ugh)
  my ($fh, $sqlfile) = File::Temp::tempfile();
  print {$fh} $diff;
  close $fh;
#  warn "*** Schema Diff:\n$diff\n"; # XXX

  $self->clear_dbis; # ensure we re-initailize handle
  unless ( $diff =~ /-- No differences found/i ) {
    DBIx::RunSQL->create(
      dbh => $self->dbh,
      sql => $sqlfile,
      verbose_handler => sub { return },
    );
    $self->dbh->disconnect;
  }

  # must reset the connection
  $self->clear_dbis;
  $self->dbis; # rebuild

#  my ($count) = $self->dbis->query(qq{select count(*) from "core"})->list;
#  warn "Initialized with $count records";
  return;
}

1;


# vim: ts=2 sts=2 sw=2 et:

__END__

=pod

=encoding UTF-8

=head1 NAME

Metabase::Backend::SQL - Metabase backend role for SQL-based backends

=head1 VERSION

version 1.001

=head1 SYNOPSIS

  # SQLite

  require Metabase::Archive::SQLite;
  require Metabase::Index::SQLite;

  my $archive = Metabase::Archive::SQLite->new(
    filename => $sqlite_file,
  );

  my $index = Metabase::Index::SQLite->new(
    filename => $sqlite_file,
  );

  # PostgreSQL

  use Metabase::Archive::PostgreSQL;
  use Metabase::Index::PostgreSQL;

  my $archive = Metabase::Archive::PostgreSQL->new(
    db_name => "cpantesters",
    db_user => "johndoe",
    db_pass => "PaSsWoRd",
  );

  my $index = Metabase::Index::PostgreSQL->new(
    db_name => "cpantesters",
    db_user => "johndoe",
    db_pass => "PaSsWoRd",
  );

=head1 DESCRIPTION

This distribution contains implementations of L<Metabase::Archive> and
L<Metabase::Index> using SQL databases.  >See L<Metabase::Backend::SQLite> or
L<Metabase::Backend::PostgreSQL> for details about specific implementations.

The main module, itself, is merely a Moose role that provides common attributes
for all the SQL-based Metabase backends.  It is not intended to be used
directly by end-users.

=head1 ATTRIBUTES

=head2 dsn

Database connection string

=head2 db_user

Database username

=head2 db_pass

Database password

=head2 db_type

SQL::Translator sub-type for a given database.  E.g. "SQLite" or "PostgreSQL".

=head2 dbis

DBIx::Simple class connected to the database

=head2 schema

SQL::Translator::Schema class

=for Pod::Coverage method_names_here

=head1 REQUIRED METHODS

The following builders must be provided by consuming classes.

  _build_dsn        # a DSN string for DBI
  _build_db_user    # a username for DBI
  _build_db_pass    # a password for DBI
  _build_db_type    # a SQL::Translator type for the DB vendor

The following method must be provided to modify the output of
SQL::Translator::Diff to fix up any dialect quirks

  _fixup_sql_diff

=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan

=head1 SUPPORT

=head2 Bugs / Feature Requests

Please report any bugs or feature requests through the issue tracker
at L<https://github.com/dagolden/metabase-backend-sql/issues>.
You will be notified automatically of any progress on your issue.

=head2 Source Code

This is open source software.  The code repository is available for
public review and contribution under the terms of the license.

L<https://github.com/dagolden/metabase-backend-sql>

  git clone https://github.com/dagolden/metabase-backend-sql.git

=head1 AUTHORS

=over 4

=item *

David Golden <[e-mail]>

=item *

Leon Brocard <[e-mail]>

=back

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2011 by David Golden.

This is free software, licensed under:

  The Apache License, Version 2.0, January 2004

=cut