AcePerl
view release on metacpan - search on metacpan
view release on metacpan or search on metacpan
Ace/Object.pm view on Meta::CPAN
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 -- 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+$/) {
$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 -- tim.cutts@incyte.com 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__
=head1 NAME
Ace::Object - Manipulate Ace Data Objects
=head1 SYNOPSIS
# open database connection and get an object
use Ace;
$db = Ace->connect(-host => 'beta.crbm.cnrs-mop.fr',
-port => 20000100);
$sequence = $db->fetch(Sequence => 'D12345');
# Inspect the object
$r = $sequence->at('Visible.Overlap_Right');
@row = $sequence->row;
@col = $sequence->col;
@tags = $sequence->tags;
# Explore object substructure
@more_tags = $sequence->at('Visible')->tags;
@col = $sequence->at("Visible.$more_tags[1]")->col;
# Follow a pointer into database
$r = $sequence->at('Visible.Overlap_Right')->fetch;
$next = $r->at('Visible.Overlap_left')->fetch;
# Classy way to do the same thing
$r = $sequence->Overlap_right;
$next = $sequence->Overlap_left;
# Pretty-print object
print $sequence->asString;
print $sequence->asTabs;
print $sequence->asHTML;
# Update object
$sequence->replace('Visible.Overlap_Right',$r,'M55555');
$sequence->add('Visible.Homology','GR91198');
$sequence->delete('Source.Clone','MBR122');
$sequence->commit();
# Rollback changes
$sequence->rollback()
# Get errors
print $sequence->error;
=head1 DESCRIPTION
view all matches for this distributionview release on metacpan - search on metacpan
( run in 0.991 second using v1.00-cache-2.02-grep-82fe00e-cpan-58dc6251afda )