File Coverage

blib/lib/Class/Container.pm

Criterion	Covered	Total	%
statement	203	249	81.5
branch	78	136	57.3
condition	30	50	60.0
subroutine	29	31	93.5
pod	12	17	70.5
total	352	483	72.8

package Class::Container;

$VERSION = '0.12';
$VERSION = eval $VERSION if $VERSION =~ /_/;

my $HAVE_WEAKEN;
BEGIN {
  eval {
    require Scalar::Util;
    Scalar::Util->import('weaken');
    $HAVE_WEAKEN = 1;
  };

  *weaken = sub {} unless defined &weaken;
}

use strict;
use Carp;

# The create_contained_objects() method lets one object
# (e.g. Compiler) transparently create another (e.g. Lexer) by passing
# creator parameters through to the created object.
#
# Any auto-created objects should be declared in a class's
# %CONTAINED_OBJECTS hash.  The keys of this hash are objects which
# can be created and the values are the default classes to use.

# For instance, the key 'lexer' indicates that a 'lexer' parameter
# should be silently passed through, and a 'lexer_class' parameter
# will trigger the creation of an object whose class is specified by
# the value.  If no value is present there, the value of 'lexer' in
# the %CONTAINED_OBJECTS hash is used.  If no value is present there,
# no contained object is created.
#
# We return the list of parameters for the creator.  If contained
# objects were auto-created, their creation parameters aren't included
# in the return value.  This lets the creator be totally ignorant of
# the creation parameters of any objects it creates.

use Params::Validate qw(:all);
Params::Validate::validation_options( on_fail => sub { die @_ } );

my %VALID_PARAMS = ();
my %CONTAINED_OBJECTS = ();
my %VALID_CACHE = ();
my %CONTAINED_CACHE = ();
my %DECORATEES = ();

sub new
{
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = bless scalar validate_with
      (
       params => $class->create_contained_objects(@_),
       spec   => $class->validation_spec,
       called => "$class->new()",
      ), $class;
    if ($HAVE_WEAKEN) {
      my $c = $self->get_contained_object_spec;
      foreach my $name (keys %$c) {
	next if $c->{$name}{delayed};
	$self->{$name}{container}{container} = $self;
	weaken $self->{$name}{container}{container};
      }
    }
    return $self;
}

sub all_specs
{
    require B::Deparse;
    my %out;

    foreach my $class (sort keys %VALID_PARAMS)
    {
	my $params = $VALID_PARAMS{$class};

	foreach my $name (sort keys %$params)
	{
	    my $spec = $params->{$name};
	    my ($type, $default);
	    if ($spec->{isa}) {
		my $obj_class;

		$type = 'object';

		if (exists $CONTAINED_OBJECTS{$class}{$name}) {
		    $default = "$CONTAINED_OBJECTS{$class}{$name}{class}->new";
		}
	    } else {
		($type, $default) = ($spec->{parse}, $spec->{default});
	    }

	    if (ref($default) eq 'CODE') {
		$default = 'sub ' . B::Deparse->new()->coderef2text($default);
		$default =~ s/\s+/ /g;
	    } elsif (ref($default) eq 'ARRAY') {
		$default = '[' . join(', ', map "'$_'", @$default) . ']';
	    } elsif (ref($default) eq 'Regexp') {
		$type = 'regex';
		$default =~ s,^\(\?(\w*)-\w*:(.*)\),/$2/$1,;
		$default = "qr$default";
	    }
	    unless ($type) {
	      # Guess from the validation spec
	      $type = ($spec->{type} & ARRAYREF ? 'list' :
		       $spec->{type} & SCALAR   ? 'string' :
		       $spec->{type} & CODEREF  ? 'code' :
		       $spec->{type} & HASHREF  ? 'hash' :
		       undef);  # Oh well
	    }

	    my $descr = $spec->{descr} || '(No description available)';
	    $out{$class}{valid_params}{$name} = { type => $type,
						  pv_type => $spec->{type},
						  default => $default,
						  descr => $descr,
						  required => defined $default || $spec->{optional} ? 0 : 1,
						  public => exists $spec->{public} ? $spec->{public} : 1,
						};
	}

	$out{$class}{contained_objects} = {};
	next unless exists $CONTAINED_OBJECTS{$class};
	my $contains = $CONTAINED_OBJECTS{$class};

	foreach my $name (sort keys %$contains)
	{
	    $out{$class}{contained_objects}{$name}
	      = {map {$_, $contains->{$name}{$_}} qw(class delayed descr)};
	}
    }

    return %out;
}

sub dump_parameters {
  my $self = shift;
  my $class = ref($self) || $self;

  my %params;
  foreach my $param (keys %{ $class->validation_spec }) {
    next if $param eq 'container';
    my $spec = $class->validation_spec->{$param};
    if (ref($self) and defined $self->{$param}) {
      $params{$param} = $self->{$param};
    } else {
      $params{$param} = $spec->{default} if exists $spec->{default};
    }
  }

  foreach my $name (keys %{ $class->get_contained_object_spec }) {
    next unless ref($self);
    my $contained = ($self->{container}{contained}{$name}{delayed} ?
		     $self->delayed_object_class($name) :
		     $params{$name});

    my $subparams = UNIVERSAL::isa($contained, __PACKAGE__) ? $contained->dump_parameters : {};

    my $more = $self->{container}{contained}{$name}{args} || {};
    $subparams->{$_} = $more->{$_} foreach keys %$more;

    @params{ keys %$subparams } = values %$subparams;
    delete $params{$name};
  }
  return \%params;
}

sub show_containers {
  my $self = shift;
  my $name = shift;
  my %args = (indent => '', @_);

  $name = defined($name) ? "$name -> " : "";

  my $out = "$args{indent}$name$self";
  $out .= " (delayed)" if $args{delayed};
  $out .= "\n";
  return $out unless $self->isa(__PACKAGE__);

  my $specs = ref($self) ? $self->{container}{contained} : $self->get_contained_object_spec;

  while (my ($name, $spec) = each %$specs) {
    my $class = $args{args}{"${name}_class"} || $spec->{class};
    $self->_load_module($class);

    if ($class->isa(__PACKAGE__)) {
      $out .= $class->show_containers($name,
				      indent => "$args{indent}  ",
				      args => $spec->{args},
				      delayed => $spec->{delayed});
    } else {
      $out .= "$args{indent}  $name -> $class\n";
    }
  }

  return $out;
}

sub _expire_caches {
  %VALID_CACHE = %CONTAINED_CACHE = ();
}

sub valid_params {
  my $class = shift;
  if (@_) {
    $class->_expire_caches;
    $VALID_PARAMS{$class} = @_ == 1 && !defined($_[0]) ? {} : {@_};
  }
  return $VALID_PARAMS{$class} ||= {};
}

sub contained_objects
{
    my $class = shift;
    $class->_expire_caches;
    $CONTAINED_OBJECTS{$class} = {};
    while (@_) {
      my ($name, $spec) = (shift, shift);
      $CONTAINED_OBJECTS{$class}{$name} = ref($spec) ? $spec : { class => $spec };
    }
}

sub _decorator_AUTOLOAD {
  my $self = shift;
  no strict 'vars';
  my ($method) = $AUTOLOAD =~ /([^:]+)$/;
  return if $method eq 'DESTROY';
  die qq{Can't locate object method "$method" via package $self} unless ref($self);
  my $subr = $self->{_decorates}->can($method)
    or die qq{Can't locate object method "$method" via package } . ref($self);
  unshift @_, $self->{_decorates};
  goto $subr;
}

sub _decorator_CAN {
  my ($self, $method) = @_;
  return $self->SUPER::can($method) if $self->SUPER::can($method);
  if (ref $self) {
    return $self->{_decorates}->can($method) if $self->{_decorates};
    return undef;
  } else {
    return $DECORATEES{$self}->can($method);
  }
}

sub decorates {
  my ($class, $super) = @_;

  no strict 'refs';
  $super ||= ${$class . '::ISA'}[0];

  # Pass through unknown method invocations
  *{$class . '::AUTOLOAD'} = \&_decorator_AUTOLOAD;
  *{$class . '::can'} = \&_decorator_CAN;

  $DECORATEES{$class} = $super;
  $VALID_PARAMS{$class}{_decorates} = { isa => $super, optional => 1 };
}

sub container {
  my $self = shift;
  die "The ", ref($self), "->container() method requires installation of Scalar::Util" unless $HAVE_WEAKEN;
  return $self->{container}{container};
}

sub call_method {
  my ($self, $name, $method, @args) = @_;

  my $class = $self->contained_class($name)
    or die "Unknown contained item '$name'";

  $self->_load_module($class);
  return $class->$method( %{ $self->{container}{contained}{$name}{args} }, @args );
}

# Accepts a list of key-value pairs as parameters, representing all
# parameters taken by this object and its descendants.  Returns a list
# of key-value pairs representing *only* this object's parameters.
sub create_contained_objects
{
    # Typically $self doesn't exist yet, $_[0] is a string classname
    my $class = shift;

    my $c = $class->get_contained_object_spec;
    return {@_, container => {}} unless %$c or $DECORATEES{$class};

    my %args = @_;

    if ($DECORATEES{$class}) {
      # Fix format
      $args{decorate_class} = [$args{decorate_class}]
	if $args{decorate_class} and !ref($args{decorate_class});

      # Figure out which class to decorate
      my $decorate;
      if (my $c = $args{decorate_class}) {
	$decorate = @$c ? shift @$c : undef;
	delete $args{decorate_class} unless @$c;
      }
      $c->{_decorates} = { class => $decorate } if $decorate;
    }

    # This one is special, don't pass to descendants
    my $container_stuff = delete($args{container}) || {};

    keys %$c; # Reset the iterator - why can't I do this in get_contained_object_spec??
    my %contained_args;
    my %to_create;

    while (my ($name, $spec) = each %$c) {
      # Figure out exactly which class to make an object of
      my ($contained_class, $c_args) = $class->_get_contained_args($name, \%args);
      @contained_args{ keys %$c_args } = ();  # Populate with keys
      $to_create{$name} = { class => $contained_class,
			    args => $c_args };
    }

    while (my ($name, $spec) = each %$c) {
      # This delete() needs to be outside the previous loop, because
      # multiple contained objects might need to see it
      delete $args{"${name}_class"};

      if ($spec->{delayed}) {
	$container_stuff->{contained}{$name} = $to_create{$name};
	$container_stuff->{contained}{$name}{delayed} = 1;
      } else {
	$args{$name} ||= $to_create{$name}{class}->new(%{$to_create{$name}{args}});
	$container_stuff->{contained}{$name}{class} = ref $args{$name};
      }
    }

    # Delete things that we're not going to use - things that are in
    # our contained object specs but not in ours.
    my $my_spec = $class->validation_spec;
    delete @args{ grep {!exists $my_spec->{$_}} keys %contained_args };
    delete $c->{_decorates} if $DECORATEES{$class};

    $args{container} = $container_stuff;
    return \%args;
}

sub create_delayed_object
{
  my ($self, $name) = (shift, shift);
  croak "Unknown delayed item '$name'" unless $self->{container}{contained}{$name}{delayed};

  if ($HAVE_WEAKEN) {
    push @_, container => {container => $self};
    weaken $_[-1]->{container};
  }
  return $self->call_method($name, 'new', @_);
}

sub delayed_object_class
{
    my $self = shift;
    my $name = shift;
    croak "Unknown delayed item '$name'"
	unless $self->{container}{contained}{$name}{delayed};

    return $self->{container}{contained}{$name}{class};
}

sub contained_class
{
    my ($self, $name) = @_;
    croak "Unknown contained item '$name'"
	unless my $spec = $self->{container}{contained}{$name};
    return $spec->{class};
}

sub delayed_object_params
{
    my ($self, $name) = (shift, shift);
    croak "Unknown delayed object '$name'"
	unless $self->{container}{contained}{$name}{delayed};

    if (@_ == 1) {
	return $self->{container}{contained}{$name}{args}{$_[0]};
    }

    my %args = @_;

    if (keys %args)
    {
	@{ $self->{container}{contained}{$name}{args} }{ keys %args } = values %args;
    }

    return %{ $self->{container}{contained}{$name}{args} };
}

# Everything the specified contained object will accept, including
# parameters it will pass on to its own contained objects.
sub _get_contained_args
{
    my ($class, $name, $args) = @_;

    my $spec = $class->get_contained_object_spec->{$name}
      or croak "Unknown contained object '$name'";

    my $contained_class = $args->{"${name}_class"} || $spec->{class};
    croak "Invalid class name '$contained_class'"
	unless $contained_class =~ /^[\w:]+$/;

    $class->_load_module($contained_class);
    return ($contained_class, {}) unless $contained_class->isa(__PACKAGE__);

    my $allowed = $contained_class->allowed_params($args);

    my %contained_args;
    foreach (keys %$allowed) {
	$contained_args{$_} = $args->{$_} if exists $args->{$_};
    }
    return ($contained_class, \%contained_args);
}

sub _load_module {
    my ($self, $module) = @_;

    unless ( eval { $module->can('new') } )
    {
	no strict 'refs';
	eval "use $module";
	croak $@ if $@;
    }
}

sub allowed_params
{
    my $class = shift;
    my $args = ref($_[0]) ? shift : {@_};

    # Strategy: the allowed_params of this class consists of the
    # validation_spec of this class, merged with the allowed_params of
    # all contained classes.  The specific contained classes may be
    # affected by arguments passed in, like 'interp' or
    # 'interp_class'.  A parameter like 'interp' doesn't add anything
    # to our allowed_params (because it's already created) but
    # 'interp_class' does.

    my $c = $class->get_contained_object_spec;
    my %p = %{ $class->validation_spec };

    foreach my $name (keys %$c)
    {
	# Can accept a 'foo' parameter - should already be in the validation_spec.
	# Also, its creation parameters should already have been extracted from $args,
	# so don't extract any parameters.
	next if exists $args->{$name};

	# Figure out what class to use for this contained item
	my $contained_class;
	if ( exists $args->{"${name}_class"} ) {
	  $contained_class = $args->{"${name}_class"};
	  $p{"${name}_class"} = { type => SCALAR };  # Add to spec
	} else {
	  $contained_class = $c->{$name}{class};
	}

	# We have to make sure it is loaded before we try calling allowed_params()
	$class->_load_module($contained_class);
	next unless $contained_class->can('allowed_params');

	my $subparams = $contained_class->allowed_params($args);

	foreach (keys %$subparams) {
	  $p{$_} ||= $subparams->{$_};
	}
    }

    return \%p;
}

sub _iterate_ISA {
  my ($class, $look_in, $cache_in, $add) = @_;

  return $cache_in->{$class} if $cache_in->{$class};

  my %out;

  no strict 'refs';
  foreach my $superclass (@{ "${class}::ISA" }) {
    next unless $superclass->isa(__PACKAGE__);
    my $superparams = $superclass->_iterate_ISA($look_in, $cache_in, $add);
    @out{keys %$superparams} = values %$superparams;
  }
  if (my $x = $look_in->{$class}) {
    @out{keys %$x} = values %$x;
  }

  @out{keys %$add} = values %$add if $add;

  return $cache_in->{$class} = \%out;
}

sub get_contained_object_spec {
  return (ref($_[0]) || $_[0])->_iterate_ISA(\%CONTAINED_OBJECTS, \%CONTAINED_CACHE);
}

sub validation_spec {
  return (ref($_[0]) || $_[0])->_iterate_ISA(\%VALID_PARAMS, \%VALID_CACHE, { container => {type => HASHREF} });
}

1;

__END__