view release on metacpan or  search on metacpan

lib/Database/Abstraction.pm  view on Meta::CPAN

		$self->_debug("read in $table from SQLite $slurp_file");
		$self->{'type'} = 'DBI';
	} elsif($deep_file) {
		# DBM::Deep file (.dbm or .deep) — slurp the entire tied hash into a plain
		# Perl hash so all existing in-memory fast-paths work without modification.
		require DBM::Deep;
		my $deep = DBM::Deep->new({ file => $deep_file, read_only => 1 });
		my $id = $self->{'id'};
		if($self->{'no_entry'}) {
			# Not keyed — produce an ordered arrayref of row hashrefs, same as CSV no_entry.
			my @data;
			for my $k (sort keys %{$deep}) {
				my $row = $deep->{$k};
				# Use reftype (not ref) so blessed DBM::Deep::Hash objects are recognised.
				# Inject the outer key as the id column so criteria on that column work.
				push @data, (Scalar::Util::reftype($row) // '') eq 'HASH'
					? { $id => $k, %{$row} }
					: { $id => $k, value => $row };
			}
			$self->{'data'} = @data ? \@data : undef;
		} else {
			# Keyed on the primary-key column (default: 'entry') for O(1) lookups.
			# Each row hash must contain the id column (like CSV rows), so that
			# selectall_arrayref and AUTOLOAD can access it by name.
			my %data;
			for my $k (keys %{$deep}) {
				my $row = $deep->{$k};
				$data{$k} = (Scalar::Util::reftype($row) // '') eq 'HASH'
					? { $id => $k, %{$row} }
					: { $id => $k, value => $row };
			}
			$self->{'data'} = %data ? \%data : undef;
		}
		$slurp_file = $deep_file;
		$self->_debug("read in $table from DBM::Deep $deep_file");
		$self->{'type'} = 'Deep';
	} elsif($self->_is_berkeley_db(File::Spec->catfile($dir, "$dbname.db"))) {
		$self->_debug("$table is a BerkeleyDB file");
		$self->{'type'} = 'BerkeleyDB';
	} else {
		my $fin;
		# File::pfopen splits $path on ':' which breaks Windows drive letters
		# (C:\foo becomes ['C', '\foo']).  Since we always have a single directory
		# we use File::Spec->catfile directly — same behaviour, portable.
		my $gz_file;
		for my $ext (qw(csv.gz db.gz)) {
			my $candidate = File::Spec->catfile($dir, "$dbname.$ext");
			next unless -r $candidate;
			open($fin, '<', $candidate);
			$gz_file = $candidate;
			last;
		}
		if($gz_file) {
			require Gzip::Faster;

			close($fin);
			$fin = File::Temp->new(SUFFIX => '.csv', UNLINK => 1);
			print $fin Gzip::Faster::gunzip_file($gz_file);
			$fin->flush();
			$slurp_file = $fin->filename();
			$self->{'_temp_fh'} = $fin;	# Keep object alive; auto-unlinks at DESTROY
		} else {
			my $psv = File::Spec->catfile($dir, "$dbname.psv");
			if(-r $psv) {
				open($fin, '<', $psv);
				# Pipe separated file
				$slurp_file = $psv;
				$params->{'sep_char'} = '|';
			} else {
				# CSV or BerkeleyDB-extension file
				for my $ext (qw(csv db)) {
					my $candidate = File::Spec->catfile($dir, "$dbname.$ext");
					next unless -r $candidate;
					open($fin, '<', $candidate);
					$slurp_file = $candidate;
					last;
				}
			}
		}
		if(my $filename = $self->{'filename'} || $defaults{'filename'}) {
			Carp::croak(ref($self), ": unsafe filename '$filename'")
				unless $filename =~ /^[a-zA-Z0-9_.-]+$/ && $filename !~ /\.\./;
			$self->_debug("Looking for $filename in $dir");
			$slurp_file = File::Spec->catfile($dir, $filename);
		}
		if(defined($slurp_file) && (-r $slurp_file)) {
			close($fin) if(defined($fin));
			my $sep_char = $params->{'sep_char'};

			$self->_debug(__LINE__, ' of ', __PACKAGE__, ": slurp_file = $slurp_file, sep_char = $sep_char");

			if($params->{'column_names'}) {
				$dbh = DBI->connect("dbi:CSV:db_name=$slurp_file", undef, undef,
					{
						csv_sep_char => $sep_char,
						csv_tables => {
							$table => {
								col_names => $params->{'column_names'},
							},
						},
						f_dir      => $dir,
						RaiseError => 1,
						PrintError => 0
					}
				);
			} else {
				$dbh = DBI->connect("dbi:CSV:db_name=$slurp_file", undef, undef, { csv_sep_char => $sep_char, f_dir => $dir, RaiseError => 1 });
			}
			$dbh->{'RaiseError'} = 1;

			$self->_debug("read in $table from CSV $slurp_file");

			$dbh->{csv_tables}->{$table} = {
				allow_loose_quotes => 1,
				blank_is_undef => 1,
				empty_is_undef => 1,
				binary => 1,
				f_file => $slurp_file,
				escape_char => '\\',
				sep_char => $sep_char,
				# Don't do this, causes "Bizarre copy of HASH