view release on metacpan or  search on metacpan

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

    if (0 == $phase) {
	# f_ext should not be initialized
	# f_map is deprecated (but might return)
	$dbh->{f_dir} = Cwd::abs_path (File::Spec->curdir ());

	push @{$dbh->{sql_init_order}{90}}, "f_meta";

	# complete derived attributes, if required
	(my $drv_class = $dbh->{ImplementorClass}) =~ s/::db$//;
	my $drv_prefix = DBI->driver_prefix ($drv_class);
        if (exists $dbh->{$drv_prefix . "meta"} and !$dbh->{sql_engine_in_gofer}) {
            my $attr = $dbh->{$drv_prefix . "meta"};
            defined $dbh->{f_valid_attrs}{f_meta}
		and $dbh->{f_valid_attrs}{f_meta} = 1;

            $dbh->{f_meta} = $dbh->{$attr};
	    }
	}

    return $dbh;
    } # init_default_attributes

sub validate_FETCH_attr {
    my ($dbh, $attrib) = @_;

    $attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta";

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

sub validate_STORE_attr {
    my ($dbh, $attrib, $value) = @_;

    if ($attrib eq "f_dir" && defined $value) {
	-d $value or
	    return $dbh->set_err ($DBI::stderr, "No such directory '$value'");
	File::Spec->file_name_is_absolute ($value) or
	    $value = Cwd::abs_path ($value);
	}

    if ($attrib eq "f_ext") {
	$value eq "" || $value =~ m{^\.\w+(?:/[rR]*)?$} or
	    carp "'$value' doesn't look like a valid file extension attribute\n";
	}

    $attrib eq "f_meta" and $dbh->{sql_engine_in_gofer} and $attrib = "sql_meta";

    return $dbh->SUPER::validate_STORE_attr ($attrib, $value);
    } # validate_STORE_attr

sub get_f_versions {
    my ($dbh, $table) = @_;

    my $class = $dbh->{ImplementorClass};
    $class =~ s/::db$/::Table/;
    my $dver;
    my $dtype = "IO::File";
    eval {
	$dver = IO::File->VERSION ();

	# when we're still alive here, everything went ok - no need to check for $@
	$dtype .= " ($dver)";
	};

    my $f_encoding;
    if ($table) {
	my $meta;
	$table and (undef, $meta) = $class->get_table_meta ($dbh, $table, 1);
	$meta and $meta->{f_encoding} and $f_encoding = $meta->{f_encoding};
	} # if ($table)
    $f_encoding ||= $dbh->{f_encoding};

    $f_encoding and $dtype .= " + " . $f_encoding . " encoding";

    return sprintf "%s using %s", $dbh->{f_version}, $dtype;
    } # get_f_versions

# ====== STATEMENT =============================================================

package DBD::File::st;

use strict;
use warnings;

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

my %supported_attrs = (
    TYPE      => 1,
    PRECISION => 1,
    NULLABLE  => 1,
    );

sub FETCH {
    my ($sth, $attr) = @_;

    if ($supported_attrs{$attr}) {
	my $stmt = $sth->{sql_stmt};

	if (exists $sth->{ImplementorClass} &&
	    exists $sth->{sql_stmt} &&
	    $sth->{sql_stmt}->isa ("SQL::Statement")) {

	    # fill overall_defs unless we know
	    unless (exists $sth->{f_overall_defs} && ref $sth->{f_overall_defs}) {
		my $types = $sth->{Database}{Types};
		unless ($types) { # Fetch types only once per database
		    if (my $t = $sth->{Database}->type_info_all ()) {
			foreach my $i (1 .. $#$t) {
			    $types->{uc $t->[$i][0]}   = $t->[$i][1];
			    $types->{$t->[$i][1]} ||= uc $t->[$i][0];
			    }
			}
		    # sane defaults
		    for ([  0, ""		],
			 [  1, "CHAR"		],
			 [  4, "INTEGER"	],
			 [ 12, "VARCHAR"	],
			 ) {
			$types->{$_->[0]} ||= $_->[1];
			$types->{$_->[1]} ||= $_->[0];