Apache-Wyrd

 view release on metacpan or  search on metacpan

Wyrd/DBL.pm  view on Meta::CPAN

no warnings qw(uninitialized);

package Apache::Wyrd::DBL;
our $VERSION = '0.98';
use DBI;
use Apache;
use Apache::Wyrd::Request;
use Apache::Wyrd::User;
use Apache::URI;

=pod

=head1 NAME

Apache::Wyrd::DBL - Centralized location for tracking variables, internals

=head1 SYNOPSIS

	my $hostname = $wyrd->dbl->req->hostname;
	my $database_handle = $wyrd->dbl->dbh;
	my $value = $wyrd->dbl->param('value');

=head1 DESCRIPTION

C<Apache::Wyrd::DBL> ("Das Blinkenlights") is a convenient placeholder for
all session information a Wyrd might need in order to do work.  It holds
references to the session's current apreq, DBI, and Apache objects, as well
as the current session log and other vital information.  It is meant to be
called from within an Apache::Wyrd object through it's C<dbl> method, as in
the SYNOPSIS.

Debugging is always turned on if port 81 is used.  Note that apache must be set
up to listen at this port as well.  See the Listen and BindAddress Apache directives.

=head1 METHODS

=over

=item (DBL) C<new> (hashref, hashref)

initialize and return the DBL with a set of startup params and a set of global
variables (for the WO to access) in the form of two hashrefs.  The first hashref
should include at least the 'req' key, which is an Apache request object.

The startup params can have several keys set.  These may be:

=over

=item apr

the param/cookie subsystem (CGI or Apache::Request object initialized by a Apache::Wyrd::Request object);

=item dba

database application.  Should be the name of a DBI::DBD driver.

=item database

database name (to connect to)

=item db_password

database password

=item db_username

database user name

=item loglevel

Logging level, per Apache::Wyrd object

=item globals

pointer to globals hashref

=item req (B<required>)

the request itself (Apache request object)

=item strict

should strict procedures be followed (not used by default)

=item user

the current user (not used by default)

=back

=cut

sub new {
	my ($class, $init) = @_;
	if ((ref($init) ne 'HASH') and $init) {
		complain("invalid init data given to Das Blinkenlights -- Ignored");
		$init = {};
	}
	$ENV{PATH} = undef unless ($$init{flags} =~ /allow_unsafe_path/);
	if ((ref($$init{'globals'}) ne 'HASH') and $$init{'globals'}) {
		complain("invalid global data given to Das Blinkenlights -- Ignored");
		$$init{'globals'} = {};
	}
	my @standard_params = qw(
		atime
		base_class
		blksize
		blocks
		ctime
		database
		db_password
		db_username
		dba
		dev
		file_path
		gid
		globals
		ino
		logfile
		loglevel
		mode
		mtime
		nlink
		rdev
		req
		self_path
		size
		strict
		taint_exceptions
		uid
		user
	);
	my $data = {
		dbl_log		=>	[],
		dbh_ok		=>	0,
		dbh			=>	undef,
		response	=>	undef
	};
	foreach my $param (@standard_params) {
		$$data{$param} = ($$init{$param} || undef);
	}
	bless $data, $class;
	if (UNIVERSAL::isa($$init{'req'}, 'Apache')) {
		$data->{'req'} = $$init{'req'};
		$data->{'mod_perl'} = 1;
		my $server = $$init{'req'}->server;
		$data->{'loglevel'} = 4 if ($server->port == 81);
		$data->{'self_path'} ||= $$init{'req'}->parsed_uri->rpath;
		my $apr = Apache::Wyrd::Request->instance($$init{'req'});
		$data->{'apr'} = $apr;
	};
	if (UNIVERSAL::isa($$init{'database'}, 'DBI::db')) {
		if ($$init{'database'}->can('ping') && $$init{'database'}->ping) {
			$data->{'dbh'} = $$init{'database'};
			$data->{'dbh_ok'} = 1;
		} else {
			$data->log_bug('DBI-type Database apparently passed to Das Blinkenlights, but was not valid')
		}
	}
	return $data;
}

=pod

=item verify_dbl_compatibility

Used by Apache::Wyrd to confirm it's been passed the right sort of object for a
DBL.

=cut

Wyrd/DBL.pm  view on Meta::CPAN

=pod

=item (void) set_global(scalar, scalar)

find the global by name and set it.  Has a helpful debugging message on
undefined globals.

=cut

sub set_global {
	my ($self, $name, $value) = @_;
	unless (exists($self->{'globals'}->{$name})) {
		$self->log_bug("Asked to set global value $name which doesn't exist.  Creating it and setting it.");
	}
	$self->{'globals'}->{$name} = $value;
	return;
}

=pod

=item (scalar) C<get_response> (void)

Return the response.  Should be an Apache::Constants response code.

=cut

sub get_response {
	my ($self) = @_;
	return $self->{'response'};
}

=pod

=item (scalar) C<set_response> (void)

Set the response.  Should be an Apache::Constants response code.

=cut

sub set_response {
	my ($self, $response) = @_;
	$self->{'response'} = $response;
	return;
}

=pod

=item (DBI::DBD::handle) C<dbh> (void)

Database handle object.  Collects database information from the initialization
data and calls _init_db with it.

=cut

sub dbh {
	my ($self) = shift;
	my $dba = $self->{'dba'};
	my $db = $self->{'database'};
	my $uname = $self->{'db_username'};
	my $pw = $self->{'db_password'};
	my $dbh = $self->_init_db($dba, $db, $uname, $pw);
	return $dbh if ($dbh);
	$self->log_bug('dbh was requested from DBL but no database could be initialized');
	return;
}

=pod

=item (Apache) C<req> (void)

Apache request object

=cut

sub req {
	my ($self) = shift;
	return $self->{'req'} if $self->{'mod_perl'};
	$self->log_bug('Apache Request Object requested from DBL, but none supplied at initialization.');
}

=pod

=item (scalar) C<user> (void)

Optional read-only method for an C<Apache::Wyrd::User> object.  Not used by the
default install.

=cut

sub user {
	my ($self) = shift;
	if ($self->{'user'}) {
		return $self->{'user'};
	} else {
		#attempt to create a null user if none is defined.
		my $req = $self->req;
		my $object_class = $req->dir_config('UserObject');
		if ($object_class) {
			eval "use $object_class";
			unless ($@) {
				my $user = undef;
				eval '$user = ' . $object_class . '->new()';
				unless ($@) {
					return $user;
				} else {
					$self->log_bug("User Object defined as $object_class, but could not be instantiated.  Reason: $@");
				}
			} else {
				$self->log_bug("You must define a user class with the UserObject directory configuration.  See `perldoc Apache::Wyrd::Services::Auth`.");
			}
		}
	}
	return undef;
}

=pod

=item (CGI/Apache::Request) C<apr> (void)

Apache::Wyrd::Request object (handle to either a CGI or Apache::Request object)

Wyrd/DBL.pm  view on Meta::CPAN

=item (scalar) C<param_exists> (scalar)

Returns a non-null value if the CGI variable indicated by the scalar argument
was actually returned by the client.

=cut

sub param_exists {
	my ($self, $value) = @_;
	return grep {$_ eq $value} $self->apr->param;
}

=pod

=item (scalar) C<file_path> (void)

return the path to the actual file being parsed.

=cut

sub file_path {
	my ($self) = shift;
	return $self->{'file_path'} if $self->{'file_path'};
	$self->log_bug('file_path was requested from DBL, but could not be determined.');
}

=pod

=item (scalar) C<self_path> (void)

return the document-root relative path to the file being served.

=cut

sub self_path {
	my ($self) = shift;
	return $self->{'self_path'} if $self->{'self_path'};
	$self->log_bug('self_path was requested from DBL, but could not be determined.');
}

=pod

=item (scalar) C<self_url> (void)

return an interpolated version of the current url.

=cut

sub self_url {
	my ($self) = @_;
	my $scheme = 'http:';
	$scheme = 'https:' if ($ENV{'HTTPS'} eq 'on');
	return $scheme . '//' . $self->req->hostname . $self->req->parsed_uri->unparse;
}

=pod

=item (internal) C<_init_db> (scalar, scalar, scalar, scalar);

open the DB connection.  Accepts a database type, a database name, a username,
and a password.  Defaults to a mysql database.  Sets the dbh parameter and the
dbh_ok parameter if the database connection was successful.  Meant to be called
from C<dbh>.  As of version 0.97 calls connect_cached instead of attempting to
maintain a cached connection itself.

=cut


sub _init_db {
	my ($self, $dba, $database, $db_uname, $db_passwd) = @_;
	my $dbh = undef;
	$dba ||= 'mysql';
	eval{$dbh = DBI->connect_cached("DBI:$dba:$database", $db_uname, $db_passwd)};
	$self->log_bug("Database init failed: $@") if ($@);
	return $dbh;
}

=pod

=item (internal) C<close_db> (void);

close the C<dbh> connection if it was opened.

=cut

sub close_db {
	my ($self) = @_;
	return undef unless ($self->{'dbh_ok'});
	$self->{'dbh'}->finish if (UNIVERSAL::can($self->{'dbh'}, 'finish'));
	$self->{'dbh'}->disconnect if (UNIVERSAL::can($self->{'dbh'}, 'disconnect'));
	return;
}

=item (scalarref) C<dump_log> (void)

return a scalarref to a html-formatted dump of the log.

=cut

sub dump_log {
	require Apache::Util;
	my ($self) = @_;
	my $out ="<code><small><b>Log Backtrace:</b><br>";
	foreach my $i (reverse(@{$self->{'dbl_log'}})) {
		$out .= Apache::Util::escape_html($i) . "<br>\n";
	}
	$out .= "</small></code>";
	return \$out;
}

=head1 BUGS

UNKNOWN

=head1 AUTHOR

Barry King E<lt>wyrd@nospam.wyrdwright.comE<gt>

=head1 SEE ALSO

=over