Apache-Wyrd

 view release on metacpan or  search on metacpan

Wyrd/DBL.pm  view on Meta::CPAN

=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

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)

Wyrd/DBL.pm  view on Meta::CPAN

=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)

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

=cut

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

=pod

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

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

=cut

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


=pod

Wyrd/DBL.pm  view on Meta::CPAN

	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)

=cut

sub apr {
	my ($self) = shift;
	return $self->{'apr'};
}

=pod

=item (scalar/arrayref) C<param> ([scalar])

Like CGI->param().  As a security measure, any data found in parameters which
matches the name of the Wyrds on a given installation, I<e.g. BASENAME> is
dropped unless the variable is named in the array of variable names stored
by reference under the C<taint_exceptions> key of the BASENAME::Handler's
C<init()> function.

=cut

sub param {
	my ($self, $value, $set) = @_;
	return $self->apr->param($value, $set) if (scalar(@_) > 2);
	if ($value) {
			if (grep {$value eq $_} $self->taint_exceptions) {
				return $self->apr->param($value);
			}
			my $forbidden = qr/<$self->{base_class}/;
			if (wantarray) {
				return grep {$_ !~ /$forbidden/} $self->apr->param($value);
			} else {
				my $result = $self->apr->param($value);
				if ($result !~ /$forbidden/) {
					return $result
				}
				return;
			}
	}
	return $self->apr->param;
}

=pod

=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