view release on metacpan or  search on metacpan

Wyrd/DBL.pm  view on Meta::CPAN

		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

sub verify_dbl_compatibility {
	return 1;
}

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

Optional read-only method for "strict" conditions.  Not used by the default install.

=cut

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

=pod

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

Optional read-only method for "loglevel" conditions.  Not used by the default install.

=cut

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;