File Coverage

blib/lib/Ace/Object.pm

Criterion	Covered	Total	%
statement	30	355	8.4
branch	0	208	0.0
condition	0	72	0.0
subroutine	10	48	20.8
pod	17	26	65.3
total	57	709	8.0

package Ace::Object;
use strict;
use Carp qw(:DEFAULT cluck);

# $Id: Object.pm,v 1.60 2005/04/13 14:26:08 lstein Exp $

use overload
    '""'       => 'name',
    '=='       => 'eq',
    '!='       => 'ne',
    'fallback' => 'TRUE';
use vars qw($AUTOLOAD $DEFAULT_WIDTH %MO $VERSION);
use Ace 1.50 qw(:DEFAULT rearrange);

# if set to 1, will conflate tags in XML output
use constant XML_COLLAPSE_TAGS => 1;
use constant XML_SUPPRESS_CONTENT=>1;
use constant XML_SUPPRESS_CLASS=>1;
use constant XML_SUPPRESS_VALUE=>0;
use constant XML_SUPPRESS_TIMESTAMPS=>0;

require AutoLoader;

$DEFAULT_WIDTH=25;  # column width for pretty-printing
$VERSION = '1.66';

# Pseudonyms and deprecated methods.
*isClass        =  \&isObject;
*pick           =  \&fetch;
*get            =  \&search;
*add            =  \&add_row;

sub AUTOLOAD {
    my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
    my $self = $_[0];

    # This section works with Autoloader
    my $presumed_tag = $func_name =~ /^[A-Z]/ && $self->isObject;  # initial_cap

    if ($presumed_tag) {
      croak "Invalid object tag \"$func_name\""
	if $self->db && $self->model && !$self->model->valid_tag($func_name);

      shift();  # get rid of the object
      my $no_dereference;
      if (defined($_[0])) {
	if ($_[0] eq '@') {
	  $no_dereference++;
	  shift();
	} elsif ($_[0] =~ /^\d+$/) {
	  $no_dereference++;
	}
      }

      $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
    }
    return 1 if ($a->name eq $b->name)
      && ($a->class eq $b->class)
	&& ($a->db eq $b->db);
    return;
}

sub ne {
    return !&eq;
}


############ returns true if this is a top-level object #######
sub isRoot {
  return exists shift()->{'.root'};
}

################### handle to ace database #################
sub db {
  my $self = shift;
  if (@_) {
    my $db = shift;
    $self->{db} = "$db";  # store string representation, not object
  }
  Ace->name2db($self->{db});
}

### Return a portion of the tree at the indicated tag path     ###
#### In a list context returns the column.  In an array context ###
#### returns a pointer to the subtree ####
#### Usually returns what is pointed to by the tag.  Will return
#### the parent object if you pass a true value as the second argument
sub at {
    my $self = shift;
    my($tag,$pos,$return_parent) = rearrange(['TAG','POS','PARENT'],@_);
    return $self->right unless $tag;
    $tag = lc $tag;

    # Removed a $` here to increase speed -- [e-mail] 2 Sep 1999

    if (!defined($pos) and $tag=~/(.*?)\[(\d+)\]$/) {
      $pos = $2;
      $tag = $1;
    }

    my $o = $self;
    my ($parent,$above,$left);
    my (@tags) = $self->_split_tags($tag);
    foreach $tag (@tags) {
      $tag=~s/$;/./g; # unprotect backslashed dots
      my $p = $o;
      ($o,$above,$left) = $o->_at($tag);
      return unless defined($o);
    }
    return $above || $left if $return_parent;
    return defined $pos ? $o->right($pos) : $o unless wantarray;
    return $o->col($pos);
}

### Flatten out part of the tree into an array ####
### along the row.  Will not follow object references.  ###
sub row {
  my $self = shift;
  my $pos = shift;
  my @r;
  my $o = defined $pos ? $self->right($pos) : $self;
  while (defined($o)) {
    push(@r,$o);
    $o = $o->right;
  }
  return @r;
}

### Flatten out part of the tree into an array ####
### along the column. Will not follow object references. ###
sub col {
  my $self = shift;
  my $pos = shift;
  $pos = 1 unless defined $pos;
  croak "Position must be positive" unless $pos >= 0;

  return ($self) unless $pos > 0;

  my @r;
  # This is for tag[1] semantics
  if ($pos == 1) {
    for (my $o=$self->right; defined($o); $o=$o->down) {
      push (@r,$o);
    }
  } else {
    # This is for tag[2] semantics
    for (my $o=$self->right; defined($o); $o=$o->down) {
      next unless defined(my $right = $o->right($pos-2));
      push (@r,$right->col);
    }
  }
  return @r;
}

#### Search for a tag, and return the column ####
#### Uses a breadth-first search (cols then rows) ####
sub search {
  my $self = shift;
  my $tag = shift unless $_[0]=~/^-/;
  my ($subtag,$pos,$filled) = rearrange(['SUBTAG','POS',['FILL','FILLED']],@_);
  my $lctag = lc $tag;

  # With caching, the old way of following ends up cloning the object
  # -- which we don't want.  So more-or-less emulate the earlier
  # behavior with an explicit get and fetch
  #  return $self->follow(-tag=>$tag,-filled=>$filled) if $filled;
  if ($filled) {
    my @node = $self->search($tag) or return;  # watch out for recursion!
    my @obj  = map {$_->fetch} @node;
    foreach (@obj) {$_->right if defined $_};  # trigger a fill
    return wantarray ? @obj : $obj[0];
  }

 TRY: {

    # look in our tag cache first
    if (exists $self->{'.PATHS'}) {

      # we've already cached the desired tree
      last TRY if exists $self->{'.PATHS'}{$lctag};

      # not cached, so try parents of tag
      my $m = $self->model;
      my @parents = $m->path($lctag) if $m;
      my $tree;
      foreach (@parents) {
	($tree = $self->{'.PATHS'}{lc $_}) && last;
      }
      if ($tree) {
	$self->{'.PATHS'}{$lctag} = $tree->search($tag);
	$self->_dirty(1);
	last TRY;
      }
    }

    # If the object hasn't been filled already, then we can use
    # acedb's query mechanism to fetch the subobject.  This is a
    # big win for large objects.  ...However, we have to disable
    # this feature if timestamps are active.
    unless ($self->filled) {
      my $subobject = $self->newFromText(
					 $self->db->show($self->class,$self->name,$tag),
					 $self->db
					);
      if ($subobject) {
	$subobject->{'.nocache'}++;
	$self->_attach_subtree($lctag => $subobject);
      } else {
	$self->{'.PATHS'}{$lctag} = undef;
      }
      $self->_dirty(1);
      last TRY;
    }

    my @col = $self->col;
    foreach (@col) {
      next unless $_->isTag;
      if (lc $_ eq $lctag) {
	$self->{'.PATHS'}{$lctag} = $_;
	$self->_dirty(1);
	last TRY;
      }
    }

    # if we get here, we didn't find it in the column,
    # so we call ourselves recursively to find it
    foreach (@col) {
      next unless $_->isTag;
      if (my $r = $_->search($tag)) {
	$self->{'.PATHS'}{$lctag} = $r;
	$self->_dirty(1);
	last TRY;
      }
    }

    # If we got here, we just didn't find it.  So tag the cache
    # as empty so that we don't try again
    $self->{'.PATHS'}{$lctag} = undef;
    $self->_dirty(1);
  }

  my $t = $self->{'.PATHS'}{$lctag};
  return unless $t;

  if (defined $subtag) {
    if ($subtag =~ /^\d+$/) {
      $pos = $subtag;
    } else {  # position on subtag and search again
      return $t->fetch->search($subtag,$pos)
	if $t->isObject  || (defined($t->right) and $t->right->isObject);
      return $t->search($subtag,$pos);
    }
  }

  return defined $pos ? $t->right($pos) : $t  unless wantarray;

  # We do something verrrry interesting in an array context.
  # If no position is defined, we return the column to the right.
  # If a position is defined, we return everything $POS tags
  # to the right (so-called tag[2] system).
  return $t->col($pos);
}

# utility routine used in partial tree caching
sub _attach_subtree {
  my $self             = shift;
  my ($tag,$subobject) = @_;
  my $lctag = lc($tag);
  my $obj;
  if (lc($subobject->right) eq $lctag) { # new version of aceserver as of 11/30/98
    $obj = $subobject->right;
  } else { # old version of aceserver
    $obj = $self->new('tag',$tag,$self->db);
    $obj->{'.right'} = $subobject->right;
  }
  $self->{'.PATHS'}->{$lctag} = $obj;
}

sub _dirty {
  my $self = shift;
  $self->{'.dirty'} = shift if @_ && $self->isRoot;
  $self->{'.dirty'};
}

#### return true if tree is populated, without populating it #####
sub filled {
  my $self = shift;
  return exists($self->{'.right'}) || exists($self->{'.raw'});
}

#### return true if you can follow the object in the database (i.e. a class ###
sub isPickable {
    return shift->isObject;
}

#### Return a string representation of the object subject to Ace escaping rules ###
sub escape {
  my $self = shift;
  my $name = $self->name;
  my $needs_escaping = $name=~/[^\w.-]/ || $self->isClass;
  return $name unless $needs_escaping;
  $name=~s/\"/\\"/g; #escape quotes"
  return qq/"$name"/;
}

############### object on the right of the tree #############
sub right {
  my ($self,$pos) = @_;

  $self->_fill;
  $self->_parse;

  return $self->{'.right'} unless defined $pos;
  croak "Position must be positive" unless $pos >= 0;

  my $node = $self;
  while ($pos--) {
    defined($node = $node->right) || return;
  }
  $node;
}

################# object below on the tree #################
sub down {
  my ($self,$pos) = @_;
  $self->_parse;
  return $self->{'.down'} unless defined $pos;
  my $node = $self;
  while ($pos--) {
    defined($node = $node->down) || return;
  }
  $node;
}

#############################################
#  fetch current node from the database     #
sub fetch {
    my ($self,$tag) = @_;
    return $self->search($tag) if defined $tag;
    my $thing_to_pick = ($self->isTag and defined($self->right)) ? $self->right : $self;
    return $thing_to_pick unless $thing_to_pick->isObject;
    my $obj = $self->db->get($thing_to_pick->class,$thing_to_pick->name) if $self->db;
    return $obj;
}

#############################################
# follow a tag into the database, returning a
# list of followed objects.
sub follow {
    my $self = shift;
    my ($tag,$filled) =  rearrange(['TAG','FILLED'],@_);

    return unless $self->db;
    return $self->fetch() unless $tag;
    my $class = $self->class;
    my $name = Ace->freeprotect($self->name);
    my @options;
    if ($filled) {
      @options = $filled =~ /^[a-zA-Z]/ ? ('filltag' => $filled) : ('filled'=>1);
    }
    return $self->db->fetch(-query=>"find $class $name ; follow $tag",@options);
}

# returns true if the object has a Model, i.e, can be followed into
# the database.
sub isObject {
    my $self = shift;
    return _isObject($self->class);
    1;
}

# returns true if the object is a tag.
sub isTag {
    my $self = shift;
    return 1 if $self->class eq 'tag';
    return;
}

# return the most recent error message
sub error {
  $Ace::Error=~s/\0//g;  # get rid of nulls
  return $Ace::Error;
}

### Returns the object's model (as an Ace::Model object)
sub model {
  my $self = shift;
  return unless $self->db && $self->isObject;
  return $self->db->model($self->class);
}

### Return the class in which to bless all objects retrieved from
# database. Might want to override in other classes
sub factory {
  return __PACKAGE__;
}

#####################################################################
#####################################################################
############### mostly private functions from here down #############
#####################################################################
#####################################################################
# simple clone
sub clone {
  my $self = shift;
  return bless {%$self},ref $self;
}

# selective clone
sub _clone {
    my $self = shift;
    my $pack = ref($self);
    my @public_keys = grep {substr($_,0,1) ne '.'} keys %$self;
    my %newobj;
    @newobj{@public_keys} = @{$self}{@public_keys};

    # Turn into a toplevel object
    $newobj{'.root'}++;
    return bless \%newobj,$pack;
}

sub _fill {
    my $self = shift;
    return if $self->filled;
    return unless $self->db && $self->isObject;

    my $data = $self->db->pick($self->class,$self->name);
    return unless $data;

    # temporary object, don't cache it.
    my $new = $self->newFromText($data,$self->db);
    %{$self}=%{$new};

    $new->{'.nocache'}++; # this line prevents the thing from being cached

    $self->_dirty(1);
}

sub _parse {
  my $self = shift;
  return unless my $raw = $self->{'.raw'};
  my $ts = $self->db->timestamps;
  my $col = $self->{'.col'};
  my $current_obj = $self;
  my $current_row = $self->{'.start_row'};
  my $db = $self->db;
  my $changed;

  for (my $r=$current_row+1; $r<=$self->{'.end_row'}; $r++) {
    next unless $raw->[$r][$col] ne '';
    $changed++;

    my $obj_right = $self->_fromRaw($raw,$current_row,$col+1,$r-1,$db);

    # comment handling
    if ( defined($obj_right) ) {
      my ($t,$i);
      my $row = $current_row+1;
      while ($obj_right->isComment) {
	$current_obj->comment($obj_right)   if $obj_right->isComment;
	$t = $obj_right;
	last unless defined ($obj_right = $self->_fromRaw($raw,$row++,$col+1,$r-1,$db));
      }
    }
    $current_obj->{'.right'} = $obj_right;

    my ($class,$name,$timestamp) = Ace->split($raw->[$r][$col]);
    my $obj_down = $self->new($class,$name,$db);
    $obj_down->timestamp($timestamp) if $ts && $timestamp;

    # comments never occur at down pointers
    $current_obj = $current_obj->{'.down'} = $obj_down;
    $current_row = $r;
  }

  my $obj_right = $self->_fromRaw($raw,$current_row,$col+1,$self->{'.end_row'},$db);

  # comment handling
  if (defined($obj_right)) {
    my ($t,$i);
    my $row = $current_row + 1;
    while ($obj_right->isComment) {
      $current_obj->comment($obj_right)   if $obj_right->isComment;
      $t = $obj_right;
      last unless defined($obj_right = $self->_fromRaw($raw,$row++,$col+1,$self->{'.end_row'},$db));
    }
  }
  $current_obj->{'.right'} = $obj_right;
  $self->_dirty(1) if $changed;
  delete @{$self}{qw[.raw .start_row .end_row .col]};
}

sub _fromRaw {
  my $pack = shift;

  # this breaks inheritance...
  #  $pack = $pack->factory();

  my ($raw,$start_row,$col,$end_row,$db) = @_;
  $db = "$db" if ref $db;
  return unless defined $raw->[$start_row][$col];

  # HACK! Some LongText entries may begin with newlines. This is within the Acedb spec.
  # Let's purge text entries of leading space and format them appropriate.
  # This should probably be handled in Freesubs.xs / Ace::split
  my $temp = $raw->[$start_row][$col];
#  if ($temp =~ /^\?txt\?\s*\n*/) {
#    $temp =~ s/^\?txt\?(\s*\\n*)/\?txt\?/;
#    $temp .= '?';
#  }
  my ($class,$name,$ts) = Ace->split($temp);

  my $self = $pack->new($class,$name,$db,!($start_row || $col));
  @{$self}{qw(.raw .start_row .end_row .col db)} = ($raw,$start_row,$end_row,$col,$db);
  $self->{'.timestamp'} = $ts if defined $ts;
  return $self;
}


# Return partial ace subtree at indicated tag
sub _at {
    my ($self,$tag) = @_;
    my $pos=0;

    # Removed a $` here to increase speed -- [e-mail] 2 Sep 1999

    if ($tag=~/(.*?)\[(\d+)\]$/) {
      $pos=$2;
      $tag=$1;
    }
    my $p;
    my $o = $self->right;
    while ($o) {
	return ($o->right($pos),$p,$self) if (lc($o) eq lc($tag));
	$p = $o;
	$o = $o->down;
    }
    return;
}


# Used to munge special data types.  Right now dates are the
# only examples.
sub _ace_format {
  my $self = shift;
  my ($class,$name) = @_;
  return undef unless defined $class && defined $name;
  return $class eq 'date' ? $self->_to_ace_date($name) : $name;
}

# It's an object unless it is one of these things
sub _isObject {
    return unless defined $_[0];
    $_[0] !~ /^(float|int|date|tag|txt|peptide|dna|scalar|[Tt]ext|comment)$/;
}

# utility routine used to split a tag path into individual components
# allows components to contain dots.
sub _split_tags {
  my $self = shift;
  my $tag = shift;
  $tag =~ s/\\\./$;/g; # protect backslashed dots
  return map { (my $x=$_)=~s/$;/./g; $x } split(/\./,$tag);
}


1;

__END__