view release on metacpan or  search on metacpan

Wyrd.pm  view on Meta::CPAN

=cut

sub _init{
	my ($dbl, $init) = @_;
	#NOTE: Because DBL is tested here for DBL compatibility, it does not need to be tested again anywhere else
	#in a Wyrd.  If it is defined, it is a DBL.
	my $not_hash = (ref($init) ne 'HASH');
	if (ref($dbl) and UNIVERSAL::can($dbl, 'verify_dbl_compatibility')) {
		$_dbl = $dbl;
		$dbl->log_bug("ERROR: Invalid data (non-hashref) apparently given to object as Initial Value -- Ignoring")
			if ($not_hash);
	}
	$init = {} if ($not_hash);
	foreach my $level (values %_loglevel) {
		$_error_handler{$level} = $_disabled_error_handler;
	}
	#must test for existence, since a loglevel can be 0 and, therefore, false
	$init->{'loglevel'} = ($dbl->loglevel || 1) unless (exists($init->{'loglevel'}));
	$init->{'loglevel'} = ($_loglevel{$init->{'loglevel'}} || $init->{'loglevel'} || 0);
	for (my $level=0; $init->{'loglevel'} >= $level; $level++) {
		$_error_handler{$level} = $_enabled_error_handler;
	}
	#set the dielevel (level lower than which, execution will terminate.  The _raise_exception() method will
	#always terminate.
	$init->{'dielevel'} = ($_loglevel{$init->{'dielevel'}} || $init->{'dielevel'} || 0);
	for (my $level=0; $init->{'dielevel'} >= $level; $level++) {
		$_error_handler{$level} = $_fatal_error_handler;
	}
	$init->{'_flags'}=Apache::Wyrd::Services::Tree->new unless ($init->{'_flags'});
	return $init;
}

#Called by output, the start of the recursive chain which interprets embedded
#Apache::Wyrd, calling their output methods in returning
sub _process_self {
	my ($self) = @_;
	my $depth = ($self->{'_depth'} || 10);
	my ($test, $temp) = (1, undef);
	my $class = $self->base_class;
	#warn "base class is $class";
	do {
		#Replace each tag with its spawned contents
		#$1 = whole Object
		#$2 = class
		#$4/$5 = params
		#$6 = Enclosed Data
		$temp = $self->{'_data'};
		$test = ($temp =~
				s[
					(						#$1
						<					#tag beginning
							$class
							::
							(				#$2 v
								[:\w]+		#class
							)
						(					#$3
							(				#$4 v
								[^>]*		#params and
							)
							\s/>			#endpoint
						|					#or
							(				#5 v
								[^>]*		#params and
							)
							>				#closure plus...
								(			#$6 v
									.*?		#data
								)
							</
								$class
								::
								\2			#matched class
							>
						)
					)
				]
				[
					$self->_invoke_html_wyrd($2, ($5 || $4), $6, $1)#(real) object id, parameters, enclosed data, complete expr.
				]gexis);
		$test = 0 if ($self->_flags->disable);
		$self->{'_depth_counter'}++;
		$self->{'_data'} = $temp;
		#warn "after iteration " . $self->_depth_counter . " test is " . $test . " values are ID='$2' params='$3' data='$4'...";
	} while ($test and ($self->{'_depth_counter'} < $depth));
	return;
}

#_spawn produces the child object, returns an error message if it can't be generated.
sub _spawn {
	my ($self, $class, $init) = @_;

	$init->{'_parent'} = $self;

	#Convert the flags attribute to a flags Tree object
	$init->{'_flags'} = $self->_process_flags($init->{'flags'});
	#Why delete it?  It may be useful.
	#delete $init->{'flags'};

	#allow user-defined filters on all Wyrds
	($class, $init) = $self->_pre_spawn($class, $init);

	#loglevel/dielevel will be inherited if it exists, but not if the object explicitly has it defined
	$init->{'loglevel'} = $self->{'loglevel'} unless(exists($init->{'loglevel'}));
	$init->{'dielevel'} = $self->{'dielevel'} unless(exists($init->{'dielevel'}));

	#Temporarily "hide" the global so that loglevel changes in children do not
	#propagate back up into their parents.
	my %_error_handler_temp = %_error_handler;

	my ($child) = ();
	#first attempt to find a perl class which is in the base_class hierarchy
	eval('require ' . $self->base_class . '::' . $class);
	eval('$child = ' . $self->base_class . '::' . $class . '->new($self->dbl, $init)');
	if ($@) {
		if ($@ =~ /^Can't locate object method "new"/) {
			$self->_info("No direct implementation of $class in " . $self->base_class . " Looking in core class...");
		} else {
			$self->_raise_exception("Compilation Error in " . $self->base_class . "::" . $class . ":" . $@);
		}
	} else {