view release on metacpan or  search on metacpan

Ace/Object.pm  view on Meta::CPAN

    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) = @_;

Ace/Object.pm  view on Meta::CPAN

If you are creating an entirely new object, you I<must> add at least
one tag in order to enter the object into the database.

=head2 kill() method

    $result_code = $object->kill;

This will remove the object from the database immediately and
completely.  It does not wait for a commit(), and does not respond to
a rollback().  If successful, you will be left with an empty object
that contains just the class and object names.  Use with care!

In the case of failure, which commonly happens when the database is
not open for writing, this method will return undef.  A description of
the problem can be found by calling the error() method.

=head2 date_style() method

   $object->date_style('ace');

This is a convenience method that can be used to set the date format
for all objects returned by the database.  It is exactly equivalent to

   $object->db->date_style('ace');

Note that the text representation of the date will change for all
objects returned from this database, not just the current one.

=head2 isRoot() method

    print "Top level object" if $object->isRoot;

This method will return true if the object is a "top level" object,
that is the root of an object tree rather than a subtree.

=head2 model() method

    $model = $object->model;

This method will return the object's model as an Ace::Model object, or
undef if the object does not have a model. See L<Ace::Model> for
details.

=head2 timestamp() method

   $stamp = $object->timestamp;

The B<timestamp()> method will retrieve the modification time and date
from the object.  This works both with top level objects and with
subtrees.  Timestamp handling must be turned on in the database, or
B<timestamp()> will return undef.

The returned timestamp is actually a UserSession object which can be
printed and explored like any other object.  However, there is
currently no useful information in UserSession other than its name.

=head2 comment() method

   $comment = $object->comment;

This returns the comment attached to an object or object subtree, if
any.  Comments are I<Comment> objects and have the interesting
property that a single comment can refer to multiple objects.  If
there is no comment attached to the current subtree, this method will
return undef.

Currently you cannot create a new comment in AcePerl or edit an old
one.

=head2 error() method
    
    $error = $object->error;

Returns the error from the previous operation, if any.  As in
Ace::error(), this string will only have meaning if the previous
operation returned a result code indicating an error.

=head2 factory() method

WARNING - THIS IS DEFUNCT AND NO LONGER WORKS.  USE THE Ace->class() METHOD INSTEAD

    $package = $object->factory;

When a root Ace object instantiates its tree of tags and values, it
creates a hierarchical structure of Ace::Object objects.  The
factory() method determines what class to bless these subsidiary
objects into.  By default, they are Ace::Object objects, but you can
override this method in a child class in order to create more
specialized Ace::Object classes.  The method should return a string
corresponding to the package to bless the object into.  It receives
the current Ace::Object as its first argument.

=head2 debug() method

    $object->debug(1);

Change the debugging mode.  A zero turns off debugging messages.
Integer values produce debug messages on standard error.  Higher
integers produce progressively more verbose messages.  This actually
is just a front end to Ace->debug(), so the debugging level is global.

=head1 SEE ALSO

L<Ace>, L<Ace::Model>, L<Ace::Object>, L<Ace::Local>,
L<Ace::Sequence>,L<Ace::Sequence::Multi>

=head1 AUTHOR

Lincoln Stein <lstein@cshl.org> with extensive help from Jean
Thierry-Mieg <mieg@kaa.crbm.cnrs-mop.fr>

Copyright (c) 1997-1998, Lincoln D. Stein

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.  See DISCLAIMER.txt for
disclaimers of warranty.

=cut


# AUTOLOADED METHODS GO HERE

### Return the pretty-printed HTML table representation ###
### may pass a code reference to add additional formatting to cells ###