File Coverage

blib/lib/MasonX/Request/ExtendedCompRoot.pm

Criterion	Covered	Total	%
statement	18	127	14.1
branch	0	68	0.0
condition	0	6	0.0
subroutine	6	14	42.8
pod	6	6	100.0
total	30	221	13.5

# This software is copyright (c) 2004 Alex Robinson.
# It is free software and can be used under the same terms as perl,
# i.e. either the GNU Public Licence or the Artistic License.

package MasonX::Request::ExtendedCompRoot;

use strict;

our $VERSION = '0.03';

use base qw(HTML::Mason::Request);

# fetch_comp needs this
use HTML::Mason::Tools qw(absolute_comp_path);
use HTML::Mason::Exceptions( abbr => [qw(param_error error)] );
use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub { param_error( join '', @_ ) } );
use File::Spec;# qw(canonpath file_name_is_absolute);

# this absurdity, because there's a bug if you leave it out or pass no args
__PACKAGE__->valid_params(blop => 0);

#
# Standard request subclass alter_superclass dance
#
sub new
{
    my $class = shift;
    $class->alter_superclass( $HTML::Mason::ApacheHandler::VERSION ?
                              'HTML::Mason::Request::ApacheHandler' :
                              $HTML::Mason::CGIHandler::VERSION ?
                              'HTML::Mason::Request::CGI' :
                              'HTML::Mason::Request' );
    return $class->SUPER::new(@_);
}

#
# Given a component path (absolute or relative), returns a component.
# Handles SELF, PARENT, REQUEST, comp:method, relative->absolute
# conversion, and local subcomponents.
#
# Basically copied and pasted from HTML::Mason::Request
#Êsee inline comments for diffs
#
sub fetch_comp
{
    my ($self,$path) = @_;
    param_error "fetch_comp: requires path as first argument" unless defined($path);

    #
    # Handle paths SELF and PARENT
    #
    if ($path eq 'SELF') {
	return $self->base_comp;
    }
    if ($path eq 'PARENT') {
	my $c = $self->current_comp->parent
	    or error "PARENT designator used from component with no parent";
	return $c;
    }
    if ($path eq 'REQUEST') {
        return $self->request_comp;
    }

##### Additions/Changes to Request.pm #####
	#
	# Handle paths of the form comp_root=>comp_path
	# Make calls to specific comp_roots appear to be absolute paths
	if (index($path,'=>') != -1)
		{
		$path =~ s|^/*|/|;
		}

    #
    # Handle paths of the form comp_path:method_name
    #
    if (index($path,':') != -1) {
	my ($method_comp,$owner_comp);
	my ($owner_path,$method_name) = split(':',$path,2);

	my @comp_root = $self->comp_root;
	foreach (@comp_root)
		{
		$owner_comp = undef;
		my $owner_path_with_comp_root = $owner_path;
		if ($owner_path_with_comp_root =~ m/^(SELF|PARENT|REQUEST)$/)
			{
			# leave alone - these are the special paths
			}
		elsif (index($owner_path_with_comp_root,'=>') == -1)
			{
			# make comp_path into comp_root=>comp_path unless it already is
			$owner_path_with_comp_root = $_->[0].'=>'.$owner_path_with_comp_root;
			}
		$owner_comp = $self->fetch_comp($owner_path_with_comp_root);
		next unless ($owner_comp);
		$owner_comp->_locate_inherited('methods',$method_name,\$method_comp);
		# nothing more to be done since, success, we have a method_comp
		last if ($method_comp);
		# nothing more to be done as path is special or an explicit comp_root call
		last if $owner_path eq $owner_path_with_comp_root;
		}
# now do the error handling
	unless ($owner_comp) { error "could not find component for path '$owner_path'\n"; }
	unless ($method_comp) { error "no method '$method_name' for component " . $owner_comp->name; }
# owner_comp->title tweaked to owner_comp->name
	return $method_comp;
    }
##### Additions to Request.pm end #####

    #
    # If path does not contain a slash, check for a subcomponent in the
    # current component first.
    #
    if ($path !~ /\//) {
	my $cur_comp = $self->current_comp;
	# Check my subcomponents.
	if (my $subcomp = $cur_comp->subcomps($path)) {
	    return $subcomp;
	}
	# If I am a subcomponent, also check my owner's subcomponents.
	# This won't work when we go to multiply embedded subcomponents...
	if ($cur_comp->is_subcomp and my $subcomp = $cur_comp->owner->subcomps($path)) {
	    return $subcomp;
	}
    }

    #
    # Otherwise pass the absolute path to interp->load.
    #
    # For speed, don't call ->current_comp, instead access it directly
    $path = absolute_comp_path($path, $self->{stack}[-1]{comp}->dir_path)
	unless substr($path, 0, 1) eq '/';

    my $comp = $self->interp->load($path);

    return $comp;
}

#
# Call Request.pm's exec, then put comp_root back
# to what it was when the current request or subrequest was made
#
sub exec
	{
	my $self = shift;
	my $return_exec = $self->SUPER::exec(@_);
	$self->reset_comp_root;
	return $return_exec;
	}

#
# return comp_root array and optionally set it
#
sub comp_root
	{
	my $self = shift;
	my @comp_root = $self->_validate_comp_root_args(@_);
	if (@comp_root)
		{
		$self->_store_comp_root;
		$self->interp->resolver->{comp_root} = \@comp_root;
		}
	return @{$self->interp->resolver->{comp_root}};
	}

#
# add further comp_roots to the beginning of the comp_root array
#
sub prefix_comp_root
	{
	my $self = shift;
	my @prefix_comp_root = $self->_validate_comp_root_args(@_);
	return unless (@prefix_comp_root);
	my %seen;
	foreach my $root (@{$self->interp->resolver->{comp_root}})
		{
		$seen{$root->[0]} = 1;
		}
	foreach my $root (@prefix_comp_root)
		{
	   	param_error "comp_root '$root->[0]' already exists" if ($seen{$root->[0]});
    	}
	$self->_store_comp_root;
	unshift(@{$self->interp->resolver->{comp_root}}, @prefix_comp_root);
	return;
	}

#
# put comp_root back to how it was at the beginning of the current (sub)request
#
sub reset_comp_root
	{
	my $self = shift;
	if ($self->{store_comp_root})
		{
		my @copy_store = @{$self->{store_comp_root}};
		$self->interp->resolver->{comp_root} = \@copy_store;
		$self->{store_comp_root} = undef;
		}
	return;
	}

#
# make sure we know what the original comp_root was
#
sub _store_comp_root
	{
	my $self = shift;
	unless ($self->{store_comp_root})
		{
		my @copy_root = @{$self->interp->resolver->{comp_root}};
		$self->{store_comp_root} = \@copy_root;
		}
	return;
	}

#
# make sure that args are valid and marshall into required array format
#
sub _validate_comp_root_args
	{
	my $self = shift;
	my @check_comp_root = @_;

	my $array_check = ref($check_comp_root[0]);
	if ($array_check eq "ARRAY")
		{
		my $inner_array_check = ref($check_comp_root[0][0]);
		if  ( ($inner_array_check =~ /ARRAY|HASH/s) or (index($check_comp_root[0][0],'=>') != -1) )
			{
			for (my $i = scalar(@{$check_comp_root[0]}) - 1; $i >= 0; $i--)
				{
				$check_comp_root[$i] = $check_comp_root[0][$i];
				}
			}
		}

	my %seen;
	foreach (@check_comp_root)
		{
		my $ref_check = ref($_);
		unless ($ref_check =~ m/ARRAY|HASH/)
			{
			my $string = $_;
			if (index($string,'=>') != -1)
				{
				my @root_split = split('=>', $string);
				if ($root_split[2]) { die "Too many delimiters in comp_root $string"; }
				$_ = \@root_split;
				}
			else { die "$string is wrong - comp_root should take the form 'comp_root_name=>/path/to/comp_root'"; }
			}
		if ($ref_check =~ m/HASH/)
			{
			my %hash_store = %{$_};
			foreach my $key (keys %hash_store)
				{
				$_ = [$key, $hash_store{$key}];
				}
			}
		$_->[1] = File::Spec->canonpath( $_->[1] );
		param_error "path specified for comp_root '$_->[0]' ($_->[1]) is not an absolute directory" unless File::Spec->file_name_is_absolute( $_->[1] );
		param_error "path specified for comp_root '$_->[0]' ($_->[1]) does not exist" unless (-d $_->[1]);
		param_error "comp_root '$_->[0]' should only be specified once" if $seen{$_->[0]}++;
		}
	return @check_comp_root;
	}

1;


__END__