view release on metacpan or  search on metacpan

Ace/Object.pm  view on Meta::CPAN

      }

      $self = $self->fetch if !$no_dereference && 
	!$self->isRoot && $self->db;  # dereference, if need be
      croak "Null object tag \"$func_name\"" unless $self;

      return $self->search($func_name,@_) if wantarray;
      my ($obj) = @_ ? $self->search($func_name,@_) : $self->search($func_name,1);

      # these nasty heuristics simulate aql semantics.
      # undefined return
      return unless defined $obj;

      # don't dereference object if '@' symbol specified
      return $obj if $no_dereference;

      # don't dereference if an offset was explicitly specified
      return $obj if defined($_[0]) && $_[0] =~ /\d+/;

      # otherwise dereference if the current thing is an object or we are at a tag
      # and the thing to the right is an object.
      return $obj->fetch if $obj->isObject && !$obj->isRoot;  # always dereference objects

      # otherwise return the thing itself
      return $obj;
    } elsif ($func_name =~ /^[A-Z]/ && $self->isTag) {  # follow tag
      return $self->search($func_name);
    } else {
      $AutoLoader::AUTOLOAD = __PACKAGE__ . "::$func_name";
      goto &AutoLoader::AUTOLOAD;
    }
}

sub DESTROY {
  my $self = shift;

  return unless defined $self->{class};      # avoid working with temp objects from a search()
  return if caller() =~ /^(Cache\:\:|DB)/;  # prevent recursion in FileCache code
  my $db = $self->db or return;
  return if $self->{'.nocache'};
  return unless $self->isRoot;

  if ($self->_dirty) {
    warn "Destroy for ",overload::StrVal($self)," ",$self->class,':',$self->name if Ace->debug;
    $self->_dirty(0);
    $db->file_cache_store($self);
  }

  # remove our in-memory cache
  # shouldn't be necessary with weakref
  # $db->memory_cache_delete($self);
}

###################### object constructor #################
# IMPORTANT: The _clone subroutine will copy all instance variables that
# do NOT begin with a dot (.).  If you do not want an instance variable
# shared with cloned copies, proceed them with a dot!!!
#
sub new {
  my $pack = shift;
  my($class,$name,$db,$isRoot) = rearrange([qw/CLASS NAME/,[qw/DATABASE DB/],'ROOT'],@_);
  $pack = ref($pack) if ref($pack);
  my $self = bless { 'name'  =>  $name,
		     'class' =>  $class
		   },$pack;
  $self->db($db) if $self->isObject;
  $self->{'.root'}++ if defined $isRoot && $isRoot;
#  $self->_dirty(1)   if $isRoot;
  return $self
}

######### construct object from serialized input, not usually called directly ########
sub newFromText {
  my ($pack,$text,$db) = @_;
  $pack = ref($pack) if ref($pack);

  my @array;
  foreach (split("\n",$text)) {
    next unless $_;
    # this is a hack to fix some txt fields with unescaped tabs
    # unfortunately it breaks other things
    s/\?txt\?([^?]*?)\t([^?]*?)\?/?txt?$1\\t$2?/g;  
    push(@array,[split("\t")]);
  }
  my $obj = $pack->_fromRaw(\@array,0,0,$#array,$db);
  $obj->_dirty(1);
  $obj;
}


################### name of the object #################
sub name {
    my $self = shift;
    $self->{'name'} = shift if  defined($_[0]);
    my $name = $self->_ace_format($self->{'class'},$self->{'name'});
    $name;
}

################### class of the object #################
sub class {
    my $self = shift;
    defined($_[0])
	? $self->{'class'} = shift
	: $self->{'class'};
}

################### name and class together #################
sub id {
  my $self = shift;
  return "$self->{class}:$self->{name}";
}

############## return true if two objects are equivalent ##################
# to be equivalent, they must have identical names, classes and databases #
# We handle comparisons between objects and numbers ourselves, and let    #
# Perl handle comparisons between objects and strings                     #
sub eq {
    my ($a,$b,$rev) = @_;
    unless (UNIVERSAL::isa($b,'Ace::Object')) {
	$a = $a->name + 0; # convert to numeric
	return $a == $b;  # do a numeric comparison