App-Framework
12 results

 view release on metacpan or  search on metacpan

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

		my $dbh = $this->dbh() ;
		my $trace_file = $this->trace_file() ;
		
		# Update trace level
		$this->_set_trace($dbh, $trace, $trace_file) ;
	}
	
	return $trace ;
}

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

=item B<trace_file(@args)>

Change trace file

=cut

sub trace_file
{
	my $this = shift ;
	my (@args) = @_ ;
	
	# Update value
##	my $trace_file = $this->SUPER::trace_file(@args) ;
	my $trace_file = $this->field_access('trace_file', @args) ;
	
	if (@args)
	{
		my $dbh = $this->dbh() ;
		my $trace = $this->trace() ;
		
		# Update trace level
		$this->_set_trace($dbh, $trace, $trace_file) ;	
	}
	
	return $trace_file ;
}




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

=item B<connect(%args)>

Connects to database. Either uses pre-set values for user/password/database,
or can use optionally specified args

=cut

sub connect
{
	my $this = shift ;
	my (%args) = @_ ;

	$this->set(%args) ;

	$this->_dbg_prt(["Sql::connect() => ",$this->database(),"\n"]) ;

	$this->throw_fatal("SQL connect error: no database specified") unless $this->database() ;
	$this->throw_fatal("SQL connect error: no host specified") unless $this->host() ;

	my $dbh ;
	eval
	{
		# Disconnect if already connected
		$this->disconnect() ;
		
		# Connect
		$dbh = DBI->connect("DBI:mysql:database=".$this->database().
					";host=".$this->host(),
					$this->user(), $this->password(),
					{'RaiseError' => 1}) or $this->throw_fatal( $DBI::errstr ) ;
		$this->dbh($dbh) ;
		
	};
	if ($@)
	{
		$this->throw_fatal("SQL connect error: $@", 1000) ;
	}
	
	my $dbh_dbg = $dbh || "" ;
	$this->_dbg_prt([" + connected dbh=$dbh_dbg : db=",$this->database()," user=",$this->user()," pass=",$this->password(),"\n"]) ;
	
	return $dbh ;
}

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

=item B<disconnect()>

Disconnect from database (if connected)

=cut

sub disconnect
{
	my $this = shift ;

	my $dbh = $this->dbh() ;

	my $dbh_dbg = $dbh || "" ;
	$this->_dbg_prt(["Sql::disconnect() => dbh=$dbh_dbg\n"]) ;

	eval
	{
		if ($dbh)
		{
			$this->dbh(0) ;
		}
	};
	if ($@)
	{
		$this->throw_fatal("SQL disconnect error: $@", 1000) ;
	}

	$this->_dbg_prt([" + disconnected\n"]) ;
}


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

=item B<sth_create($name, $spec)>

Prepare a named SQL query & store it for later execution by query_sth()

Name is saved as $name. Certain names are 'special':

 ins*	- Create an 'insert' type command
 upd*	- Create an 'update' type command
 sel*	- Create a 'select' type command
 check* - Create a 'select' type command
 
The $spec is either a SCALAR or HASH ref 

If $spec is a SCALAR then it is in the form of sql. Note, when the query is executed the values
(if required) must be specified.

If $spec is a HASH ref then it can contain the following fields:

	'cmd'	=> Command type: 'insert', 'update', 'select'
	'vars'	=> ARRAY ref list of variable names (used for 'insert', 'update')
	'vals'	=> Provides values to be used in the query (no extra values need to be specified). HASH ref or ARRAY ref. 
	           HASH ref - the hash is used to look up the values using the 'vars' names
	           ARRAY ref - list of values (or refs to values)
	           NOTE: If insufficient values are provided for the query, then the remaining values must be specified in the query call
	'sql'  	=> Sql string.
			   NOTE: Depending on the command type, if the command is not specified then a default will be prepended to this string.
	'table'	=> Overrides the object table setting for this query
	'limit'	=> Sets the limit on the number of results
	'group'	=> Specify group by string
	'where'	=> Where clause. String or HASH ref.
			   String - specify sql for where clause (can omit 'WHERE' prefix)
			   HASH ref - specify where clause as HASH:  
					'sql' => Used to specify more complicated where clauses (e.g. '`pid`=? AND `channel`=?')
					'vars'	=> ARRAY ref list of variable names (used for 'where'). If no 'sql' is specified, then the where clause
							   is created by ANDing the vars together (e.g. [qw/pid channel/] gives '`pid`=? AND `channel`=?')
					'vals'	=> Provides values to be used in the query (no extra values need to be specified). HASH ref or ARRAY ref.

EXAMPLES

The following are all (almost) equivalent:

	$sql->sth_create('check',  {
					'table'	=> '$table',
					'limit'	=> 1,
					'where'	=> {
						'sql' => '`pid`=? AND `channel`=?',
						'vars'	=> [qw/pid channel/],
						'vals'	=> \%sql_vars
					}) ;

	$sql->sth_create('check2',  {
					'table'	=> '$table',
					'limit'	=> 1,
					'where'	=> '`pid`=? AND `channel`=?',# need to pass in extra params to query method
					}}) ;

	$sql->sth_create('check3',  "SELECT * FROM `$table` WHERE `pid`=? AND `channel`=? LIMIT 1") ;
	
	$sql->sth_create('select',  "WHERE `pid`=? AND `channel`=? LIMIT 1") ;

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 ;
	my ($name, @vals) = @_ ;

	my @results ;
	
	$this->sth_query($name, @vals) ;
	while(my $href = $this->next($name))
	{
		push @results, $href ;
	}
	
	return @results ;
}



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

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

Query database

=cut

sub query
{
	my $this = shift ;
	my ($query, @vals) = @_ ;
	
	$this->sth_create($DEFAULT_STH_NAME, $query) ;
	$this->sth_query($DEFAULT_STH_NAME, @vals) ;

	return $this ;
}

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

=item B<query_all($query)>

Query database - return array of complete results, each entry is a hash ref

=cut

sub query_all
{
	my $this = shift ;
	my ($query, @vals) = @_ ;
	
	my @results ;
	
	$this->query($query, @vals) ;
	while(my $href = $this->next())
	{
		push @results, $href ;
	}
	
	return @results ;
}

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

=item B<do($sql)>

Do sql command

=cut

sub do
{
	my $this = shift ;
	my ($sql) = @_ ;
	
	my $dbh = $this->connect() ;

	# Do query
	eval
	{
		$dbh->do($sql) ;
	};
	if ($@)
	{
		$this->throw_fatal("SQL do error $@\nSql=$sql", 1) if $@ ;
	}

	return $this ;
}

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

=item B<do_sql_text($sql_text)>

Process the SQL text, split it into one or more SQL command, then execute each of them

=cut

sub do_sql_text
{
	my $this = shift ;
	my ($sql_text) = @_ ;
	
	while ($sql_text =~ /([^;]*);/gm)
	{
		$this->do($1) ;
	}
	
	return $this ;
}

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

=item B<next([$name])>

Returns hash ref to next row (as a result of query). Uses prepared STH name $name
(as created by sth_create method), or default name (as created by query method)

=cut

sub next
{
	my $this = shift ;
	my ($name) = @_ ;
	
	# Get STH and get next row
	$name ||= $DEFAULT_STH_NAME ;
	my $sth = $this->_sth_record_sth($name) ;
	my $href = $sth->fetchrow_hashref() ;

	$this->_dbg_prt(["Sql::next() => sth=",$sth, " : record=",$href,"\n"]) ;
	
	return $href ;
}

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

=item B<tables()>

Returns list of tables for this database

=cut

sub tables
{

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

	{
		$sqldate =~ s%-%/%g ;
		my $date = ParseDate($sqldate) ;

		$datestr = UnixDate($date, "%d-%m-%Y") ;
		
	}

	return $datestr ;
}


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

=item B<sqldate_to_datemanip($sql_date)>

Convert SQL based date (YYYY-MM-DD) to a date string suitable for Date::Manip (d/M/YYYY)
	
=cut

sub sqldate_to_datemanip
{
	my $this = shift ;
	my ($sqldate) = @_ ;

	my $datestr ;

	if ($sqldate =~ m/(\d{4})\-(\d{2})\-(\d{2})/)
	{
		$datestr = "$3/$2/$1" ;
	}
	else
	{
		$sqldate =~ s%-%/%g ;
		my $date = ParseDate($sqldate) ;

		$datestr = UnixDate($date, "%d/%m/%Y") ;
		
	}

	return $datestr ;
}


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

=item B<sql_from_data($name)>

NOTE: Only works when feature is registered with an application

Execute the (possible sequence of) command(s) stored in a named __DATA__ area in the application.

=cut

sub sql_from_data
{
	my $this = shift ;
	my ($name) = @_ ;
	
	my $app = $this->app() ;
	$this->throw_error("Unable to find DATA section since not associated with an application") unless $app ;	
	
	# Get named data
	my $sql_text = $app->data($name) ;
	
	if ($sql_text)
	{
		## process the data
		$this->do_sql_text($sql_text) ;
	}
	else
	{
		$this->throw_error("Data section $name contains no SQL") ;	
	}

	return $this ;	
}




# ============================================================================================
# PRIVATE METHODS
# ============================================================================================


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

=item B<_sql_cmd($name)>

Convert $name into a sql command if possible

=cut

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

	my $cmd ;
	foreach my $match (keys %CMDS)
	{
		if ($name =~ m/^$match/i)
		{
			$cmd = $CMDS{$match} ;
			last ;
		}
	}
	
	return $cmd ;
}

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

=item B<_sql_setvars($context, $spec, $vars_href)>

Set/add variables into the $vars_href HASH driven by the specification $spec (which may
be a sql string or a HASH specification). Creates the variables in the namespace defined by
the $context string (which is usually the lookup string into the %CMD_SQL table)

=cut

sub _sql_setvars
{
	my $this = shift ;
	my ($context, $spec, $vars_href) = @_ ;

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


	## Start by getting control info from %CMD_SQL if possible
	my $var = "sqlvar_${context}" ;
	my ($format, $prefix) ;

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

		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'}))
	{
		$sth = $sth_href->{'sth'} ;

		$this->throw_fatal("sth $name not created" ) unless $sth ;				

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

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

=item B<_set_trace($dbh, $trace, $trace_file)>

Update trace level

=cut

sub _set_trace
{
	my $this = shift ;
	my ($dbh, $trace, $trace_file) = @_ ;
	
	if ($dbh)
	{
		$dbh->trace($trace, $trace_file)
	}
}

# ============================================================================================
# END OF PACKAGE

=back

=head1 DIAGNOSTICS

Setting the debug flag to level 1 prints out (to STDOUT) some debug messages, setting it to level 2 prints out more verbose messages.

=head1 AUTHOR

Steve Price C<< <sdprice at cpan.org> >>

=head1 BUGS

None that I know of!

NOTE: To avoid the common "Mysql server gone away" problem, everywhere that I get the database connection handle, I actually call
the connect() method to ensure the connection is working.

=cut

1;

__END__



( run in 0.660 second using v1.01-cache-2.11-cpan-39bf76dae61 )