bless.* results from the CPAN

AcePerl

      $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)

Ace/Object.pm view on Meta::CPAN

  $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)) {

Ace/Object.pm view on Meta::CPAN

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 ###
sub asHTML {
    my $self = shift;
    my ($modify_code) = rearrange(['MODIFY'],@_);
    return unless defined($self->right);
    my $string = "<TABLE BORDER>\n<TR ALIGN=LEFT VALIGN=TOP><TH>$self</TH>";
    $modify_code = \&_default_makeHTML unless $modify_code;
    $self->right->_asHTML(\$string,1,2,$modify_code);
    $string .= "</TR>\n</TABLE>\n";
    return $string;
}

### Get the FASTA-format DNA/Peptide representation for this object ###
### (if appropriate) ###
sub asDNA {
  return shift()->_special_dump('dna');
}

sub asPeptide {
  return shift()->_special_dump('peptide');
}

sub _special_dump {
  my $self = shift;
  my $dump_format = shift;
  return unless $self->db->count($self->class,$self->name);
  my $result = $self->db->raw_query($dump_format);

( run in 0.587 second using v1.01-cache-2.11-cpan-99c4e6809bf )