view release on metacpan or  search on metacpan

Ace/Object.pm  view on Meta::CPAN

    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 -- tim.cutts@incyte.com 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+$/) {

Ace/Object.pm  view on Meta::CPAN

  delete $self->{'.PATHS'}; # uncache cached values
  $self->_dirty(1);
  1;
}

# Use this method to add an entire subobject to the right of the tag.
# The tree may come from another database.
sub add_tree {
  my $self = shift;
  my($tag,$value,@rest) = rearrange([['TAG','PATH'],['VALUE','TREE']],@_);
  croak "Value must be an Ace::Object" unless ref($value) && $value->isa('Ace::Object');

  unless ($tag =~ /\./) {
    my $model = $self->model;
    my @intermediate_tags = $model->path($tag);
    $tag = join '.',@intermediate_tags,$tag;
  }

  # position at the indicated tag, creating it if necessary
  my (@tags) = $self->_split_tags($tag);
  my $p = $self;
  foreach (@tags) {
    $p = $p->_insert($_);
  }
  # Copy the subtree too
  if ($p->{'.right'}) {
    $p = $p->{'.right'};
    while (1) { 
      last unless $p->{'.down'};
      $p = $p->{'.down'};
    }
    $p->{'.down'} = $value->{'.right'};
  } else {
    $p->{'.right'} = $value->{'.right'};
  }
  push(@{$self->{'.update'}},map { join(' ',@tags,$_) } split("\n",$value->asAce));
  delete $self->{'.PATHS'}; # uncache cached values
  $self->_dirty(1);
  1;
}

################# delete a portion of the tree #############
# Only changes local copy until you perform commit() #
#  returns true if this is a valid thing to do.
sub delete {
  my $self = shift;
  my($tag,$oldvalue,@rest) = rearrange([['TAG','PATH'],['VALUE','OLDVALUE','OLD']],@_);

  # flatten array refs into array
  my @values;
  @values = map { ref($_) && ref($_) eq 'ARRAY' ? @$_ : $_ } ($oldvalue,@rest) 
    if defined($oldvalue);

  unless ($tag =~ /\./) {
    my $model = $self->model;
    my @intermediate_tags = $model->path($tag);
    $tag = join '.',@intermediate_tags,$tag;
  }

  my $row = join(".",($tag,map { (my $x = $_) =~s/\./\\./g; $x } @values));
  my $subtree = $self->at($row,undef,1);  # returns the parent

  if (@values
      && defined($subtree->{'.right'})
      && "$subtree->{'.right'}" eq $oldvalue) {
    $subtree->{'.right'} = $subtree->{'.right'}->down;
  } else {
    $subtree->{'.down'} = $subtree->{'.down'}->{'.down'}
  }

  push(@{$self->{'.update'}},join(' ','-D',
				 map { Ace->freeprotect($_) } ($self->_split_tags($tag),@values)));
  delete $self->{'.PATHS'}; # uncache cached values
  $self->_dirty(0);
  $self->db->file_cache_delete($self);
  1;
}


################# delete a portion of the tree #############
# Only changes local copy until you perform commit() #
#  returns true if this is a valid thing to do #
sub replace {
  my $self = shift;
  my($tag,$oldvalue,$newvalue,@rest) = rearrange([['TAG','PATH'],
						  ['OLDVALUE','OLD'],
						  ['NEWVALUE','NEW']],@_);
    $self->delete($tag,$oldvalue);
    $self->add($tag,$newvalue,@rest);
    delete $self->{'.PATHS'}; # uncache cached values
    1;
}

# commit changes from local copy to database copy
sub commit {
  my $self = shift;
  return unless my $db = $self->db;
  
  my ($retval,@cmd);
  my $name = $self->{'name'};
  return unless defined $name;
  
  $name =~ s/([^a-zA-Z0-9_-])/\\$1/g;
  return 1 unless exists $self->{'.update'} && $self->{'.update'};

  $Ace::Error = '';
  my $result = '';

  # bad design alert: the following breaks encapsulation
  if ($db->db->can('write')) { # new way for socket server
    my $cmd = join "\n","$self->{'class'} : $name",@{$self->{'.update'}};
    warn $cmd if $self->debug;
    $result = $db->raw_query($cmd,0,'parse');  # sets Ace::Error for us
  } else {   # old way for RPC server and local
    my $cmd = join('; ',"$self->{'class'} : $name",
		   @{$self->{'.update'}});
    warn $cmd if $self->debug;
    $result = $db->raw_query("parse = $cmd");
  }

  if (defined($result) and $result=~/write( or admin)? access/im) {  # this keeps changing