view release on metacpan or  search on metacpan

Wyrd.pm  view on Meta::CPAN

use 5.006;
use strict;
use warnings;
no warnings qw(uninitialized);

package Apache::Wyrd;
our $VERSION = '0.98';
use Apache::Wyrd::Services::SAK qw (token_parse slurp_file);
use Apache::Wyrd::Services::Tree;
use Apache::Util;
use Apache::Constants qw(:common);

###############################################################################
#Globals
###############################################################################

my $_dbl = undef;

my %_loglevel = (
	'fatal'		=>	0,
	'error'		=>	1,
	'warn'		=>	2,
	'info'		=>	3,
	'debug'		=>	4,
	'verbose'	=>	5,
);

###############################################################################
#Error Handling Anonymous Subroutines
###############################################################################

my %_error_handler = ();

my $_disabled_error_handler = sub {
	return undef
};

my $_enabled_error_handler = sub {
	my ($self, $value) = @_;
	my @caller = caller();
	$caller[0] =~ s/.+://;
	$caller[2] =~ s/.+://;
	my $id = "($caller[0]:$caller[2])";
	$value = join(':', $id, $value);
	$_dbl->log_event($value) if ($_dbl);
	print STDERR "$value\n";
};

my $_fatal_error_handler = sub {
	my ($self, $value) = @_;
	die "_raise_exception called without object.  Always call _raise_exception as a method, not a subroutine."
		unless UNIVERSAL::isa($self, 'Apache::Wyrd');
	my @caller = caller();
	$caller[0] =~ s/.+://;
	$caller[2] =~ s/.+://;
	my $processing = undef;
	$processing = $self->dbl->self_path if ($_dbl);
	$processing ||= "{COULD NOT PROCESS PATH TO PERL OBJECT}";#assume self_path could be erroneously null
	my $id = "($processing -- $caller[0]:$caller[2])";
	$value = join(':', $id, $value , "\n". $self->{'_as_html'} . "\n");
	if ($_dbl) {
		my $htmlvalue = join(':', $id, $value , "<BR>\n". Apache::Util::escape_html($self->{'_as_html'}) . "<BR>\n");
		$_dbl->log_event($htmlvalue);
	}
	die $value;
};

sub _verbose {
	goto $_error_handler{$_loglevel{'verbose'}};
}

sub _debug {
	goto $_error_handler{$_loglevel{'debug'}};
}

sub _info {
	goto $_error_handler{$_loglevel{'info'}};
}

sub _warn {
	goto $_error_handler{$_loglevel{'warn'}};
}

sub _error {
	goto $_error_handler{$_loglevel{'error'}};
}

sub _fatal {
	goto $_error_handler{$_loglevel{'fatal'}};
}

sub _raise_exception {
	goto $_fatal_error_handler;
}

=pod

=head1 NAME

Apache::Wyrd - HTML embeddable perl objects under mod_perl

=head1 SYNOPSIS

NONE

=head1 DESCRIPTION

Apache::Wyrd is the core module in a collection of interoperating
modules that allow the rapid object-oriented development of web sites in
Apache's mod_perl environment (LAMP).  This collection includes a very
flexible, HTML-friendly method of defining dynamic items on a web page,
and interfacing directly to perl objects with them.  It comes with many
pre-built objects to support a web site such as an authentication

Wyrd.pm  view on Meta::CPAN

    $self->_flags->reverse(0);

=back

=head2 PERL METHODS

Unlike most perl modules, modules derived from Apache::Wyrd attempt to
leave public methods open to the developer so that they can appear as
attributes in the corresponding HTML.  Hence, most important Wyrd
methods are private and are denoted as such by a leading underscore (_).
 Some methods are public, usually for obvious or traditional reasons.

=head3 PUBLIC METHODS

In most cases, a given HTML attribute will be available to the Wyrd directly by
accessing C<$self-E<gt>{attribute}>.  For convenience, these can be accessed via
a method call to the name of the attribute (I<example:> C<$value =
$self-E<gt>attributename>).  If the method call has an argument, it means to set
rather than retrieve the attribute (I<example:>
C<$self-E<gt>attributename($value)>).

B<Important Documentation Note:> Since the paragraph above describes the
default behavior for attributes, a perl method is not described in the
POD for these modules for any attributes UNLESS the method has been
explicitly defined, for example, to make the attribute read-only or be a
value other than scalar.

=cut

###############################################################################
#Public Methods
###############################################################################

#autoload will return the value of a variable unless provided with a value,
#in which case it will set it.  It will raise an exception if the variable has not
#been defined beforehand.
sub AUTOLOAD {
	no strict 'vars';
	my ($self, $newval) = @_;
	#Catch destruction events gracefully
	return undef if ($AUTOLOAD =~ /DESTROY$/);
	$AUTOLOAD =~ s/.*:://;
	#warn ("Auto-Loading $AUTOLOAD");
	if ($AUTOLOAD =~ /_format_(.+)/){
		#_format_HTMLTAGNAME allows an object to "entag" items in a simplified version
		#of what the CGI module does
		return $self->_generate_tag($1, $newval);
	}
	if (ref($self)) {
		if(defined($self->{$AUTOLOAD})){
			#if the method is called with no argument it's a GET value request
			return $self->{$AUTOLOAD} unless (scalar(@_) == 2);
			#if the method is called with an argument, it's a SET value request
			$self->{$AUTOLOAD} = $newval;
			#set always returns the value it is set to (no reason, may be useful for catching
			#errors down the road).
			return $newval;
		} elsif (ref($self) && &UNIVERSAL::can($self, '_raise_exception')) {
			$self->_error("Dead because of \$self->" . $AUTOLOAD . " being called.  You probably need to define this function/attribute or import it from somewhere else.");
			return $self->_raise_exception("Undefined variable was accessed in AUTOLOAD: $AUTOLOAD at " . join(':', caller()));
		}
	}
	die ("Dead because an undefined subroutine in a non-method call was executed: " . $AUTOLOAD . "() at " . join(':', caller()) . ".  You probably need to correct/define this subroutine or import it from somewhere else.  This error was reported by Wyrd...
}

=pod

Note: methods are described I<(format: (returned value/s) C<methodname>
(arguments))>, where the first argument, representing the object itself, is
assumed, since the method is called using the standard notation
C<$object-E<gt>method>.

=over

=item (Apache::Wyrd ref) C<new> (Apache::Wyrd::DBL ref, hashref)

create and return a Wyrd object

=cut

sub new {
	my ($class, $dbl, $init) = @_;
	my $data = _init($dbl, $init);
	bless ($data, $class);
	$data->{'_class_name'} = $class;
	my $base_class = $dbl->base_class;
	$base_class ||= $init->{'_parent'}->{'_base_class'};
	unless ($base_class) {
		$class =~ s/([^:]+)::.+/$1/;
		$base_class ||= $class;
		$base_class ||= 'Apache::Wyrd';
	}
	$data->{'_base_class'} = $base_class;
	$data->_setup unless ($data->_flags->disable);
	return ($data);
}

=pod

=item (Apache::Wyrd ref) C<clone> (void)

make an identical copy of this Wyrd

=cut

sub clone {
	my ($self) = @_;
	my $data = {map {$_, $self->{$_}} keys %$self};
	bless $data, $self->_class_name;
	return $data;
}

=pod

=item (Apache::Wyrd::DBL ref) C<dbl> (void)

the current DBL

=cut

#defined to make this a read-only method
sub dbl {
	return $_dbl;