view release on metacpan or  search on metacpan

Wyrd.pm  view on Meta::CPAN

	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 {
		$self->_info("Using $class from " . $self->base_class);
	}
	#if that doesn't work, go into the Apache::Wyrd class
	unless (ref($child)) {
		eval('require Apache::Wyrd::' . $class);
		eval('$child = Apache::Wyrd::' . $class . '->new($self->dbl, $init)');
		if ($@) {
			if ($@ =~ /^Can't locate object method "new"/) {
				$self->_error("No direct or indirect implementation of $class...");
			} else {
				$self->_raise_exception("Compilation Error while spawning a new Wyrd: " . $@);
			}
		}
		unless (ref($child)) {
			$self->_raise_exception("Giving up!  Don't know how to make a $child") if ($self->dbl->strict);
			$child = Apache::Wyrd->new($self->dbl, $init);
			$child->{'_attempted'} = $self->base_class . '::' . $class;
		}
	}

	#Restore the loglevel of this parent so that it's child's changes to the
	#global variable do not affect it.
	%_error_handler = %_error_handler_temp;

	return (undef, $self->base_class . "$class could not be generated.") unless ref($child);
	return $child, undef;
}

sub _invoke_html_wyrd {
	my ($self, $class, $params, $data, $original) = @_;
	my $base_class = $self->base_class;
	$self->_debug("$original is the original\n");
	$self->_debug("$base_class is the base class\n");
	$self->_debug("$class is the class\n");
	$self->_debug("$params is the params\n");
	$self->_debug("$data is the data\n");
	my $match = 0;
	my (%init, $init_ref, $unescape) = ();
	$self->_error("Attempted recursion of $class") if ($data =~ /<$base_class\:\:$class[\s>]/);
	#drop the nest identifier
	$class =~ s/([^:]):([^:]+)$/$1/ && $self->_info("dropped the nest identifier $2");
	#encode the escaped-out " and '
	$params =~ s/\\'/<!apostrophe!>/g;
	$params =~ s/\\"/<!quote!>/g;
	#escape-out special characters when they are the only attribute
	$params =~ s/\$/<!dollar!>/g;
	$params =~ s/\@/<!at!>/g;
	$params =~ s/\%/<!percent!>/g;
	$params =~ s/\&/<!ampersand!>/g;
	#nullify the blank attributes
	$params =~ s/""/"<!null!>"/g;
	$params =~ s/''/'<!null!>'/g;
	#zerofy the numerical zero attributes
	$params =~ s/"0"/"<!zero!>"/g;
	$params =~ s/'0'/'<!zero!>'/g;
	#Process Params:
	do {
		$match = 0;
		$match = ($params =~ m/
			\G					#last search match
			[^\w-]*				#any amount of non-word space
			(?:					#non-capturing cluster 1
				([^=]+)			#non-equals
				\s*=\s*			#an equals with or without whitespace around it
					(?:			#non-capturing cluster 2
					"([^"]+)"	#non-double-quotes surrounded by double-quotes
					|			#or
					'([^']+)'	#non-single-quotes surrounded by single quotes
					)			#end of non-capturing cluster 2
				|				#or
					([\w-]+)	#plain word
			)					#end of non-matching cluster 1
			\W*					#and any amount of non-word space
			/xmsg);
		if ($match) {
			#warn "1: $1 2: $2 3: $3 4: $4";
			if ($1) {
				$init{lc($1)} = ($2 || $3);
				$self->_debug(lc($1) . " is '" . $init{$1} . "'\n");
			} else {
				$init{lc($4)} = 1;
				$self->_debug(lc($4) . " is '1'\n");
			}
		}
	} while $match;
	foreach my $i (keys(%init)) {
		$init{$i} =~ s/<!apostrophe!>/'/g;
		$init{$i} =~ s/<!quote!>/"/g;
		$init{$i} =~ s/<!null!>//g;
		$init{$i} =~ s/<!zero!>/0/g;
		$init{$i} =~ s/<!dollar!>/\$/g;
		$init{$i} =~ s/<!at!>/\@/g;
		$init{$i} =~ s/<!percent!>/\%/g;
		$init{$i} =~ s/<!ampersand!>/\&/g;
	}

	#store the HTML of the wyrd
	$init{'_as_html'} = $original;
	$init{'_data'} = $data || '';

	#spawn the new object
	my ($wyrd, $err) = $self->_spawn($class, \%init);

	#Either call output on the object or give up
	if ($err) {
		$self->_error($err);
		return $original;
	} else {
		$self->_debug("newly spawned object reference is " . ref($wyrd) . "\n");
		my $output = $wyrd->output;
		$wyrd->_shutdown;
		return $output;
	}
}

sub _invoke_wyrd {
	my ($self, $class, $init) = @_;

	my ($wyrd, $err) = $self->_spawn($class, $init);

	if ($err) {
		$self->_error($err);
		return join(':', 'Error when invoked from Wyrd at', caller);
	} else {
		$self->_debug("newly spawned object reference is " . ref($wyrd) . "\n");
		my $output = $wyrd->output;
		return $output;
	}
}

#process_flags makes a lightweight Tree object which can be accessed
#using $wo_ref->_flags->n where n is the flag
sub _process_flags {
	my ($self, $flags) = @_;
	my (%init) = ();
	my @flags = token_parse($flags);
	foreach my $i (@flags) {
		$init{$i} = 1;
	}
	$flags = Apache::Wyrd::Services::Tree->new(\%init);
	return $flags;
}

1;