File Coverage

blib/lib/DBD/CSV.pm

Criterion	Covered	Total	%
statement	207	218	94.9
branch	78	110	70.9
condition	25	41	60.9
subroutine	31	32	96.8
pod			n/a
total	341	401	85.0

#!/usr/bin/perl
#
#   DBD::CSV - A DBI driver for CSV and similar structured files
#
#   This module is currently maintained by
#
#	H.Merijn Brand
#
#   See for full acknowledgements the last two pod sections in this file

use strict;
use warnings;

require DynaLoader;
require DBD::File;
require IO::File;

our @f_SHORT = qw( class file dir dir_search ext lock lockfile schema encoding );
our @c_SHORT = qw( eof
	eol sep_char quote_char escape_char binary decode_utf8 auto_diag
	diag_verbose blank_is_undef empty_is_undef allow_whitespace
	allow_loose_quotes allow_loose_escapes allow_unquoted_escape
	always_quote quote_empty quote_space escape_null quote_binary
	keep_meta_info callbacks );

package DBD::CSV;

use strict;

use vars qw( @ISA $VERSION $ATTRIBUTION $drh $err $errstr $sqlstate );

@ISA =   qw( DBD::File );

$VERSION     = "0.60";
$ATTRIBUTION = "DBD::CSV $DBD::CSV::VERSION by H.Merijn Brand";

$err      = 0;		# holds error code   for DBI::err
$errstr   = "";		# holds error string for DBI::errstr
$sqlstate = "";         # holds error state  for DBI::state
$drh      = undef;	# holds driver handle once initialized

sub CLONE {		# empty method: prevent warnings when threads are cloned
    } # CLONE

# --- DRIVER -------------------------------------------------------------------

package DBD::CSV::dr;

use strict;

use Text::CSV_XS ();
use vars qw( @ISA @CSV_TYPES );

@CSV_TYPES = (
    Text::CSV_XS::IV (), # SQL_TINYINT
    Text::CSV_XS::IV (), # SQL_BIGINT
    Text::CSV_XS::PV (), # SQL_LONGVARBINARY
    Text::CSV_XS::PV (), # SQL_VARBINARY
    Text::CSV_XS::PV (), # SQL_BINARY
    Text::CSV_XS::PV (), # SQL_LONGVARCHAR
    Text::CSV_XS::PV (), # SQL_ALL_TYPES
    Text::CSV_XS::PV (), # SQL_CHAR
    Text::CSV_XS::NV (), # SQL_NUMERIC
    Text::CSV_XS::NV (), # SQL_DECIMAL
    Text::CSV_XS::IV (), # SQL_INTEGER
    Text::CSV_XS::IV (), # SQL_SMALLINT
    Text::CSV_XS::NV (), # SQL_FLOAT
    Text::CSV_XS::NV (), # SQL_REAL
    Text::CSV_XS::NV (), # SQL_DOUBLE
    );

our @ISA = qw( DBD::File::dr );

our $imp_data_size     = 0;
our $data_sources_attr = undef;

sub connect {
    my ($drh, $dbname, $user, $auth, $attr) = @_;
    if ($attr && ref $attr eq "HASH") {
	# Top-level aliasses
	foreach my $key (grep { exists $attr->{$_} } @f_SHORT) {
	    my $f_key = "f_$key";
	    exists $attr->{$f_key} and next;
	    $attr->{$f_key} = delete $attr->{$key};
	    }
	foreach my $key (grep { exists $attr->{$_} } @c_SHORT) {
	    my $c_key = "csv_$key";
	    exists $attr->{$c_key} and next;
	    $attr->{$c_key} = delete $attr->{$key};
	    }
	}

    my $dbh = $drh->DBD::File::dr::connect ($dbname, $user, $auth, $attr);
    $dbh and $dbh->{Active} = 1;
    $dbh;
    } # connect

# --- DATABASE -----------------------------------------------------------------

package DBD::CSV::db;

use strict;

our $imp_data_size = 0;
our @ISA = qw( DBD::File::db );

sub set_versions {
    my $this = shift;
    $this->{csv_version} = $DBD::CSV::VERSION;
    return $this->SUPER::set_versions ();
    } # set_versions

my %csv_xs_attr;

sub init_valid_attributes {
    my $dbh = shift;

    # Straight from Text::CSV_XS.pm
    my @xs_attr = @c_SHORT;
    @csv_xs_attr{@xs_attr} = ();
    # Dynamically add "new" attributes - available in Text::CSV_XS-1.20
    if (my @ka = eval { Text::CSV_XS->known_attributes }) {
	for (grep { m/^[a-su-z]/ && !exists $csv_xs_attr{$_} } @ka) {
	    push @xs_attr => $_;
	    $csv_xs_attr{$_} = undef;
	    }
	};

    $dbh->{csv_xs_valid_attrs} = [ @xs_attr ];

    $dbh->{csv_valid_attrs} = { map {("csv_$_" => 1 )} @xs_attr, qw(

	class tables in csv_in out csv_out skip_first_row

	null sep quote escape bom
	)};

    $dbh->{csv_readonly_attrs} = { };

    $dbh->{csv_meta} = "csv_tables";

    return $dbh->SUPER::init_valid_attributes ();
    } # init_valid_attributes

sub get_csv_versions {
    my ($dbh, $table) = @_;
    $table ||= "";
    my $class = $dbh->{ImplementorClass};
    $class =~ s/::db$/::Table/;
    my $meta;
    $table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
    unless ($meta) {
	$meta = {};
	$class->bootstrap_table_meta ($dbh, $meta, $table);
	}
    my $dvsn  = eval { $meta->{csv_class}->VERSION (); };
    my $dtype = $meta->{csv_class};
    $dvsn and $dtype .= " ($dvsn)";
    return sprintf "%s using %s", $dbh->{csv_version}, $dtype;
    } # get_csv_versions

sub get_info {
    my ($dbh, $info_type) = @_;
    require  DBD::CSV::GetInfo;
    my $v = $DBD::CSV::GetInfo::info{int ($info_type)};
    ref $v eq "CODE" and $v = $v->($dbh);
    return $v;
    } # get_info

sub type_info_all {
#   my $dbh = shift;
    require   DBD::CSV::TypeInfo;
    return [@$DBD::CSV::TypeInfo::type_info_all];
    } # type_info_all

# --- STATEMENT ----------------------------------------------------------------

package DBD::CSV::st;

use strict;

our $imp_data_size = 0;
our @ISA = qw( DBD::File::st );

package DBD::CSV::Statement;

use strict;
use Carp;

our @ISA = qw( DBD::File::Statement );

package DBD::CSV::Table;

use strict;
use Carp;

our @ISA = qw( DBD::File::Table );

my %compat_map;

{   my %class_mapped;

    sub _register_compat_map {
	my $class = shift;

	my $x = 0;
	if (!%compat_map) {
	    $compat_map{$_} = "f_$_"   for @f_SHORT;
	    $compat_map{$_} = "csv_$_" for @c_SHORT;
	    $x++;
	    }
	if ($class and !$class_mapped{$class}++ and
		my @ka = eval { $class->known_attributes }) {
	    # exclude types
	    $compat_map{$_} = "csv_$_" for grep m/^[a-su-z]/ => @ka;
	    $x++;
	    }
	if ($x) {
	    __PACKAGE__->register_compat_map (\%compat_map);
	    }
	} # _register_compat_map
    }

#sub DESTROY {
#    my $self = shift or return;
#
#    $self->{meta} and delete $self->{meta}{csv_in};
#    } # DESTROY

sub bootstrap_table_meta {
    my ($self, $dbh, $meta, $table) = @_;
    $meta->{csv_class} ||= $dbh->{csv_class} || "Text::CSV_XS";
    $meta->{csv_eol}   ||= $dbh->{csv_eol}   || "\r\n";

    _register_compat_map ($meta->{csv_class});

    exists $meta->{csv_skip_first_row} or
	$meta->{csv_skip_first_row} = $dbh->{csv_skip_first_row};
    exists $meta->{csv_bom} or
	$meta->{csv_bom} = exists $dbh->{bom} ? $dbh->{bom} : $dbh->{csv_bom};
    $self->SUPER::bootstrap_table_meta ($dbh, $meta, $table);
    } # bootstrap_table_meta

sub init_table_meta {
    my ($self, $dbh, $meta, $table) = @_;

    _register_compat_map ($meta->{csv_class});

    $self->SUPER::init_table_meta ($dbh, $table, $meta);

    my $csv_in = $meta->{csv_in} || $dbh->{csv_csv_in};
    unless ($csv_in) {
	my %opts = ( binary => 1, auto_diag => 1 );

	# Allow specific Text::CSV_XS options
	foreach my $attr (@{$dbh->{csv_xs_valid_attrs}}) {
	    $attr eq "eol" and next; # Handles below
	    exists $dbh->{"csv_$attr"} and $opts{$attr} = $dbh->{"csv_$attr"};
	    }
	$dbh->{csv_null} || $meta->{csv_null} and
	    $opts{Text::CSV_XS->version < 1.18 ? "always_quote" : "quote_empty"} =
	    $opts{blank_is_undef} = 1;

	my $class = $meta->{csv_class};
	my $eol   = $meta->{csv_eol};
	$eol =~ m/^\A(?:[\r\n]|\r\n)\Z/ or $opts{eol} = $eol;
	for ([ "sep",    ',' ],
	     [ "quote",  '"' ],
	     [ "escape", '"' ],
	     ) {
	    my ($attr, $def) = ($_->[0]."_char", $_->[1]);
	    $opts{$attr} =
		exists $meta->{$attr} ? $meta->{$attr} :
		    exists $dbh->{"csv_$attr"} ? $dbh->{"csv_$attr"} : $def;
	    }
	$meta->{csv_in}  = $class->new (\%opts) or
	    $class->error_diag;
	$opts{eol} = $eol;
	$meta->{csv_out} = $class->new (\%opts) or
	    $class->error_diag;
	}
    } # init_table_meta

sub table_meta_attr_changed {
    my ($class, $meta, $attr, $value) = @_;

    _register_compat_map ($meta->{csv_class});

    (my $csv_attr = $attr) =~ s/^csv_//;
    if (exists $csv_xs_attr{$csv_attr}) {
	for ("csv_in", "csv_out") {
	    exists $meta->{$_} && exists $meta->{$_}{$csv_attr} and
		$meta->{$_}{$csv_attr} = $value;
	    }
	}

    $class->SUPER::table_meta_attr_changed ($meta, $attr, $value);
    } # table_meta_attr_changed

sub open_data {
    my ($self, $meta, $attrs, $flags) = @_;
    $self->SUPER::open_file ($meta, $attrs, $flags);

    if ($meta && $meta->{fh}) {
	$attrs->{csv_csv_in}  = $meta->{csv_in};
	$attrs->{csv_csv_out} = $meta->{csv_out};
	if (my $types = $meta->{types}) {
	    # XXX $meta->{types} is nowhere assigned and should better $meta->{csv_types}
	    # The 'types' array contains DBI types, but we need types
	    # suitable for Text::CSV_XS.
	    my $t = [];
	    for (@{$types}) {
		$_ = $_
		    ? $DBD::CSV::dr::CSV_TYPES[$_ + 6] || Text::CSV_XS::PV ()
		    : Text::CSV_XS::PV ();
		push @$t, $_;
		}
	    $meta->{types} = $t;
	    }
	if (!$flags->{createMode}) {
	    my $array;
	    my $skipRows = defined $meta->{skip_rows}
		? $meta->{skip_rows}
		: defined $meta->{csv_skip_first_row}
		    ? 1
		    : exists $meta->{col_names} ? 0 : 1;
	    defined $meta->{skip_rows} or
		$meta->{skip_rows} = $skipRows;
	    if ($meta->{csv_bom}) {
		my @hdr = $attrs->{csv_csv_in}->header ($meta->{fh}) or
		    croak "Failed using the header row: ".$attrs->{csv_csv_in}->error_diag;
		$meta->{col_names} ||= \@hdr;
		$skipRows and $skipRows = 0;
		}
	    if ($skipRows--) {
		$array = $attrs->{csv_csv_in}->getline ($meta->{fh}) or
		    croak "Missing first row due to ".$attrs->{csv_csv_in}->error_diag;
		unless ($meta->{raw_header}) {
		    s/\W/_/g for @$array;
		    }
		defined $meta->{col_names} or
		    $meta->{col_names} = $array;
		while ($skipRows--) {
		    $attrs->{csv_csv_in}->getline ($meta->{fh});
		    }
		}
	    # lockMode is set 1 for DELETE, INSERT or UPDATE
	    # no other case need seeking
	    $flags->{lockMode} and # $meta->{fh}->can ("tell") and
		$meta->{first_row_pos} = $meta->{fh}->tell ();
	    exists $meta->{col_names} and
		$array = $meta->{col_names};
	    if (!$meta->{col_names} || !@{$meta->{col_names}}) {
		# No column names given; fetch first row and create default
		# names.
		my $ar = $meta->{cached_row} =
		    $attrs->{csv_csv_in}->getline ($meta->{fh});
		$array = $meta->{col_names};
		push @$array, map { "col$_" } 0 .. $#$ar;
		}
	    }
	}
    } # open_file

no warnings 'once';
$DBI::VERSION < 1.623 and
    *open_file = \&open_data;
use warnings;

sub _csv_diag {
    my @diag = $_[0]->error_diag;
    for (2, 3) {
	defined $diag[$_] or $diag[$_] = "?";
	}
    return @diag;
    } # _csv_diag

sub fetch_row {
    my ($self, $data) = @_;

    my $tbl = $self->{meta};

    exists $tbl->{cached_row} and
	return $self->{row} = delete $tbl->{cached_row};

    my $csv = $self->{csv_csv_in} or
	return do { $data->set_err ($DBI::stderr, "Fetch from undefined handle"); undef };

    my $fields = eval { $csv->getline ($tbl->{fh}) };
    unless ($fields) {
	$csv->eof and return;

	my @diag = _csv_diag ($csv);
	$diag[0] == 2012 and return; # Also EOF (broken in Text::CSV_XS-1.10)

	my $file = $tbl->{f_fqfn};
	croak "Error $diag[0] while reading file $file: $diag[1] \@ line $diag[3] pos $diag[2]";
	}
    @$fields < @{$tbl->{col_names}} and
	push @$fields, (undef) x (@{$tbl->{col_names}} - @$fields);
    $self->{row} = (@$fields ? $fields : undef);
    } # fetch_row

sub push_row {
    my ($self, $data, $fields) = @_;
    my $tbl = $self->{meta};
    my $csv = $self->{csv_csv_out};
    my $fh  = $tbl->{fh};

    unless ($csv->print ($fh, $fields)) {
	my @diag = _csv_diag ($csv);
	my $file = $tbl->{f_fqfn};
	return do { $data->set_err ($DBI::stderr,
	    "Error $diag[0] while writing file $file: $diag[1] \@ line $diag[3] pos $diag[2]"); undef };
	}
    1;
    } # push_row

no warnings 'once';
*push_names = \&push_row;
use warnings;

1;

__END__