view release on metacpan or  search on metacpan

MakeMethods/Composite/Inheritable.pm  view on Meta::CPAN

use vars qw( %HashFragments );

sub hash {
  (shift)->_build_composite( \%HashFragments, @_ );
}

%HashFragments = (
  '' => [
    '+init' => sub {
	my ($method) = @_;
	$method->{hash_key} ||= $_->{name};
	$method->{data} ||= {};
      },
    'do' => sub {
	my $method = pop @_;
	my $self = shift @_;
	
	if ( scalar(@_) == 0 ) {
	  my $value = get_vvalue($method->{data}, $self);
	  if ( $method->{auto_init} and ! $value ) {
	    $value = set_vvalue( $method->{data}, $self, {} );
	  }
	  wantarray ? %$value : $value;
	} elsif ( scalar(@_) == 1 ) {
	  if ( ref($_[0]) eq 'HASH' ) {
	    %{$method->{data}{$self}} = %{$_[0]};
	  } elsif ( ref($_[0]) eq 'ARRAY' ) {
	    my $v_self = find_vself($method->{data}, $self) or return;
	    return @{ $method->{data}{$v_self} }{ @{$_[0]} }
	  } else {
	    my $v_self = find_vself($method->{data}, $self) or return;
	    return $method->{data}{$v_self}{ $_[0] }
	  }

	} elsif ( scalar(@_) % 2 ) {
	  Carp::croak "Odd number of items in assigment to $method->{name}";
	} else {
	  if ( ! exists $method->{data}{$self} ) {
	    my $v_self = find_vself($method->{data}, $self);
	    $method->{data}{$self} = { $v_self ? %{ $method->{data}{$v_self} } : () };
	  }
	  while ( scalar(@_) ) {
	    my $key = shift();
	    $method->{data}{$self}->{ $key } = shift();
	  }
	  wantarray ? %{$method->{data}{$self}} : $method->{data}{$self};
	}
      },
  ],
);

########################################################################

=head2 hook - Overrideable array of subroutines

A hook method is called from the outside as a normal method. However, internally, it contains an array of subroutine references, each of which are called in turn to produce the method's results.

Subroutines may be added to the hook's array by calling it with a blessed subroutine reference, as shown below. Subroutines may be added on a class-wide basis or on an individual object. 

You might want to use this type of method to provide an easy way for callbacks to be registered.

  package MyClass;
  use Class::MakeMethods::Composite::Inheritable ( 'hook' => 'init' );
  
  MyClass->init( Class::MakeMethods::Composite::Inheritable->Hook( sub { 
      my $callee = shift;
      warn "Init...";
  } );
  
  my $obj = MyClass->new;
  $obj->init();

=cut

use vars qw( %HookFragments );

sub hook {
  (shift)->_build_composite( \%HookFragments, @_ );
}

%HookFragments = (
  '' => [
    '+init' => sub {
	my ($method) = @_;
	$method->{data} ||= {};
      },
    'do' => sub {
	my $method = pop @_;
	my $self = shift @_;
	
	if ( scalar(@_) and 
	    ref($_[0]) eq 'Class::MakeMethods::Composite::Inheritable::Hook' ) {
	  if ( ! exists $method->{data}{$self} ) {
	    my $v_self = find_vself($method->{data}, $self);
	    $method->{data}{$self} = [ $v_self ? @{ $method->{data}{$v_self} } : () ];
	  }
	  push @{ $method->{data}{$self} }, map $$_, @_;
	} else {
	  my $v_self = find_vself($method->{data}, $self);
	  my $subs = $v_self ? $method->{data}{$v_self} : ();
	  my @subs = ( ( ! $subs ) ? () : @$subs );
	  
	  if ( ! defined $method->{wantarray} ) {
	    foreach my $sub ( @subs ) {
	      &$sub( @{$method->{args}} );	
	    }
	  } elsif ( ! $method->{wantarray} ) {
	    foreach my $sub ( @subs ) {
	      my $value = &$sub( @{$method->{args}} );
	      if ( defined $value ) { 
		$method->{result} = \$value;
	      }
	    }
	  } else {
	    foreach my $sub ( @subs ) {
	      my @value = &$sub( @{$method->{args}} );
	      if ( scalar @value ) { 
		push @{ $method->{result} }, @value;
	      }
	    }