view release on metacpan or  search on metacpan

Wyrd/DBL.pm  view on Meta::CPAN

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

=pod

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

insert a debugging message in the session log.

=cut

sub log_bug {
	return unless (ref($_[0]) and ($_[0]->{'debug'}));
	my ($self, $value) = @_;
	my @caller = caller();
	$caller[0] =~ s/.+://;
	$caller[2] =~ s/.+://;
	my $id = "($caller[0]:$caller[2])";
	$value = join(':', $id, $value);
	push @{$self->{'dbl_log'}}, $value;
	warn $value;
}

=pod

=item (void) C<set_logfile> (filehandle typeglob)

give DBL a file in which to store it's events. The filehandle is then kept in
the logfile attribute.

=cut

sub set_logfile {
	my ($self, $fh) = @_;
	$| = 1;
	$self->{'logfile'} = $fh;
}

=pod

=item (void) C<close_logfile> (void)

flush logfile to disk.  Necessary in mod_perl situation, it seems.

=cut

sub close_logfile {
	my ($self, $fh) = @_;
	$self->{'logfile'} = $fh;
	close ($fh) if ($fh);
	eval("system('/bin/sync')");
}

=pod

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

same as log_bug, but don't send the output to STDERR. Instead, make it HTML escaped and store it for later dumping.

=cut

sub log_event {
	my ($self, $value) = @_;
	$self->{'dbl_log'} = [@{$self->{'dbl_log'}}, $value];
	my $fh = $self->{'logfile'};
	if ($fh) {
		print $fh (Apache::Util::escape_html($value) . "<br>\n");
	}
}

=pod

=item (hashref) C<base_class> (void)

return the base class of this set of Wyrds.

=cut

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

=pod

=item (hashref) C<taint_exceptions> (void)

Which params are allowed to contain information that could be interpreted as a
Wyrd.

=cut

sub taint_exceptions {
	my ($self) = @_;
	return @{$self->{'taint_exceptions'} || []};
}

=pod

=item (hashref) C<globals> (void)

return a reference to the globals hashref  Has a useful debugging message on unfound globals.

=cut

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

=pod

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

the modification time of the file currently being served.  Derived from
Apache::Wyrd::Handler, by default compatible with the C<stat()> builtin
function.

=cut

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

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

Wyrd/DBL.pm  view on Meta::CPAN

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

=item Apache::Wyrd

General-purpose HTML-embeddable perl object

=back

=head1 LICENSE

Copyright 2002-2007 Wyrdwright, Inc. and licensed under the GNU GPL.

See LICENSE under the documentation for C<Apache::Wyrd>.

=cut

1;