view release on metacpan or  search on metacpan

lib/Class/Container.pm  view on Meta::CPAN

use strict;
package Class::Container;
{
  $Class::Container::VERSION = '0.13';
}

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

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} = {};

lib/Class/Container.pm  view on Meta::CPAN

    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);