view release on metacpan or  search on metacpan

lib/Chorus/Frame.pm  view on Meta::CPAN

  );

  my $f2 = Chorus::Frame->new(
    a => { 
           b1 => sub { $SELF->get('a b2') }, # procedural attachment using context $SELF
           b2 => {
                   _ISA    => $f1->{b},
                   _NEEDED => 'needed for b  # needs mode Z to precede inherited _DEFAULT
                 }
         }     
  );
                    
  Chorus::Frame::setMode(GET => 'N');
  print $f2->get('a b1') . "\n";       # print 'inherited default for b'

  Chorus::Frame::setMode(GET => 'Z');
  print $f2->get('a b1') . "\n";       # print 'needed for b'
  
=cut

=head1 DESCRIPTION

  - A frame is a generic object structure described by slots (properties).
  - A frame can inherit slots from other frames.
  - A frame can have specific slots describing :
  
    * how it can be associated to a target information, 
    * how he reacts when its target information changes
    * what it can try when a missing property is requested.
      
  - The slots _VALUE,_DEFAULT,_NEEDED are tested in this order to obtain the target information 
    of a given frame (can be inherited).
  - Two other special slots _BEFORE & _AFTER can define what a frame has to do before or after 
    one of its properties changes.
  - The slot _ISA is used to define the inheritance. 

  Two modes 'N' (default) or 'Z' are used to define the priority between a frame and its inherited 
  frames in order to process its target information
             
  The globale variable $SELF returns the current CONTEXT which is the most recent frame called for the method get().
  A slot defined by a function sub { .. } can refer to the current context $SELF in its body.
  
  All frames are automaticaly referenced in a repository used to optimise the selection of frames for a given action.
  The function fmatch() can be used to quicly select all the frames responding to a given test on their properties.  
=cut

BEGIN {
  use Exporter;
  use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);

  @ISA         = qw(Exporter);
  @EXPORT      = qw($SELF &fmatch REQUIRE_FAILED);
  @EXPORT_OK   = qw(%FMAP);	

  # %EXPORT_TAGS = ( );		# eg: TAG => [ qw!name1 name2! ];
}

use strict;
use Carp;			# warn of errors (from perspective of caller)
use Digest::MD5;
use Scalar::Util qw(weaken);

use Data::Dumper;

use constant DEBUG_MEMORY => 0;

use vars qw($AUTOLOAD);

use constant SUCCESS        =>  1;
use constant FAILED         =>  0;
use constant REQUIRE_FAILED => -1;

use constant VALUATION_ORDER => ('_VALUE', '_DEFAULT', '_NEEDED');

use constant MODE_N => 1;
use constant MODE_Z => 2;

my $getMode = MODE_N;       # DEFAULT IS N !!!

my %REPOSITORY;
my %FMAP;
my %INSTANCES;

our $SELF;
my @Heap = ();

sub AUTOLOAD {
  my $frame = shift || $SELF;
  my $slotName = $AUTOLOAD;
  $slotName =~ s/.*://;           # strip fully-qualified portion
  get($frame, $slotName, @_); # or getN or getZ !!
}

sub _isa {
  my ($ref, $str) = @_;
  return (ref($ref) eq $str);
}

=head1 SUBROUTINES
=cut

=head2 setMode

 Defines the inheritance mode of methods get() for the special slots _VALUE,_DEFAULT,_NEEDED
 the default mode is 'N'.
   
    'N' : ex. a single slot from the sequence _VALUE,_DEFAULT,_NEEDED will be tested in all inherited
              frames before trying the next one.
              
    'Z' : the whole sequence _VALUE,_DEFAULT,_NEEDED will be tested from the frame before being 
          tested from the inherited frames
          
    ex. Chorus::Frame::setMode(GET => 'Z');

=cut

sub setMode {
	my (%opt) = @_;
	$getMode = MODE_N if defined($opt{GET}) and uc($opt{GET}) eq 'N';
	$getMode = MODE_Z if defined($opt{GET}) and uc($opt{GET}) eq 'Z';
}

=head1 METHODS
=cut

=head2 _keys

  my @k = $f->_keys;
  same as CORE::keys but excludes the special slot '_KEY' specific to all frames
=cut

sub _keys {
  my ($this) = @_;
  grep { $_ ne '_KEY' } keys %{$this};
}

sub pushself {
  unshift(@Heap, $SELF) if $SELF;
  $SELF = shift;
}

sub popself {
  $SELF = shift @Heap;
}

sub expand {
    my ($info, @args) = @_;
    return expand(&$info(@args)) if _isa($info, 'CODE');
    return $info;       
}

=head2 _push

  push new elements to a given slot (becomes an array if necessary)
=cut

sub _push {
  my ($this, $slot, @elems) = @_;
  return unless scalar(@elems);
  $this->{$slot} = [ $this->{$slot} || () ] unless ref($this->{$slot}) eq 'ARRAY'; 
  unshift @{$this->{$slot}}, @elems;
}

sub _addInstance {
  my ($this, $instance) = @_;
  my $k = $instance->{_KEY};
  
  $INSTANCES{$this->{_KEY}}->{$k} = $instance;
  weaken($INSTANCES{$this->{_KEY}}->{$k});      # will not increase garbage ref counter to $instance !!
}

=head2 _inherits

  add inherited new frame(s) outside constructor
  ex. $f->_inherits($F1,$F2);
=cut
  
sub _inherits {
  my ($this, @inherited) = @_;
  my $k = $this->{_KEY};
  for (grep { ! $INSTANCES{$_->{_KEY}}->{$k} } @inherited) { # clean list
  	$_->_addInstance($this);
  	$this->_push('_ISA', $_);
  }
  return $this;
}

sub _removeInstance {
  my ($this, $instance) = @_;
  my $k = $instance->{_KEY};
  (warn "Instance NOT FOUND !?", return) unless $INSTANCES{$this->{_KEY}}->{$k};
  delete $INSTANCES{$this->{_KEY}}->{$k};
}

sub blessToFrame {

  sub register {

    my ($this) = @_;

    my $k;
    do {
    	$k = Digest::MD5::md5_base64( rand );
    } while(exists($FMAP{$k}));
 
    foreach my $slot (keys(%$this)) { # register all slots
      $REPOSITORY{$slot} = {} unless exists $REPOSITORY{$slot};
      $REPOSITORY{$slot}->{$k} = 'Y';
    }
    
    $this->{_KEY} = $k;
    $FMAP{$k} = $this;
    weaken($FMAP{$k}); # will not increase garbage ref counter to $this !!
    return $this; 
  }

  sub blessToFrameRec {

    local $_ = shift;

    if (_isa($_,'Chorus::Frame')) {
      
      while(my ($k, $val) = each %$_) {
         if (_isa($val,'HASH')) {
            next if $val->{_NOFRAME};
            bless($val, 'Chorus::Frame');
            $val->register();
            blessToFrameRec($val);
         } else {
            if (_isa($val,'ARRAY')) {
               blessToFrameRec($_->{$k});
            }
         }
         if ($k eq '_ISA') {
           foreach my $inherited (_isa($val,'ARRAY') ? map \&expand, @{$val} 
                                                         : (expand($val))) {
              $inherited->_addInstance($_) if $inherited;
           }
         }
      }

      return;
    }

    if (_isa($_,'ARRAY')) { # à revoir (sans $idx)
      foreach my $idx (0 .. scalar(@$_) - 1) {
	    if (_isa($_[$idx], 'HASH')) {
	      next if exists $_[$idx]->{_NOFRAME};
	      bless($_[$idx], 'Chorus::Frame');
	      $_[$idx]->register();
	      blessToFrameRec($_[$idx]);
	    } else {
	      if (_isa($_[$idx],'ARRAY')) {
	        blessToFrameRec($_[$idx]);
	      }
	    }
      }
    }
  }

  my $res = shift;

  return $res if _isa($res, 'Chorus::Frame'); # already blessed

  SWITCH: {

    _isa($res, 'HASH') && do {
	  return $res if exists $res->{_NOFRAME};
	  bless($res, 'Chorus::Frame')->register();
	  blessToFrameRec $res if keys(%$res);
	  last SWITCH;;
    };