view release on metacpan or  search on metacpan

Ace/Object.pm  view on Meta::CPAN

right.

The list context semantics are identical to get().  If you want to
dereference all members of a multivalued tag, you have to do so manually:

  @papers = $author->Paper;
  foreach (@papers) { 
    my $paper = $_->fetch;
    print  $paper->asString;
  }

You can provide an optional positional index to rapidly navigate
through the tree or to obtain tag[2] behavior.  In the following
examples, the first two return the object's Fax number, and the third
returns all data two hops to the right of Address.

     $object   = $db->fetch(Author => 'Thierry-Mieg J');
     ($fax_no) = $object->Fax;
     $fax_no   = $object->Fax(1);
     @address  = $object->Address(2);

You may also position at a subtag, using this syntax:

     $representative = $object->Laboratory('Representative');

Both named tags and positions can be combined as follows:

     $lab_address = $object->Laboratory(Address=>2);

If you provide a -fill=>$tag argument, then the object fetch will
automatically fill the specified subtree, greatly improving
performance.  For example:

      $lab_address = $object->Laboratory(-filled=>'Address');

** NOTE: In a scalar context, if the node to the right of the tag is
** an object, the method will perform an implicit dereference of the
** object.  For example, in the case of:

    $lab = $author->Laboratory;

**NOTE: The object returned is the dereferenced Laboratory object, not
a node in the Author object.  You can control this by giving the
autogenerated method a numeric offset, such as Laboratory(0) or
Laboratory(1).  For backwards compatibility, Laboratory('@') is
equivalent to Laboratory(1).

The semantics of the autogenerated methods have changed subtly between
version 1.57 (the last stable release) and version 1.62.  In earlier
versions, calling an autogenerated method in a scalar context returned
the subtree rooted at the tag.  In the current version, an implicit
right() and dereference is performed.


=head2 fetch() method

    $new_object = $object->fetch;
    $new_object = $object->fetch($tag);

Follow object into the database, returning a new object.  This is
the best way to follow object references.  For example:

    $laboratory = $object->at('Laboratory')->fetch;
    print $laboratory->asString;

Because the previous example is a frequent idiom, the optional $tag
argument allows you to combine the two operations into a single one:

    $laboratory = $object->fetch('Laboratory');

=head2 follow() method

    @papers        = $object->follow('Paper');
    @filled_papers = $object->follow(-tag=>'Paper',-filled=>1);
    @filled_papers = $object->follow(-tag=>'Paper',-filled=>'Author');

The follow() method will follow a tag into the database, dereferencing
the column to its right and returning the objects resulting from this
operation.  Beware!  If you follow a tag that points to an object,
such as the Author "Paper" tag, you will get a list of all the Paper
objects.  If you follow a tag that points to a scalar, such as
"Full_name", you will get an empty string.  In a scalar context, this
method will return the number of objects that would have been
followed.

The full named-argument form of this call accepts the arguments
B<-tag> (mandatory) and B<-filled> (optional).  The former points to
the tag to follow.  The latter accepts a boolean argument or the name
of a subtag.  A numeric true argument will return completely "filled"
objects, increasing network and memory usage, but possibly boosting
performance if you have a high database access latency.
Alternatively, you may provide the name of a tag to follow, in which
case just the named portion of the subtree in the followed objects
will be filled (v.g.)

For backward compatability, if follow() is called without any
arguments, it will act like fetch().

=head2 pick() method

Deprecated method.  This has the same semantics as fetch(), which
should be used instead.

=head2 col() method

     @column = $object->col;
     @column = $object->col($position);


B<col()> flattens a portion of the tree by returning the column one
hop to the right of the current subtree. You can provide an additional
positional index to navigate through the tree using "tag[2]" behavior.
This example returns the author's mailing address:

  @mailing_address = $object->at('Address.Mail')->col();

This example returns the author's entire address including mail,
e-mail and phone:

  @address = $object->at('Address')->col(2);

Ace/Object.pm  view on Meta::CPAN

    my ($left,$top,$right,$bottom,$class,$name,$comments) = 
      m/^\s*\d*\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\w+):"(.+)"\s*(.*)/;
    next unless defined $left;
    $comments=~s/\s+$//; # sometimes there's extra white space at the end
    my $box = {'coordinates'=>[$left,$top,$right,$bottom],
	       'class'=>$class,
	       'name' =>$name,
	       'comment'=>$comments};
    push (@b,$box);
  }
  return ($gif,\@b);
}

############## timestamp and comment information ############
sub timestamp {
    my $self = shift;
    return $self->{'.timestamp'} = $_[0] if defined $_[0];
    if ($self->db && !$self->{'.timestamp'}) {
      $self->_fill;
      $self->_parse;
    }
    return $self->{'.timestamp'} if $self->{'.timestamp'};
    return unless defined $self->right;
    return $self->{'.timestamp'} = $self->right->timestamp;
}

sub comment {
    my $self = shift;
    return $self->{'.comment'} = $_[0] if defined $_[0];
    if ($self->db && !$self->{'.comment'}) {
      $self->_fill;
      $self->_parse;
    }
    return $self->{'.comment'};
}

### Return list of all the tags in the object ###
sub tags {
    my $self = shift;
    my $current = $self->right;
    my @tags;
    while (defined($current)) {
	push(@tags,$current);
	$current = $current->down;
    }
    return @tags;
}

################# kill an object ################
# Removes the object from the database immediately.
sub kill {
  my $self = shift;
  return unless my $db = $self->db;
  return 1 unless $db->count($self->class,$self->name);
  my $result = $db->raw_query("kill");
  if (defined($result) and $result=~/write access/im) {  # this keeps changing
    $Ace::Error = "Write access denied";
    return;
  }
  # uncache cached values and clear the object out
  # as best we can
  delete @{$self}{qw[.PATHS .right .raw .down]};
  1;
}

# sub isTimestamp {
#   my $self = shift;
#   return 1 if $self->class eq 'UserSession';
#   return;
# }

sub isComment {
  my $self = shift;
  return 1 if $self->class eq 'Comment';
  return;
}

################# add a new row #############
#  Only changes local copy until you perform commit() #
#  returns true if this is a valid thing to do #
sub add_row {
  my $self = shift;
  my($tag,@newvalue) = rearrange([['TAG','PATH'],'VALUE'],@_);

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

  # make sure that this entry doesn't already exist
  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));
  return if $self->at($row);  # an identical row already exists in the object

  # If we get here then we need to turn @values into an array of Ace::Objects
  # for insertion.  Also need to link them together into a row.
  my $previous;
  foreach (@values) {
    if (ref($_) && $_->isa('Ace::Object')) {
      $_ = $_->_clone;
    } else {
      $_ = $self->new('scalar',$_);
    }
    $previous->{'.right'} = $_ if defined $previous;
    $previous = $_;
    $_->{'.right'} = undef; # make sure it doesn't automatically expand!
  }

  # position at the indicated tag (creating it if necessary)
  my (@tags) = $self->_split_tags($tag);
  my $p = $self;
  foreach (@tags) {
    $p = $p->_insert($_);
  }
  if ($p->{'.right'}) {
    $p = $p->{'.right'};
    while (1) { 
      last unless $p->{'.down'};
      $p = $p->{'.down'};