File Coverage

lib/Fry/Lib/CDBI/Basic.pm

Criterion	Covered	Total	%
statement	4	88	4.5
branch	0	8	0.0
condition			n/a
subroutine	2	14	14.2
pod			n/a
total	6	110	5.4

package Fry::Lib::CDBI::Basic;
use strict;

our $VERSION='0.15';
my $sql_count;
#our $cdbi_search = "search_abstract";
#other possible values are cdbi_search,cdbi_regex and cdbi_search_like

#functions
	sub _default_data {
		my $class = shift;

		return {
			depend=>[':CDBI::Load'],
			vars=>{
				editor=>$ENV{EDITOR},
				splitter=>'=',
				insert_columns=>'',
				abstract_opts=>{logic=>'and'},
				insert_delimiter=>',,',
				cdbi_search=>'search_abstract',
				#flags
				safe_update=>1,
				only_modified=>1,
			},
			subs=>{parseHash=>{qw/a h/},parseHashref=>{qw/a hr/},
				printTextTable=>{qw/a tt/}
				#search=>{sub=>'search'},search_like=>{}
			},
			cmds=>{
				print_columns=>{a=>'pc',d=>'Prints columns of current table',u=>''},
				search_abstract=>{a=>'s',aa=>\&aliasInputAndSql,
					d=>'Search for results via AbstractSearch'
					,u=>'@search_term'},
				cdbi_search=>{a=>'sn',aa=>\&aliasInputAndSql,u=>'@search_term'},
				cdbi_search_like=>{a=>'sl',aa=>\&aliasInputAndSql,u=>'@search_term'},
				cdbi_search_regex=>{a=>'sr',aa=>\&aliasInputAndSql,u=>'@search_term'},
				cdbi_delete=>{a=>'d',aa=>\&aliasInputAndSql,
					d=>'Deletes results of given query',u=>'@search_term'},
				cdbi_create=>{a=>'i',aa=>\&aliasInsert, d=>"Creates a record",
					u=>'($value$delim)+'},
				cdbi_find_or_create=>{a=>'fc',aa=>\&aliasInputAndSql, d=>"Find or create a record",
					u=>'@search_term'},
				cdbi_multi_insert=>{a=>'mi',arg=>'$file',u=>'$file'},
				cdbi_update=>{a=>'U',aa=>\&aliasInputAndSql, d=>'Updates records via a text editor',
					u=>'@search_term'},
				replace=>{d=>'evals each value of each result row with $operation', a=>'r',
					u=>'@search_term$operation'},
				cdbi_delete_obj=>{a=>':d',u=>'@cdbi'},
				cdbi_update_obj=>{a=>':U',u=>'@cdbi'},
				verify_no_delim=>{a=>'V',aa=>\&aliasInputAndSql, u=>'@cdbi',
					d=>"Verify that specified records don't have display delimiter in them"},
				display_table_list=>{qw/a dpt/, d=>'Displays public tables',u=>''},
				print_dbi_log=>{a=>'dpl',d=>'Prints the current DBI log',u=>''},
				clear_dbi_log=>{d=>'Clears the dbi log',u=>'',a=>'dcl',u=>''},
				set_dbi_log_level=>{a=>'dsl',d=>'Sets the log level of a DBI handler',
					u=>'$num'},
			},
			opts=>{cdbi_search=>{qw/a cs type var noreset 1 default cdbi_search_regex/ }}
			#retrieve_all retrieve/],
			#construct,has*,trigger,constrain_column,set_sql
			#}
			#subs=>{aliasInputAndSql=>{}},
			#td: obj-$result(autoupdate,update,delete,set/get,copy,discard_changes,is_changed),$iterator,$col,$relation
		}
	}
	sub _initLib {
		my $cls = shift;
		$cls->_set_insert_col;
		$cls->Var('abstract_opts')->{cmp} =  $cls->_regex_operator;

		#ugly, should be in _default_data
		$cls->call(var=>'set','cdbi_search',enum=>[qw/cdbi_search cdbi_search_like cdbi_search_regex search_abstract/]);
	       	$cls->call(var=>'set','cdbi_search',default=>'cdbi_search_regex');
	}
	#note for library use outside of shell
	#this module depends on external subs: &parse_num

	##utils
	sub uniqueInArrays {
		my ($cls,$uniq,$array2) =@_;
		my (@unique,%seen,$i,@num);

		for (@$array2) {$seen{$_}++}
		for (@$uniq) { $i++; do {push(@unique,$_);push(@num,$i) } if (! exists $seen{$_}) }
		return (\@unique,\@num);
	}
	sub file2array {
		shift;
		#local function
		#d:converts file to @ of lines
		open(FILE,"< $_[0]");
		my @lines; chomp(@lines = );
		close FILE;
		return @lines;
	}
	sub check_for_regex {
		#d: AoHregexp, could be used as an 'or' search on multiple columns
		my ($class,$regex,@records) = @_;
		my @unclean;

		for (@records) {
			for my $col (@{$class->Var('action_columns')}) {
				if ($_->$col =~ /$regex/) {
					push(@unclean,$_);
					last; #break?
				}
			}
		}
		return @unclean;
	}
	#internal methods
	sub _set_insert_col {
		my $cls = shift;
		#set insert_columns
		my @insert_columns = @{$cls->Var('columns')};
		shift @insert_columns;
		$cls->setVar(insert_columns=>\@insert_columns);

	}
	sub regexChangeAoH {
		my ($cls,$op,@records2update) = @_;
		for my $rec (@records2update) {
			for (my $j=0; $j < @{$cls->Var('action_columns')}; $j++) {
				my $col= $cls->Var('action_columns')->[$j];
				$_ = $rec->$col;
				eval $op; die($@) if $@;
				$rec->$col($_);
			}
		$rec->update;
		}
	}
	sub modify_file {
		my ($cls,$tempfile) = @_;
		my $inp;

		system($cls->Var('editor') . " $tempfile");# or die "can't execute command as $<: $@";
		#?: why does this system always return a fail code
		#$cls->view("cdbi_update (y/n)? "); chomp($inp = );
		$inp = $cls->Rline->stdin("cdbi_update (y/n)?");
		return ($inp eq "y");
	}
	sub update_from_file {
		my ($cls,$tempfile,@records) = @_;

		my @lines = $cls->file2array($tempfile);

		#my $firstline = shift(@lines);
		#read column order from file
		#my @fields = split(/$updatedelim/,$firstline);
		#or not
		my @fields = @{$cls->Var('action_columns')};

		my $i;
		foreach (@records) {		#each row to update
			my @fvalues = split(/${\$cls->Var('field_delimiter')}/,$lines[$i]);
			for (my $j=0; $j < @fields; $j++) {		#each column to update

				my $temp=$fields[$j];
				$_->$temp($fvalues[$j]);		# this line = $_->$field($fieldvalue)
			}
			$_->update;
			#$_->dbi_commit if ($db = postgres
			$i++;
		}
	}
	sub col2f1 {
		#d: aliases column names with c and number
		my $class = shift;
		my @newterms;

		for (@_) {
		#if (/c(\d+)=/) { my $col = $col[$1-1];s/c\d+/$col/}
		if (/c([-,\d]+)(.*)/) {
		my @tempcol = $class->sub->parseNum($1,@{$class->Var('columns')});
			for my $eachcol (@tempcol) {
				push(@newterms,$eachcol.$2);
			}
		}
		else {push (@newterms,$_)}
		}
		return @newterms;
	}
#sub objects
	##print functions,input is objects
	sub printtofile {
		#d:prints rows to temporary file
		my ($cls,$tempfile,@records) =  @_;

		my $output = join($cls->Var('field_delimiter'),@{$cls->Var('action_columns')})."\n";
		$output .= $cls->View->objAoH_dt(\@records,$cls->Var('action_columns'));
		$cls->View->file($tempfile,$output);
	}
	sub printTextTable {
		my $cls = shift;
		$cls->print_text_table(\@_,$cls->Var('action_columns'));
	}
	sub print_text_table {
		my $cls = shift;
		my ($ref1,$ref2) = @_; my @row = @{$ref1}; my @columns = @{$ref2};
		my (@column_values,@longest);

		#defaul
		eval { use Text::Reform}; die $@ if ($@);

		for my $column (@columns) {
			my @column_value;
			my $longest = length($column);
			for (@row) {
				#find longest string in each column including string
				my $newlength = length($_->$column);
				$longest = $newlength if ($newlength > $longest);

				push(@column_value,$_->$column);
			}
			push(@longest,$longest);
			push(@column_values,\@column_value);
		}

		#create format
		my $line_length = 3 * @columns + 1;
		my $picture_line = "|";

		for (@longest) {
			$line_length += $_ ;
			$picture_line .= " " . "["x $_ . " |";
		}
		my $firstline = "=" x $line_length;
		#$picture_line .= "\n" . "-" x $line_length;

		#print column names
		$cls->view(form $picture_line,@columns);
		#print body
		$cls->view(form $firstline,$picture_line, @column_values);
	}
	sub print_horizontal_numbered_list {
		my ($cls,$prompt,$list) = @_;
		my $a;

		my $output = $prompt;
		for (@$list){$a++;$output .= "$a.$_ " };
	       	$output .= "\n";
		$cls->view($output);
	}
	##alias fns
	sub cdbiDbh { shift->Var('table_class')->db_Main }
	sub aliasInputAndSql { my $cls = shift;
		return $cls->aliasSqlAbstract($cls->aliasInput(@_)) }
	sub aliasInput {
		my $class =  shift;
		@_ = $class->Var('columns')->[0].$class->Var('splitter').".*" if ($_[0] eq "a");  #all results given
		@_ = $class->col2f1(@_) if ("@_" =~ /c[-,\d]+=/);	#c\d instead of column name
		return @_;
	}
	sub aliasInsert {
		#d:parses userinput to hashref for &create
		my $cls = shift;
		my %chosenf;
		#die "Nothing given for cdbi_insert" if (not defined @_);
		my @fields = split(/${\$cls->Var('insert_delimiter')}/,"@_");
		my @insert_columns = @{$cls->Var('insert_columns')};

		for (my $i=0;$i< @insert_columns;$i++) {
			$chosenf{$insert_columns[$i]} = $fields[$i];
			$cls->view("$insert_columns[$i] = $fields[$i]\n");
		}
		return \%chosenf;
	}
	sub aliasSqlAbstract {
		#d:parse to feed to sql::abstract
		#note: operators hardcoded for now
		my $class =  shift;
		my @processf;
		my $splitter = $class->Var('splitter');

		foreach (@_) {
			if (/$splitter([>!<])=/) {
				my $operator = $1;
				my ($key,$value) = split(/=$operator=/);
				push(@processf,$key,{"$operator\=",$value});
			}
			elsif (/$splitter([><=])/) {
				my $operator = $1;
				my ($key,$value) = split (/$splitter$operator/);
				push(@processf,$key,{$operator,$value});
			}
			#embedded sql
			elsif (/$splitter(.*)$splitter/) {
				my $literal_sql = $1;
				$literal_sql =~ s/_/ /g;
				my ($key,$dump) = split (/$splitter/);
				push(@processf,$key,\$literal_sql);
			}
			#default operator
			#elsif(/=/)
			else {
				my ($key,$value) = split(/$splitter/) or die "error splitting select";
				push(@processf,$key,$value);
			}
			#else { warn "no valid operator specified" };
		}
		return @processf;
	}
	##parse functions,input is from commandine
	sub parseHash {
		my ($cls,$input) = @_;

		my @arg = split(/ /,$input);
		my $cmd = shift @arg;
		my %results = $cls->parseIndHash($cls->Var('splitter'),@arg);
		return ($cmd,%results)
	}
	sub parseHashref {
		my ($cls,$input) = @_;
		my ($cmd,%results) = $cls->parseHash($input);
		return ($cmd,\%results);
	}
	sub parseIndHash {
		my ($class,$splitter,@chunks) =  @_;
		my %processf;

		for (@chunks) {
			my ($key,$value) = split(/$splitter/) or die "error splitting select";
			$processf{$key} = $value;
		}
		return %processf;
	}
#commands
	sub print_columns {
		my $cls =  shift;
		$cls->print_horizontal_numbered_list($cls->Var('table')."'s columns are ",$cls->Var('columns'));
	}
	sub search_abstract {
		#d:handles multiple parsing cases and returns search results
		my $cls =  shift;
		if (@_ ==0 ) {warn("No arguments given to &search_abstract\n");return () }
		$cls->sub->_require('Class::DBI::AbstractSearch');
		$cls->sub->useThere('Class::DBI::AbstractSearch',$cls->Var('table_class'));

		#calling class determines class
		my @results = $cls->Var('table_class')->Class::DBI::AbstractSearch::search_where(\@_,$cls->Var('abstract_opts'));
		$cls->saveArray(@results) if ($cls->Flag('menu'));
		return @results;
	}
	sub cdbi_search { shift->Var('table_class')->search(@_) }
	sub cdbi_search_like { shift->Var('table_class')->search_like(@_) }
	sub cdbi_search_regex { shift->Var('table_class')->search_regex(@_) }
	sub cdbi_create { shift->Var('table_class')->create(@_) }
	sub cdbi_delete {
		#td: chain
		my $cls =  shift;
		my @aliasedinput = @_;
		my @results = $cls->${\$cls->Var('cdbi_search')}(@aliasedinput);
		#my @results = $cls->sub->subHook(args=>\@aliasedinput,var=>'cdbi_search',default=>'search_abstract',caller=>$cls);
		$cls->cdbi_delete_obj(@results);
	}
	sub cdbi_find_or_create {
		my ($cls,%dt)    = @_;
		#my $hash     = ref $_[0] eq "HASH" ? shift: {@_};
		my ($exists) = $cls->${\$cls->Var('cdbi_search')}(%dt);
		return defined($exists) ? $exists : $cls->Var('table_class')->create(\%dt);
	}
	sub cdbi_multi_insert {
		my ($cls,$file) = @_;

		chomp(my @lines= $cls->file2array($file));
		for (@lines) {
			$cls->create($cls->aliasInsert($_));
		}
	}
	sub replace {
		#td:chain
		my $cls = shift;
		my $op = pop(@_);

		my @records2update = $cls->${\$cls->Var('cdbi_search')}($cls->aliasInputAndSql(@_));
		$cls->regexChangeAoH($op,@records2update);
	}
	sub verify_no_delim {
		#td:chain
		my $cls = shift;

		my @records2update = $cls->${\$cls->Var('cdbi_search')}(@_);
		my $clean = $cls->verify_no_delim_obj(@records2update);
		$cls->view("No records containing delimiter found") if ($clean);
	}
	sub cdbi_update {
		#td:chain
		my $cls =  shift;
		#$cls->cdbi_update_obj($cls->${\$cls->Var('cdbi_search')}(@_));
		$cls->cdbi_update_obj($cls->search_abstract(@_));
	}
	##$result obj
	sub cdbi_update_obj {
		my ($cls,@records2update) = @_;
		$cls->sub->_require('File::Temp');
		do {warn("File::Temp"); return} if ($@);
		my (undef,$tempfile) = File::Temp::tempfile();
		#$tempfile = 'ya';

		if ($cls->Flag('safe_update')) {
			my $clean = $cls->verify_no_delim_obj(@records2update);
			return if (not $clean);
		}

		$cls->printtofile($tempfile,@records2update);

		#only for changed rec
		my @original_lines = $cls->file2array($tempfile)
			if ($cls->Flag('only_modified'));

		my $modify = $cls->modify_file($tempfile);

		#only update changed records
		if ($cls->Flag('only_modified')) {
			my @new_lines = $cls->file2array($tempfile);
			#shift off columns line
			shift(@new_lines); shift(@original_lines);

			my ($modified_lines,$num) = ([],[]);
			($modified_lines,$num) = $cls->uniqueInArrays(\@new_lines,\@original_lines);
			#exit early if nothing to modify
			if (@$modified_lines == 0) { $modify = 0; last }

			#write new file
			$cls->View->file($tempfile,join("\n",@$modified_lines));
			@records2update = $cls->sub->parseNum(join(',',@$num),@records2update);
		}

		$cls->update_from_file($tempfile,@records2update) if ($modify);
	}
	sub verify_no_delim_obj {
		my ($cls,@records) = @_;

		my @unclean_records =
		$cls->check_for_regex($cls->Var('field_delimiter'),@records);
		#$cls->check_for_regex('a',@records);

		if (defined @unclean_records) {
			$cls->view( "The following are records containing the delimiter '",
			$cls->Var('field_delimiter'),"':\n\n");
			$cls->View->objAoH(\@unclean_records,$cls->Var('action_columns'));
			return 0;
		}
		#passed successfully
		return 1;
	}
	sub cdbi_delete_obj {
		my $class =  shift;
		for (@_) { $_->delete; }
	}
#$dbh commands: could be used in DBI
	sub display_table_list {
		my ($class,$dbh) = @_;
		$class->print_horizontal_numbered_list("Database's tables are ",[$class->get_table_list($dbh)]);
	}
	sub print_dbi_log {
		my ($cls) = @_;
		my $dbh =  $cls->cdbiDbh;
		$cls->view($dbh->{Profile}->format);
	}
	sub clear_dbi_log {
		my ($cls) = @_;
		my $dbh =  $cls->cdbiDbh;
		$dbh->{Profile}->{Data}=undef;
	}
	sub set_dbi_log_level{
		my ($cls,$num) = @_;
		my $dbh =  $cls->cdbiDbh;

		if ($num > 15 or $num < -15) {
			warn" given log level out of -15 to 15 range";
		}
		else { $dbh->{Profile} = $num; }
	}
	#$dbh = (defined $dbh) ? $cls->idToObj($dbh) : $cls->cdbiDbh;
	##other
	sub t_file {
		my $cls = shift;
		#w
		my $file = shift || do { $cls->view("No file given.\n"); return 0 };
		if (! -e $file) { $cls->view("File doesn't exist.\n"); return 0};
		return 1;
	}
	sub cmpl_file {
	}
	###internal
	sub get_table_list {
		my ($cls,$dbh) = @_;
		$dbh = (defined $dbh) ? $cls->idToObj($dbh) : $cls->cdbiDbh;
		my $sth = $cls->get_table_info($dbh);
		return warn "Driver hasn't implemented the table_info() method" unless (ref $sth);
		my @tables =  map {$_->[2]} @{$sth->fetchall_arrayref};
		return @tables;
	}
	sub get_table_info {
		#d: displays public tables for postgres, may have to adjust &table_info per database
		my ($class,$dbh,$table) = @_;
		my $catalog = undef;
		my $schema = ($class->Var('db') eq "postgres") ? 'public' : undef;
		my $type;
		return  $dbh->table_info($catalog,$schema,$table,$type);
	}
1;

__END__