App-Framework
14 results

 view release on metacpan or  search on metacpan

lib/App/Framework/Feature/Sql.pm  view on Meta::CPAN 

#    [ORDER BY {col_name | expr | position}
#      [ASC | DESC], ...]
#    [LIMIT {[offset,] row_count | row_count OFFSET offset}]
#    [PROCEDURE procedure_name(argument_list)]
#    [INTO OUTFILE 'file_name' export_options
#      | INTO DUMPFILE 'file_name'
#      | INTO var_name [, var_name]]
#    [FOR UPDATE | LOCK IN SHARE MODE]]
#
#"SELECT `title` FROM `$table` WHERE `pid`=? AND `channel`=? LIMIT 1;"
#
#
#* UPDATE
#
#UPDATE [LOW_PRIORITY] [IGNORE] 
#	tbl_name
#    SET col_name1=expr1 [, col_name2=expr2] ...
#    [WHERE where_condition]
#    [ORDER BY ... ASC|DESC]
#    [LIMIT row_count]
#
#"UPDATE `$table` SET `title`=?, `date`=?, `start`=?, `duration`=?, `text`=?, `episode`=?, `num_episodes`=?, `repeat`=? ". 
#'WHERE `pid`=? AND `channel`=? LIMIT 1 ;'
#
#			where	order	limit	setlist		
#delete		  Y		Y		Y		-
#insert		  -		-		-		Y
#replace 	  -		-		-		Y
#select		  Y		Y		Y		-
#update		  Y		Y		Y		Y
#
#setlist 	=> [SET] `var`=?, `var`=? ..
#andlist	=> [WHERE] `var`=? AND `var`=? ..
#varlist	=> [SELECT|ORDER BY] `var`, `var`
#

my %CMDS = (
	'(sel|check)'	=> 'select',  
	'(del|rm)'		=> 'delete',  
	'ins'			=> 'insert',  
	'rep'			=> 'replace', 
	'upd'			=> 'update',  
) ;


#=back
#
#=head2 %CMD_SQL - Parse control hash
#
#Variables get created with the name 
#
#	* $sqlvar_<context>
#	
#where <context> is the hash key. This created variable contains the sql for this command or option.
#
#If the control hash entry contains a 'vals' entry, then the following variable is created:
#
#	* @sqlvar_<context>
#
#This will be a text string containing something like "@sqlvar_select_vals,@sqlvar_where_vals" i.e. a comma
#seperated list of references to other arrays. These values will be expanded into a real array before use in the
#sql prepare.
#
#Also, as each entry is processed, extra variables are created:
#
#	* $sqlvar_<context>_prefix	- Prefix string for this entry
#	* $sqlvar_<context>_format	- Just the same as sqlvar_<context>
#
#
#=head2 Specification variables
#
#This control hash is used to direct processing of the SQL specification passed to sth_create(). If the spec
#contains a 'vars' field then these additional variables are created in the context: 
#
#	* $sqlvar_<context>_varlist	- List of the 'vars' in the format `var`, `var` ..
#	* $sqlvar_<context>_andlist	- List of the 'vars' in the format `var` AND `var` ..
#	* $sqlvar_<context>_varlist	- List of the 'vars' in the format `var`=?, `var`=? ..
#
#If the spec has a 'vals' entry, then these are pushed on to an ARRAY ref and stored in:
#
#	* @sqlvar_<context>_vals
#
#@sqlvar_<context>_vals = Real ARRAY ref (provided by the spec)
#@sqlvar_<context> = String in the format "@sqlvar_select_vals,@sqlvar_where_vals" (provided by parse control hash)
#
#
#=cut



my %CMD_SQL = (

	## Overall query 
	'query'			=> {
			'format'	=> '$sqlvar_select$sqlvar_delete$sqlvar_insert$sqlvar_replace$sqlvar_update',
			'vals'		=> '@sqlvar_select,@sqlvar_delete,@sqlvar_insert,@sqlvar_replace,@sqlvar_update',
	},


	## Specific SQL commands
	'select'	=> {
			'prefix'	=> 'SELECT $sqlvar_select_varlist FROM `$sqlvar_table`',
			'format'	=> 'SELECT $sqlvar_select_varlist FROM `$sqlvar_table` $sqlvar_where $sqlvar_group $sqlvar_order $sqlvar_limit',
			'vals'		=> '@sqlvar_select_vals,@sqlvar_where_vals,@sqlvar_order_vals',
	},
	'delete'		=> {
			'prefix'	=> 'DELETE FROM `$sqlvar_table`',
			'format'	=> 'DELETE FROM `$sqlvar_table` $sqlvar_where $sqlvar_group $sqlvar_order $sqlvar_limit',
			'vals'		=> '@sqlvar_where_vals,@sqlvar_order_vals',
	},
	'insert'			=> {
			'prefix'	=> 'INSERT INTO `$sqlvar_table`',
			'format'	=> 'INSERT INTO `$sqlvar_table` SET $sqlvar_insert_setlist',
			'vals'		=> '@sqlvar_insert_vals',
	},
	'replace'			=> {
			'prefix'	=> 'REPLACE INTO `$sqlvar_table`',
			'format'	=> 'REPLACE INTO `$sqlvar_table` SET $sqlvar_replace_setlist',
			'vals'		=> '@sqlvar_replace_vals',
	},
	'update'			=> {

lib/App/Framework/Feature/Sql.pm  view on Meta::CPAN 

They are then used as:

	$sql->sth_query('check') ; # already given it's parameters
	$sql->sth_query('check2', $pid, $channel) ;
	$sql->sth_query('check3', $pid, $channel) ;
	$sql->sth_query('select', $pid, $channel) ;
			  

=cut

sub sth_create
{
	my $this = shift ;
	my ($name, $spec) = @_ ;
	
	my @vals ;
	
	## Set up vars
	my %vars = $this->vars() ;

	$vars{'sqlvar_select_varlist'} = '*' ;
	$vars{'sqlvar_query'} = $CMD_SQL{'query'}{'format'} ;
	$vars{'@sqlvar_query'} = $CMD_SQL{'query'}{'vals'} ;
	
	# Default table name
	$vars{'sqlvar_table'} = $vars{'table'} ;

$this->_dbg_prt(["sth_create($name)\n"], 2) ;
	
	## Guess command based on name
	my $cmd = $this->_sql_cmd($name) ;

$this->_dbg_prt([" + cmd=$cmd\n"], 2) ;
	
	## Handle hash
	if (ref($spec) eq 'HASH')
	{
		my %spec = (%{$spec}) ;
		
		# Set table if specified
		$vars{'sqlvar_table'} = delete $spec{'table'} if (exists($spec{'table'})) ; 

		# see if command specified
		$cmd = delete $spec{'cmd'} if (exists($spec{'cmd'})) ; 
		$cmd = lc $cmd ;

		# error check
		$this->throw_fatal("No valid sql command") unless $cmd ;

		# Process spec - set vars
		$this->_sql_setvars($cmd, \%spec, \%vars) ;
	}
	elsif (!ref($spec))
	{
		# Process spec - set vars
		$this->_sql_setvars($cmd || 'query', $spec, \%vars) ;
	}

$this->_dbg_prt(["Vars=", \%vars], 2) ;

$this->_dbg_prt(["+ expand vars\n"], 2) ;

	## Run through all vars and expand them
	$this->_sql_expand_vars(\%vars) ;

	## Run through all vars and expand arrays them
	$this->_sql_expand_arrays(\%vars) ;
	
	
	# query should now be in variable 'sqlvar_query'
	my $sql = $vars{'sqlvar_query'} ;

	# values should now be in variable '@sqlvar_query'
	my $values_aref = $vars{'@sqlvar_query'} ;

if ($this->debug())
{
	print "\n------------------------------------\n" ;
	print "PREPARE SQL($name): $sql\n----------\n" ;
	$this->prt_data("Values=", $values_aref) ;
}

#$this->prt_data("Values=", $values_aref, "\n--------------------\nVars=", \%vars) ;

	## Use given/created command sql
	my $dbh = $this->connect() ;
	$this->throw_fatal("No database created", 1) unless $dbh ;
	
	my $sth ;
	eval
	{
		$sth = $dbh->prepare($sql) ;
	};
	$this->throw_fatal("STH prepare error $@\nQuery=$sql", 1) if $@ ;
	
	my $sth_href = $this->_sth() ;
	$sth_href->{$name} = {
		'sth' => $sth,
		'vals' => $values_aref,
		'query' => $sql,		# For debug
	} ;
	
}




#----------------------------------------------------------------------------

=item B<sth_query($name, [@vals])>

Use a pre-prepared named sql query to return results. If the query has already been
given a set of values, then use them; otherwise use the values specified in this call
(or append the values to an insufficient list of values given when the sth was created)

=cut

sub sth_query
{
	my $this = shift ;
	my ($name, @vals) = @_ ;

	my $sth_href = $this->_sth_record($name) ;
	if ($sth_href)
	{
		my ($sth, $vals_aref, $query) = @$sth_href{qw/sth vals query/} ;

		# TODO: expand vars?
		my @args ;
		foreach my $arg (@$vals_aref)
		{
			## process each value			
			if (ref($arg) eq 'SCALAR')
			{
				## Ref to scalar
				push @args, $$arg ;
			}
			elsif (ref($arg) eq 'HASH')
			{
				## Special case handling where STH was created with an ARRAY ref or HASH ref
				if ($arg->{'type'} eq 'HASH')
				{
					## get latest value from hash ref
					push @args, $arg->{'hash'}{$arg->{'var'}} ;
				}
				elsif ($arg->{'type'} eq 'ARRAY')
				{
					## get latest value from array ref
					push @args, $arg->{'array'}[$arg->{'index'}] ;
				}
			}
			elsif (!ref($arg))
			{
				## Standard scalar
				push @args, $arg ;
			}
		}

		

		$this->_dbg_prt(["Sql::sth_query($query) : args=", \@args, "vals=", \@vals], 2) ;
		
		# execute
		eval
		{
			$sth->execute(@args, @vals) ;
		};
		if ($@)
		{
			my $vals = join(', ', @args, @vals) ;
			$this->throw_fatal("STH \"$name\"execute error $@\nQuery=$query\nValues=$vals", 1) if $@ ;
		}
	}

	return $this ;
}

#----------------------------------------------------------------------------

=item B<sth_query_all($name, [@vals])>

Use a pre-prepared named sql query to return results. Return all results in array.

=cut

sub sth_query_all
{
	my $this = shift ;

lib/App/Framework/Feature/Sql.pm  view on Meta::CPAN 

						'var'	=> $var,
					} ;
				}
			}
		}
		
		## If sql specified, use it
		if (exists($spec{'sql'}))
		{
			# create set of lists within this context namespace
			$format = delete $spec{'sql'} ;
		}

$this->_dbg_prt([" > + processing hash ...\n"], 2) ;
#$this->prt_data("spec=", \%spec) ;
		
		## cycle through the other hash keys to produce other variables
		foreach my $var (keys %spec)
		{
$this->_dbg_prt([" > + + $var = $spec{$var}\n"], 2) ;

			$this->_sql_setvars($var, $spec{$var}, $vars_href) ;
		}

#$this->prt_data("done hash : spec=", \%spec) ;
		
	}
	elsif (!ref($spec))
	{
		## String
		$format = $spec ;
		
$this->_dbg_prt([" > + spec is string : format=$format\n"], 2) ;


	}

$this->_dbg_prt([" > Now: prefix=$prefix , format=$format\n"], 2) ;


	## Ensure prefix is present
	if ($format && $prefix)
	{
		# Use prefix if necessary
		unless ($format =~ m/^\s*$context/i)
		{
$this->_dbg_prt([" > + + Adding prefix=$prefix to format=$format\n"], 2) ;
			$format = "$prefix $format" ;
		}
	}

	# Set var
	$vars_href->{$var} = $format ;

$this->_dbg_prt([" > _sql_setvars($context) - END [format=$format]\n"], 2) ;

}

#----------------------------------------------------------------------------

=item B<_sql_expand_vars($vars_href)>

Expand all the variables in the HASH ref

=cut

sub _sql_expand_vars
{
	my $this = shift ;
	my ($vars_href) = @_ ;

$this->_dbg_prt(["_sql_expand_vars()\n"], 2) ;
$this->_dbg_prt(["vars", \$vars_href], 2) ;


	# do all vars in HASH
	foreach my $var (keys %$vars_href)
	{
		# skip non SCALAR
		next if ref($vars_href->{$var}) ;
		
		# skip if empty
		next unless $vars_href->{$var} ;

$this->_dbg_prt([" + $var\n"], 2) ;
		
		# Keep replacing until all variables have been expanded
		my $ix = index $vars_href->{$var}, '$' ;
		while ($ix >= 0)
		{
$this->_dbg_prt([" + + ix=$ix : $var = $vars_href->{$var}\n"], 2) ;


			# At least 1 more variable to replace, so replace it
			$vars_href->{$var} =~ s{
								     \$                         # find a literal dollar sign
								     \{{0,1}					# optional brace
								    (\w+)                       # find a "word" and store it in $1
								     \}{0,1}					# optional brace
									}{
									    if (defined $vars_href->{$1}) {
									        $vars_href->{$1};       # expand 
									    } else {
									        "";  					# remove
									    }
									}egx;

		$ix = index $vars_href->{$var}, '$' ;

$this->_dbg_prt([" + + + $var = $vars_href->{$var}\n"], 2) ;
			
		}
	}

$this->_dbg_prt(["_sql_expand_vars - END\n"], 2) ;

}

#----------------------------------------------------------------------------

=item B<_sql_expand_arrays($vars_href)>

Expand all the array variables in the HASH ref

=cut

sub _sql_expand_arrays
{
	my $this = shift ;
	my ($vars_href) = @_ ;

$this->_dbg_prt(["_sql_expand_arrays()\n"], 2) ;
$this->_dbg_prt(["vars", \$vars_href], 2) ;

	# do all vars in HASH
	foreach my $var (keys %$vars_href)
	{
$this->_dbg_prt([" + $var=", $vars_href->{$var}, "\n"], 2) ;

		# skip variables that aren't named @....
		next unless $var =~ /^\@/ ;
		
		# skip if already an array
		next if ref($vars_href->{$var}) eq 'ARRAY' ;

		# Expand it
		$this->_sql_expand_array($var, $vars_href) ;
	}

$this->_dbg_prt(["_sql_expand_arrays() - END\n"], 2) ;

}

#----------------------------------------------------------------------------

=item B<_sql_expand_array($arr, $vars_href)>

Expand the named array

=cut

sub _sql_expand_array
{
	my $this = shift ;
	my ($array, $vars_href) = @_ ;

$this->_dbg_prt(["_sql_expand_array($array)\n"], 2) ;

	# skip if already an array
	unless (ref($vars_href->{$array}) eq 'ARRAY')
	{
		if ($vars_href->{$array})
		{
			# split on commas
			my @arr_list = split(/[,\s+]/, $vars_href->{$array}) ;
			
			# start array off
			$vars_href->{$array} = [] ;
	
	$this->_dbg_prt([" -- setting array\n"], 2) ;
	
			# process them
			foreach my $arr (@arr_list)
			{
	$this->_dbg_prt([" -- -- get $arr\n"], 2) ;
	
				# if reference to another array, evaluate it
				if ($arr =~ /^\@/)
				{
	$this->_dbg_prt([" -- -- -- expand $arr\n"], 2) ;
					my $arr_aref = $this->_sql_expand_array($arr, $vars_href) ;
					
	$this->_dbg_prt([" -- -- -- push array $arr=", $arr_aref, "\n"], 2) ;
	
					# Add to list
					push @{$vars_href->{$array}}, @$arr_aref if $arr_aref ;
				}
				else
				{
	$this->_dbg_prt([" -- -- -- push value ", $arr, "\n"], 2) ;
					# Add to list
					push @{$vars_href->{$array}}, $arr ;
				}			
			}
		}
	}

$this->_dbg_prt(["ARRAY $array=", $vars_href->{$array}], 2) ;
$this->_dbg_prt(["_sql_expand_array($array) - END\n"], 2) ;

	return ($vars_href->{$array}) ;
}


#----------------------------------------------------------------------------

=item B<_sth_record($name)>

Returns the saved sth information looked up from $name; returns undef otherwise

=cut

sub _sth_record
{
	my $this = shift ;
	my ($name) = @_ ;

	# error check
	if (!$name)
	{
		$this->dump_callstack() if $this->debug() ;
		$this->throw_fatal("Attempting to find prepared statement but no name has been specified") unless $name ;				
	}

	my $sth_href = $this->_sth() ;
	if (exists($sth_href->{$name}))
	{
		$sth_href = $sth_href->{$name} ;

		# error check
		$this->throw_fatal("sth $name not created") unless $sth_href ;				

	}
	else
	{
		# error
		$this->throw_fatal("sth $name not created") ;				
	}
		
	return $sth_href ;
}

#----------------------------------------------------------------------------

=item B<_sth_record_sth($name)>

Returns the saved sth looked up from $name; returns undef otherwise

=cut

sub _sth_record_sth
{
	my $this = shift ;
	my ($name) = @_ ;

	my $sth ;
	my $sth_href = $this->_sth_record($name) ;
	
	if ($sth_href && exists($sth_href->{'sth'}))



( run in 1.021 second using v1.01-cache-2.11-cpan-5623c5533a1 )