File Coverage

blib/lib/HTML/Mason/Component.pm

Criterion	Covered	Total	%
statement	138	151	91.3
branch	46	64	71.8
condition			n/a
subroutine	36	40	90.0
pod	20	30	66.6
total	240	285	84.2

# Copyright (c) 1998-2005 by Jonathan Swartz. All rights reserved.
# This program is free software; you can redistribute it and/or modify it
# under the same terms as Perl itself.

package HTML::Mason::Component;
$HTML::Mason::Component::VERSION = '1.60';
use strict;
use warnings;
use File::Spec;
use HTML::Mason::Exceptions( abbr => [qw(param_error)] );
use HTML::Mason::Tools qw(absolute_comp_path can_weaken);
use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub { param_error join '', @_  } );

use HTML::Mason::Exceptions( abbr => ['error'] );
use HTML::Mason::MethodMaker
    ( read_only => [ qw( code
                         comp_id
                         compiler_id
                         declared_args
                         inherit_path
                         inherit_start_path
                         has_filter
                         load_time
                       ) ],

      read_write => [ [ dynamic_subs_request => { isa => 'HTML::Mason::Request' } ],
                      [ mfu_count => { type => SCALAR } ],
                      [ filter => { type => CODEREF } ],
                    ]
      );

# for reference later
#
# __PACKAGE__->valid_params
#     (
#      attr               => {type => HASHREF, default => {}, public => 0},
#      code               => {type => CODEREF, public => 0, public => 0},
#      load_time          => {type => SCALAR,  optional => 1, public => 0},
#      declared_args      => {type => HASHREF, default => {}, public => 0},
#      dynamic_subs_init  => {type => CODEREF, default => sub {}, public => 0},
#      flags              => {type => HASHREF, default => {}, public => 0},
#      comp_id            => {type => SCALAR,  optional => 1, public => 0},
#      methods            => {type => HASHREF, default => {}, public => 0},
#      mfu_count          => {type => SCALAR,  default => 0, public => 0},
#      parser_version     => {type => SCALAR,  optional => 1, public => 0}, # allows older components to be instantied
#      compiler_id        => {type => SCALAR,  optional => 1, public => 0},
#      subcomps           => {type => HASHREF, default => {}, public => 0},
#     );
#

my %defaults = ( attr              => {},
                 declared_args     => {},
                 dynamic_subs_init => sub {},
                 flags             => {},
                 methods           => {},
                 mfu_count         => 0,
                 subcomps          => {},
               );
sub new
{
    my $class = shift;
    my $self = bless { %defaults, @_ }, $class;

    # Initialize subcomponent and method properties: owner, name, and
    # is_method flag.
    while (my ($name,$c) = each(%{$self->{subcomps}})) {
        $c->assign_subcomponent_properties($self,$name,0);
        Scalar::Util::weaken($c->{owner}) if can_weaken;
    }
    while (my ($name,$c) = each(%{$self->{methods}})) {
        $c->assign_subcomponent_properties($self,$name,1);
        Scalar::Util::weaken($c->{owner}) if can_weaken;
    }

    return $self;
}

my $comp_count = 0;
sub assign_runtime_properties {
    my ($self, $interp, $source) = @_;
    $self->interp($interp);
    $self->{comp_id} = defined $source->comp_id ? $source->comp_id : "[anon ". ++$comp_count . "]";

    $self->{path} = $source->comp_path;

    $self->_determine_inheritance;

    foreach my $c (values(%{$self->{subcomps}}), values(%{$self->{methods}})) {
        $c->assign_runtime_properties($interp, $source);
    }

    # Cache of uncanonicalized call paths appearing in the
    # component. Used in $m->fetch_comp.
    #
    if ($interp->use_internal_component_caches) {
        $self->{fetch_comp_cache} = {};
    }
}

sub flush_internal_caches
{
    my ($self) = @_;

    $self->{fetch_comp_cache} = {};
    delete($self->{parent_cache});
}

sub _determine_inheritance {
    my $self = shift;

    my $interp = $self->interp;

    # Assign inheritance properties
    if (exists($self->{flags}->{inherit})) {
        if (defined($self->{flags}->{inherit})) {
            $self->{inherit_path} = absolute_comp_path($self->{flags}->{inherit}, $self->dir_path);
        }
    } elsif ( $interp->use_autohandlers ) {
        if ($self->name eq $interp->autohandler_name) {
            unless ($self->dir_path eq '/') {
                ($self->{inherit_start_path}) = $self->dir_path =~ m,^(.*/)?.*,s
            }
        } else {
            $self->{inherit_start_path} = $self->dir_path;
        }
    }
}

sub run {
    my $self = shift;

    $self->{mfu_count}++;

    $self->{code}->(@_);
}

sub dynamic_subs_init {
    my $self = shift;

    error "cannot call a method or subcomponent from a <%shared> block"
        if $self->{in_dynamic_subs_init};

    local $self->{in_dynamic_subs_init} = 1;

    $self->{dynamic_subs_hash} = $self->{dynamic_subs_init}->();
    error "could not process <%shared> section (does it contain a return()?)"
        unless ref($self->{dynamic_subs_hash}) eq 'HASH';
}

sub run_dynamic_sub {
    my ($self, $key, @args) = @_;

    error "call_dynamic: assert error - could not find code for key $key in component " . $self->title
        unless exists $self->{dynamic_subs_hash}->{$key};

    return $self->{dynamic_subs_hash}->{$key}->(@args);
}

# Legacy, left in for pre-0.8 obj files
sub assign_subcomponent_properties {}

#
# By default components are not persistent.
#
sub persistent { 0 }

#
# Only true in Subcomponent subclass.
#
sub is_subcomp { 0 }

sub is_method { 0 }

#
# Only true in FileBased subclass.
#
sub is_file_based { 0 }

#
# Basic defaults for component designators: title, path, name, dir_path
#
sub title { return $_[0]->{comp_id} }
sub name { return $_[0]->{comp_id} }
sub path { return undef }
sub dir_path { return undef }

#
# Get all subcomps or particular subcomp by name
#
sub subcomps {
    my ($self,$key) = @_;
    if (defined($key)) {
        return $self->{subcomps}->{$key};
    } else {
        return $self->{subcomps};
    }
}

#
# Get all methods or particular method by name
#
sub methods {
    my ($self,$key) = @_;
    if (defined($key)) {
        return $self->{methods}->{$key};
    } else {
        return $self->{methods};
    }
}

#
# Get all attributes
#
sub attributes { $_[0]->{attr} }

#
# Get attribute by name
#
sub attr {
    my ($self,$name) = @_;
    my $value;
    if ($self->_locate_inherited('attr',$name,\$value)) {
        return $value;
    } else {
        error "no attribute '$name' for component " . $self->title;
    }
}

sub attr_if_exists {
    my ($self,$name) = @_;
    my $value;
    if ($self->_locate_inherited('attr',$name,\$value)) {
        return $value;
    } else {
        return undef;
    }
}

#
# Determine if particular attribute exists
#
sub attr_exists {
    my ($self,$name) = @_;
    return $self->_locate_inherited('attr',$name);
}

#
# Call method by name
#
sub call_method {
    my ($self,$name,@args) = @_;
    my $method;
    if ($self->_locate_inherited('methods',$name,\$method)) {
        HTML::Mason::Request->instance->comp({base_comp=>$self},$method,@args);
    } else {
        error "no method '$name' for component " . $self->title;
    }
}

#
# Like call method, but return component output.
#
sub scall_method {
    my ($self,$name,@args) = @_;
    my $method;
    if ($self->_locate_inherited('methods',$name,\$method)) {
        HTML::Mason::Request->instance->scomp({base_comp=>$self},$method,@args);
    } else {
        error "no method '$name' for component " . $self->title;
    }
}

#
# Determine if particular method exists
#
sub method_exists {
    my ($self,$name) = @_;
    return $self->_locate_inherited('methods',$name);
}

#
# Locate a component slot element following inheritance path
#
sub _locate_inherited {
    my ($self,$field,$key,$ref) = @_;
    my $count = 0;
    for (my $comp = $self; $comp; $comp = $comp->parent) {
        if (exists($comp->{$field}->{$key})) {
            $$ref = $comp->{$field}->{$key} if $ref;
            return 1;
        }
        error "inheritance chain length > 32 (infinite inheritance loop?)"
            if ++$count > 32;
    }
    return 0;
}

#
# Get particular flag by name
#
sub flag {
    my ($self,$name) = @_;
    my %flag_defaults =
        (
         );
    if (exists($self->{flags}->{$name})) {
        return $self->{flags}->{$name};
    } elsif (exists($flag_defaults{$name})) {
        return $flag_defaults{$name};
    } else {
        error "invalid flag: $name";
    }
}

#
# Return parent component according to inherit flag.
#
sub parent {
    my ($self) = @_;

    # Return cached value for parent, if any (may be undef)
    #
    return $self->{parent_cache} if exists($self->{parent_cache});

    my $interp = $self->interp;
    my $parent;
    if ($self->inherit_path) {
        $parent = $interp->load($self->inherit_path)
            or error(sprintf("cannot find inherit path '%s' for component '%s'",
                             $self->inherit_path, $self->title));
    } elsif ($self->inherit_start_path) {
        $parent = $interp->find_comp_upwards($self->inherit_start_path, $interp->autohandler_name);
    }

    # Can only cache parent value if interp->{use_internal_component_caches} is on -
    # see definition in Interp::_initialize.
    #
    if ($interp->use_internal_component_caches) {
        $self->{parent_cache} = $parent;
    }

    return $parent;
}

sub interp {
    my $self = shift;

    if (@_) {
        validate_pos( @_, { isa => 'HTML::Mason::Interp' } );

        $self->{interp} = $_[0];

        Scalar::Util::weaken( $self->{interp} ) if can_weaken;
    } elsif ( ! defined $self->{interp} ) {
        die "The Interp object that this object contains has gone out of scope.\n";
    }

    return $self->{interp};
}

#
# Accessors for various files associated with component
#
sub object_file {
    my $self = shift;
    return $self->interp->object_file($self);
}

# For backwards compatibility with 1.0x
sub create_time {
    my $self = shift;
    return $self->load_time(@_);
}

# Create logger on demand - generally called from $m->log
sub logger {
    my ($self) = @_;

    if (!$self->{logger}) {
        my $log_category = "HTML::Mason::Component" . $self->path();
        $log_category =~ s/\//::/g;
        $self->{logger} = Log::Any->get_logger(category => $log_category);
    }
    return $self->{logger};
}

1;

__END__