File Coverage

lib/Fry/Lib/CDBI/Load.pm

Criterion	Covered	Total	%
statement	9	115	7.8
branch	0	28	0.0
condition	0	15	0.0
subroutine	3	19	15.7
pod	0	6	0.0
total	12	183	6.5

package Fry::Lib::CDBI::Load;
	use strict qw/subs vars/;
	our @ISA;
	#local data
	my %db_driver = (qw/mysql dbi:mysql: postgres dbi:Pg:dbname= sqlite
		dbi:SQLite:dbname=/);
	our $cdbi_class = "Class::DBI";
	our $regex_operator;
#methods
	sub _default_data {
		return {
			vars=>{
				qw/user bozo
				pwd bozo
				db postgres
				dbname useful/,
				table=>'junk',
				columns=>'',
				action_columns=>'',
				set_db_opts=>{AutoCommit=>1},
				db_default=>{
					postgres=>{
						regex=>'~',
					},
					mysql=>{
						regex=>'REGEXP',
					},
					sqlite=>{
					},

				},
				table_class=>'My::CDBI',
				#flags
				CDBI_Loader=>1,
				get_columns=>1,
			},
			opts=>{
				table=>{qw/a t type var noreset 1 default junk/,
					action=>sub {shift->Var('cmd_class')->newTable($_[0])} },
				action_columns=>{qw/a C type var noreset 1/,
					action=> sub {$_[0]->setVar(action_columns=>[$_[0]->sub->parseNum($_[1],@{$_[0]->Var('columns')})])}
				}
			},
			class=>'Class::DBI',
		}
	}
	sub _initLib {
		my $cls = shift;
		no strict 'refs';

		#should be done by tags=class attribute
		my $table_class = $cls->Var('table_class');
		$cls->sub->_require ($cdbi_class);
		push (@{"$table_class\::ISA"},$cdbi_class);

		$regex_operator = $cls->_regex_operator;

		$cls->setupCdbi;
	}

#Setup subs
	sub setupCdbi {
		my $cls = shift;

		my $table_class = $cls->Var('table_class');
		my ($dbname,$db,$user,$pwd,$set_db_opts) = $cls->varMany(qw/dbname db user pwd set_db_opts/);
		warn("Database $db doesn't have a dsn entry and thus set_db was not set up correctly")
			if (! exists $db_driver{$db});

		eval "use Class::DBI::Loader ";
		if ($Class::DBI::Loader::VERSION < 0.07) {
			$cls->view("Need at least version 0.07 for Class::DBI::Loader");
			$cls->setFlag('CDBI_Loader'=>0);

		}
		if ($@ or ! $cls->Flag('CDBI_Loader')) {

			$table_class->set_db('Main',$db_driver{$db}.$dbname,$user,$pwd,$set_db_opts);
		       	$cls->newCdbiTable;
		}
		else { $cls->initCdbiLoader }
	}
	sub newTable {
		my ($cls,$table) = @_;
		eval "require Class::DBI::Loader";
		if ($@ or ! $cls->Flag('CDBI_Loader')) {
			$cls->setVar(table=>$table);
		       	$cls->newCdbiTable;
		}
		else { $cls->initCdbiLoader(table=>$table) }
	}
	sub newCdbiTable {
		#new table info coming from var
		my $cls = shift;
		my $table_class = $cls->Var('table_class');
		$table_class->table($cls->Var('table'));

		#td: only works for 3 databases
		$cls->init_columns;

		$table_class->columns(All => @{$cls->Var('columns')});

		#td: set sequences for any db
		$table_class->sequence($cls->Var('table').'_'.$cls->Var('columns')->[0].'_seq')
			if ($cls->Var('db') eq "postgres");
	}
	sub initCdbiLoader {
		my ($cls,%arg) = @_;
		my %set = %arg;

		for (qw/pwd user db dbname table set_db_opts/) {
			$arg{$_} = $arg{$_} || $cls->Var($_)
		}

		my $loader = Class::DBI::Loader->new(
			dsn => $db_driver{$arg{db}}.$arg{dbname},
			user => $arg{user},
			password => $arg{pwd},
			options=>$arg{set_db_opts},
			#tables=>[$arg{table}],
			constraint=>"^$arg{table}\$",
			namespace => ucfirst($arg{db}),
		) or die "new CDBIL object failed: $@";

		#if new definition has been successful
		$cls->setVar(%set);

		#subclass latest shell and its fns into $tableclass
		my $table_class = $loader->find_class($arg{table});
		$cls->setVar(table_class=>$table_class);

		#hack: each Class::DBI::* loaded table first has cdbi subclass + then class::db::*
		#as parents
		{ no strict 'refs';
		my $tc = $cls->Var('table_class');
		unshift(@{"$tc\::ISA"},'My::CDBI');
		}

		#hack: don't pass existing columns b/c they're out of order
		$cls->init_columns;  #(columns=>[map {$_->name} $table_class->columns('All')]);
	}
#Internal subs
	sub _regex_operator {
		$_[0]->Var('db_default')->{$_[0]->Var('db')}->{regex} || "LIKE"
	}
	sub dbiSource {
		my $cls = shift;
		my ($db,$dbname,$user,$pwd) = $cls->varMany(qw/db dbname user pwd/);
		return ($db_driver{$db}.$dbname,$user,$pwd);
	}
	sub init_columns {
		#d: initializes column data dependent &columns
		my ($cls,%arg) = @_;
		my $db = $arg{db} || $cls->Var('db');
		my $table = $arg{table} || $cls->Var('table');
		my $table_class = $cls->Var('table_class');

		#set &columns
		if (exists $arg{columns}) {
			$cls->setVar(columns=>$arg{columns})
		}
		#create columns
		elsif ($cls->Flag('get_columns')) {
			my $method = "getcol_$db";
			if ($table_class->can($method)){
				$cls->setVar(columns=>[$table_class->$method($table)]);
			}
			#fall back on defined columns from Class::DBI, whose order isn't dependable :(
			elsif (my @columns = map {$_->name} $table_class->columns('All') > 0) {
				$cls->setVar(columns=>[@columns]);
			}
			else { warn "Columns aren't loaded for this table" }
		}

		#sync &action_columns with &columns
		$cls->setVar(action_columns=>$cls->Var('columns'));
	}

	package My::CDBI;

	sub search_regex {
		my $cls = shift;
		$cls->_do_search($regex_operator=> @_);
	}
	#subclass of Class::DBI b/c these functions expect it
	#h: the rest of the functions have been copied from their Class::DBI::*
	#all the getcol* does is return the columns of a table in order
	sub getcol_postgres {
		my ($class,$table) = @_;
		my @columns;
		eval {require DBD::Pg};

		my $catalog = ($class->pg_version >= 7.3) ? "pg_catalog." : "";
		my $sth = $class->db_Main->prepare("SELECT a.attname, a.attnum FROM ${catalog}pg_class c, ${catalog}pg_attribute a
	WHERE c.relname = ?  AND a.attnum > 0 AND a.attrelid = c.oid ORDER BY a.attnum");
		$sth->execute($table);
		my $columns = $sth->fetchall_arrayref;
		$sth->finish;

		foreach my $col(@$columns) {
			# skip dropped column.
			next if $col->[0] =~ /^\.+pg\.dropped\.\d+\.+$/;
			push @columns, $col->[0];
		}
		return @columns;
	}
	sub getcol_sqlite {
		my ($class,$table) = @_;
		my $sth = $class->db_Main->prepare("PRAGMA table_info(?)");
		$sth->execute($table);
		my @columns;
		while (my $row = $sth->fetchrow_hashref) {
			push @columns,$row->{name};
	    }
	    $sth->finish;
		return @columns;
	}
	sub getcol_mysql {
		#d:get columns of tb
		#t:mysql
		my $class = shift;
		my (@columns, @pri);

		$class->set_sql(desc_table => 'DESCRIBE __TABLE__');
		(my $sth = $class->sql_desc_table)->execute;

		while (my $hash = $sth->fetch_hash) {
			my ($col) = $hash->{field} =~ /(\w+)/;
			push @columns, $col;
			push @pri, $col if $hash->{key} eq "PRI";
		}
		#$class->_croak("$table has no primary key") unless @pri;
		return @columns
	}
	#used by getcol_postgres
	sub pg_version {
		my $class = shift;
		my $dbh = $class->db_Main;
		my $sth = $dbh->prepare("SELECT version()");
		$sth->execute;
		my($ver_str) = $sth->fetchrow_array;
		$sth->finish;
		my($ver) = $ver_str =~ m/^PostgreSQL ([\d\.]{3})/;
		return $ver;
	}
	1;

__END__