view release on metacpan or  search on metacpan

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

    # their own caching, so caching here just provides extra safety.
    $drh->{$class} and return $drh->{$class};

    $attr ||= {};
    {	no strict "refs";
	unless ($attr->{Attribution}) {
	    $class eq "DBD::File" and
		$attr->{Attribution} = "$class by Jeff Zucker";
	    $attr->{Attribution} ||= ${$class . "::ATTRIBUTION"} ||
		"oops the author of $class forgot to define this";
	    }
	$attr->{Version} ||= ${$class . "::VERSION"};
	$attr->{Name} or ($attr->{Name} = $class) =~ s/^DBD\:\://;
	}

    $drh->{$class} = $class->SUPER::driver ($attr);

    # XXX inject DBD::XXX::Statement unless exists

    return $drh->{$class};
    } # driver

sub CLONE {
    undef $drh;
    } # CLONE

# ====== DRIVER ================================================================

package DBD::File::dr;

use strict;
use warnings;

use Carp;

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

sub dsn_quote {
    my $str = shift;
    ref     $str and return "";
    defined $str or  return "";
    $str =~ s/([;:\\])/\\$1/g;
    return $str;
    } # dsn_quote

# XXX rewrite using TableConfig ...
sub default_table_source { "DBD::File::TableSource::FileSystem" }

sub connect {
    my ($drh, $dbname, $user, $auth, $attr) = @_;

    # We do not (yet) care about conflicting attributes here
    # my $dbh = DBI->connect ("dbi:CSV:f_dir=test", undef, undef, { f_dir => "text" });
    # will test here that both test and text should exist
    #
    # Parsing on our own similar to parse_dsn to find attributes in 'dbname' parameter.
    if ($dbname) {
	my $attr_hash = {
	    map { (m/^\s* (\S+) \s*(?: =>? | , )\s* (\S*) \s*$/x) }
	    split m/;/ => $dbname };
	if (defined $attr_hash->{f_dir}) {
	    my $f_dir = $attr_hash->{f_dir};
	    # DSN escapes the : in Windows' path, which is not accepted by -d
	    #   D\\:\\\\Test\\\\DBI-01\\\\test_output_12345
	    # ->  D:\\\\Test\\\\DBI-01\\\\test_output_12345
	    $^O eq "MSWin32" and $f_dir =~ s{^([a-zA-Z])\\+:}{$1:};
	    unless (-d $f_dir) {
		my $msg = "No such directory '$attr_hash->{f_dir}";
		$drh->set_err (2, $msg);
		$attr_hash->{RaiseError} and croak $msg;
		return;
		}
	    }
	}
    if ($attr and defined $attr->{f_dir}) {
	my $f_dir = $attr->{f_dir};
	$^O eq "MSWin32" and $f_dir =~ s{^([a-zA-Z])\\+:}{$1:};
	unless (-d $f_dir) {
	    my $msg = "No such directory '$attr->{f_dir}";
	    $drh->set_err (2, $msg);
	    return;
	    }
	}

    return $drh->SUPER::connect ($dbname, $user, $auth, $attr);
    } # connect

sub disconnect_all {
    } # disconnect_all

sub DESTROY {
    undef;
    } # DESTROY

# ====== DATABASE ==============================================================

package DBD::File::db;

use strict;
use warnings;

use Carp;
require File::Spec;
require Cwd;
use Scalar::Util qw( refaddr ); # in CORE since 5.7.3

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

sub data_sources {
    my ($dbh, $attr, @other) = @_;
    ref ($attr) eq "HASH" or $attr = {};
    exists $attr->{f_dir}        or $attr->{f_dir}        = $dbh->{f_dir};
    exists $attr->{f_dir_search} or $attr->{f_dir_search} = $dbh->{f_dir_search};
    return $dbh->SUPER::data_sources ($attr, @other);
    } # data_source

sub set_versions {
    my $dbh = shift;
    $dbh->{f_version} = $DBD::File::VERSION;

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

	binmode $meta->{fh} or croak "Failed to set binary mode on $fn: $!";
	}
    } # apply_encoding

sub open_data {
    my ($self, $meta, $attrs, $flags) = @_;

    $flags->{dropMode} and croak "Can't drop a table in stream";
    my $fn = "file handle " . fileno ($meta->{f_file});

    if ($flags->{createMode} || $flags->{lockMode}) {
	$meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "w+") or
	    croak "Cannot open $fn for writing: $! (" . ($!+0) . ")";
	}
    else {
	$meta->{fh} = IO::Handle->new_from_fd (fileno ($meta->{f_file}), "r") or
	    croak "Cannot open $fn for reading: $! (" . ($!+0) . ")";
	}

    if ($meta->{fh}) {
	$self->apply_encoding ($meta, $fn);
	} # have $meta->{$fh}

    if ($self->can_flock && $meta->{fh}) {
	my $lm = defined $flags->{f_lock}
		      && $flags->{f_lock} =~ m/^[012]$/
		       ? $flags->{f_lock}
		       : $flags->{lockMode} ? 2 : 1;
	if ($lm == 2) {
	    flock $meta->{fh}, 2 or croak "Cannot obtain exclusive lock on $fn: $!";
	    }
	elsif ($lm == 1) {
	    flock $meta->{fh}, 1 or croak "Cannot obtain shared lock on $fn: $!";
	    }
	# $lm = 0 is forced no locking at all
	}
    } # open_data

sub can_flock { $locking }

package DBD::File::DataSource::File;

use strict;
use warnings;

our @ISA = "DBD::File::DataSource::Stream";

use Carp;
require List::Util;

my $fn_any_ext_regex = qr/\.[^.]*/;

sub complete_table_name {
    my ($self, $meta, $file, $respect_case, $file_is_table) = @_;

    $file eq "." || $file eq ".."	and return; # XXX would break a possible DBD::Dir

    # XXX now called without proving f_fqfn first ...
    my ($ext, $req) = ("", 0);
    if ($meta->{f_ext}) {
	($ext, my $opt) = split m{/}, $meta->{f_ext};
	if ($ext && $opt) {
	    $opt =~ m/r/i and $req = 1;
	    }
	}

    # (my $tbl = $file) =~ s/\Q$ext\E$//i;
    my ($tbl, $basename, $dir, $fn_ext, $user_spec_file, $searchdir);
    if ($file_is_table and defined $meta->{f_file}) {
	$tbl = $file;
	($basename, $dir, $fn_ext) = File::Basename::fileparse ($meta->{f_file}, $fn_any_ext_regex);
	$file = $basename . $fn_ext;
	$user_spec_file = 1;
	}
    else {
	($basename, $dir, undef) = File::Basename::fileparse ($file, qr{\Q$ext\E});
	# $dir is returned with trailing (back)slash. We just need to check
	# if it is ".", "./", or ".\" or "[]" (VMS)
	if ($dir =~ m{^(?:[.][/\\]?|\[\])$} && ref $meta->{f_dir_search} eq "ARRAY") {
	    foreach my $d ($meta->{f_dir}, @{$meta->{f_dir_search}}) {
		my $f = File::Spec->catdir ($d, $file);
		-f $f or next;
		$searchdir = Cwd::abs_path ($d);
		$dir = "";
		last;
		}
	    }
	$file = $tbl = $basename;
	$user_spec_file = 0;
	}

    if (!$respect_case and $meta->{sql_identifier_case} == 1) { # XXX SQL_IC_UPPER
        $basename = uc $basename;
        $tbl = uc $tbl;
	}
    elsif (!$respect_case and $meta->{sql_identifier_case} == 2) { # XXX SQL_IC_LOWER
        $basename = lc $basename;
        $tbl = lc $tbl;
	}

    unless (defined $searchdir) {
	$searchdir = File::Spec->file_name_is_absolute ($dir)
	    ? ($dir =~ s{/$}{}, $dir)
	    : Cwd::abs_path (File::Spec->catdir ($meta->{f_dir}, $dir));
	}
    -d $searchdir or
	croak "-d $searchdir: $!";

    # If the file location is outside the current folder,
    # its absolute path should be in ($f_dir, @f_dir_search)
    # Note this triggers only when *used*, not at definition time
    #   $dbh->{csv_tables}{foo}{file} = "/out/side/scope/foo.csv"; # OK
    #   $dbh->do ("create table foo (c char)"); # FAIL
    {   my @sd = map { Cwd::abs_path ($_) } $meta->{f_dir}, @{$meta->{f_dir_search} || []};
	unless (List::Util::first { $_ eq $searchdir } @sd) {
	    croak "Using data files in $searchdir is unsafe and not allowed.\nUse f_dir or f_dir_search.\n";
	    }
	}

    $searchdir eq $meta->{f_dir} and
	$dir = "";