File Coverage

blib/lib/DBIx/TableLoader.pm

Criterion	Covered	Total	%
statement	137	137	100.0
branch	41	44	93.1
condition	29	38	76.3
subroutine	40	40	100.0
pod	28	28	100.0
total	275	287	95.8

# vim: set ts=2 sts=2 sw=2 expandtab smarttab:
#
# This file is part of DBIx-TableLoader
#
# This software is copyright (c) 2011 by Randy Stauner.
#
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
#
use strict;
use warnings;

package DBIx::TableLoader;
# git description: v1.100-1-g8e5d9b8

our $AUTHORITY = 'cpan:RWSTAUNER';
# ABSTRACT: Easily load a database table from a data set
$DBIx::TableLoader::VERSION = '1.101';
use Carp qw(croak);
#use DBI 1.13 (); # oldest DBI on CPAN as of 2011-02-15; Has SQL_LONGVARCHAR
use Try::Tiny 0.09;


sub new {
  my $class = shift;
  my $self = bless {}, $class;

  my %opts = @_ == 1 ? %{$_[0]} : @_;

  my %defaults = (%{ $self->base_defaults }, %{ $self->defaults });
  while( my ($key, $value) = each %defaults ){
    $self->{$key} = exists($opts{$key})
      ? delete $opts{$key}
      : $value;
  }

  # be loud about typos
  croak("Unknown options: ${\join(', ', keys %opts)}")
    if %opts;

  # custom routine to handle type of input data (hook for subclasses)
  $self->prepare_data();

  # normalize 'columns' attribute
  $self->determine_column_types();

  return $self;
}


sub base_defaults {
  return {
    catalog              => undef,
    columns              => undef,
    create               => 1,
    create_prefix        => '',
    create_sql           => '',
    create_suffix        => '',
    # 'data' attribute may not be useful in subclasses
    data                 => undef,
    dbh                  => undef,
    default_column_type  => '',
    default_sql_data_type => '',
    drop                 => 0,
    drop_prefix          => '',
    drop_sql             => '',
    drop_suffix          => '',
    get_row              => undef,
    grep_rows            => undef,
    handle_invalid_row   => undef,
    map_rows             => undef,
    # default_name() method will default to 'data' if 'name' is blank
    # this way subclasses don't have to override this value in defaults()
    name                 => '',
    name_prefix          => '',
    name_suffix          => '',
    quoted_name          => undef,
    schema               => undef,
    table_type           => '', # TEMP, TEMPORARY, VIRTUAL?
    transaction          => 1,
  };
}


sub defaults {
  return {};
}


sub columns {
  my ($self) = @_;
  # by default the column names are found in the first row of the data
  # (but circumvent get_row() to avoid any grep or map subs)
  return $self->{columns} ||= $self->_get_custom_or_raw_row();
}


sub column_names {
  my ($self) = @_;
  # return the first element of each arrayref
  return [ map { $$_[0] } @{ $self->columns } ];
}


sub create {
  my ($self) = @_;
  $self->{dbh}->do($self->create_sql);
}


sub create_prefix {
  my ($self) = @_;
  return $self->{create_prefix} ||=
    "CREATE $self->{table_type} TABLE " .
      $self->quoted_name . " (";
}


sub create_sql {
  my ($self) = @_;
  $self->{create_sql} ||=
    join(' ',
      $self->create_prefix,

      # column definitions (each element is: [name, data_type])
      join(', ', map {
        $self->{dbh}->quote_identifier($_->[0]) . ' ' . $_->[1]
      } @{ $self->columns }),

      $self->create_suffix
    );
}


sub create_suffix {
  my ($self) = @_;
  return $self->{create_suffix} ||=
    ')';
}

# ask the driver what data type it uses for the desired SQL standard type

sub _data_type_from_driver {
  my ($self, $data_type) = @_;
  if( my $type = $self->{dbh}->type_info($data_type) ){
    return $type->{TYPE_NAME};
  }
  return;
}


sub default_name {
  return 'data';
}


sub default_column_type {
  my ($self) = @_;
  return $self->{default_column_type} ||= try {
    $self->_data_type_from_driver($self->default_sql_data_type);
  }
    # outside the eval in case there was an error
    || 'text';
}


sub default_sql_data_type {
  my ($self) = @_;
  $self->{default_sql_data_type} ||= try {
    # if this doesn't work default_column_type will just use 'text'
    require DBI;
    DBI::SQL_LONGVARCHAR();
  };
}


sub determine_column_types {
  my ($self) = @_;
  my ($columns, $type) = ($self->columns, $self->default_column_type);

  croak("Unable to determine columns!")
    unless $columns && @$columns;

  # break reference
  $columns = [@$columns];

  # reset each element to an arrayref if it isn't already
  foreach my $column ( @$columns ){
    # upgrade lone string to arrayref otherwise break reference
    $column = ref $column ? [@$column] : [$column];
    # append column type if missing
    push(@$column, $type)
      unless @$column > 1;
  }

  # restore changes
  $self->{columns} = $columns;
  return;
}


sub drop {
  my ($self) = @_;
  $self->{dbh}->do($self->drop_sql);
}


sub drop_prefix {
  my ($self) = @_;
  # default to "DROP TABLE" since SQLite, PostgreSQL, and MySQL
  # all accept it (rather than "DROP $table_type TABLE")
  $self->{drop_prefix} ||= 'DROP TABLE';
}


sub drop_sql {
  my ($self) = @_;
  return $self->{drop_sql} ||= join(' ',
    $self->drop_prefix,
    $self->quoted_name,
    $self->drop_suffix,
  );
}


sub drop_suffix {
  my ($self) = @_;
  # default is blank
  return $self->{drop_suffix};
}

# call get_raw_row unless a custom 'get_row' is defined
# (this is the essence of get_row() but without the grep/map subs)

sub _get_custom_or_raw_row {
  my ($self) = @_;
  # considered { $self->{get_row} ||= $self->can('get_raw_row'); } in new()
  # but it just seemed a little strange... this is more normal/clear
  return $self->{get_row}
       ? $self->{get_row}->($self)
       : $self->get_raw_row();
}


sub get_raw_row {
  my ($self) = @_;
  # It would be simpler to shift the data but I don't think it actually
  # gains us anything.  This way we're not modifying anything unexpectedly.
  # Besides subclasses will likely be more useful than this one.
  return $self->{data}->[ $self->{row_index}++ ];
}


sub get_row {
  my ($self) = @_;
  my $row;

  GETROW: {
    $row = $self->_get_custom_or_raw_row()
      or last GETROW;

    # call grep_rows with the same semantics as map_rows (below)
    if( $self->{grep_rows} ){
      local $_ = $row;
      # if grep returns false try the block again
      redo GETROW
        unless $self->{grep_rows}->($row, $self);
    }

    # Send the row first since it's the important part.
    # This isn't a method call, and $self will likely be seldom used.
    if( $self->{map_rows} ){
      # localize $_ to the $row for consistency with the built in map()
      local $_ = $row;
      # also pass row as the first argument to simulate a normal function call
      $row = $self->{map_rows}->($row, $self);
    }

    # validate the row before passing a bad value to the DBI
    $row = try {
      $self->validate_row($row);
    }
    catch {
      # file/line position is unhelpful, but so is the newline
      chomp(my $e = $_[0]);
      # if there was an error, pass it through the handler
      # the handler should die, return a row, or return false to skip
      $self->handle_invalid_row($e, $row);
    }
      or redo GETROW;
  }

  return $row;
}


sub handle_invalid_row {
  my ($self, $error, $row) = @_;

  if( my $handler = $self->{handle_invalid_row} ){
    # should this be croak/carp?
    if( $handler eq 'die' ){
      die $error . "\n";
    }
    elsif( $handler eq 'warn' ){
      warn $error . "\n";
      return $row;
    }
    # otherwise it should be a coderef (or a method name (for a subclass maybe))
    else {
      return $self->$handler($error, $row);
    }
  }

  # pass through if no handler was defined
  return $row;
}


sub insert_sql {
  my ($self) = @_;
  join(' ',
    'INSERT INTO',
    $self->quoted_name,
    '(',
      join(', ', @{ $self->quoted_column_names } ),
    ')',
    'VALUES(',
      join(', ', ('?') x @{ $self->columns }),
    ')'
  );
}


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

  my $rows = 0;
  my $sth = $self->{dbh}->prepare($self->insert_sql);
  while( my $row = $self->get_row() ){
    $sth->execute(@$row);
    ++$rows;
  }

  return $rows;
}


sub load {
  my ($self) = @_;
  my $rows;

  # is it appropriate/sufficient to call prepare_data() from new()?

  try {

  $self->{dbh}->begin_work()
    if $self->{transaction};

  $self->drop()
    if $self->{drop};

  $self->create()
    if $self->{create};

    $rows = $self->insert_all();

  $self->{dbh}->commit()
    if $self->{transaction};

  }
  catch {
    # explicitly end the transaction that we started
    # in case this isn't the last thing being done with the dbh
    $self->{dbh}->rollback()
      if $self->{transaction};

    # propagate the exception
    die $_[0];
  };

  return $rows;
}


sub name {
  my ($self) = @_;
  return $self->{_name} ||=
    $self->{name_prefix} .
    ($self->{name} || $self->default_name) .
    $self->{name_suffix};
}


sub prepare_data {
  my ($self) = @_;
  $self->{row_index} = 0;
}


sub quoted_name {
  my ($self) = @_;
  # allow quoted name to be passed in to handle edge cases
  return $self->{quoted_name} ||=
    $self->{dbh}->quote_identifier(
      $self->{catalog}, $self->{schema}, $self->name);
}


sub quoted_column_names {
  my ($self) = @_;
  return $self->{quoted_column_names} ||= [
    map { $self->{dbh}->quote_identifier($_) }
      @{ $self->column_names }
  ];
}


sub validate_row {
  my ($self, $row) = @_;

  # DBI will croak if exec'd with different numbers
  my $num_columns = @{ $self->columns };

  die 'Row has ' . @$row . ' fields when ' .  $num_columns . " are expected\n"
    if @$row != $num_columns;

  # are there other validation checks we can do?

  return $row;
}

1;

__END__