AcePerl
view release on metacpan or search on metacpan
Ace/Object.pm view on Meta::CPAN
}
$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;
Ace/Object.pm view on Meta::CPAN
}
# 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
I<Ace::Object> is the base class for objects returned from ACEDB
databases. Currently there is only one type of I<Ace::Object>, but
this may change in the future to support more interesting
object-specific behaviors.
Using the I<Ace::Object> interface, you can explore the internal
structure of an I<Ace::Object>, retrieve its content, and convert it
into various types of text representation. You can also fetch a
representation of any object as a GIF image.
If you have write access to the databases, add new data to an object,
replace existing data, or kill it entirely. You can also create a new
object de novo and write it into the database.
For information on connecting to ACEDB databases and querying them,
see L<Ace>.
=head1 ACEDB::OBJECT METHODS
The structure of an Ace::Object is very similar to that of an Acedb
object. It is a tree structure like this one (an Author object):
Thierry-Mieg J->Full_name ->Jean Thierry-Mieg
|
Laboratory->FF
|
Address->Mail->CRBM duCNRS
| | |
| | BP 5051
| | |
| | 34033 Montpellier
| | |
| | FRANCE
| |
| E_mail->mieg@kaa.cnrs-mop.fr
| |
| Phone ->33-67-613324
| |
| Fax ->33-67-521559
|
Paper->The C. elegans sequencing project
|
Genome Project Database
|
Genome Sequencing
|
How to get ACEDB for your Sun
|
ACEDB is Hungry
Each object in the tree has two pointers, a "right" pointer to the
node on its right, and a "down" pointer to the node beneath it. Right
pointers are used to store hierarchical relationships, such as
Address->Mail->E_mail, while down pointers are used to store lists,
such as the multiple papers written by the Author.
Each node in the tree has a type and a name. Types include integers,
Ace/Object.pm view on Meta::CPAN
some piece of information about the object in question. You can
display it in the status bar of the browser or in a popup window if
your browser provides that facility.
=head2 asDNA() and asPeptide() methods
$dna = $object->asDNA();
$peptide = $object->asPeptide();
If you are dealing with a sequence object of some sort, these methods
will return strings corresponding to the DNA or peptide sequence in
FASTA format.
=head2 add_row() method
$result_code = $object->add_row($tag=>$value);
$result_code = $object->add_row($tag=>[list,of,values]);
$result_code = $object->add(-path=>$tag,
-value=>$value);
add_row() updates the tree by adding data to the indicated tag path. The
example given below adds the value "555-1212" to a new Address entry
named "Pager". You may call add_row() a second time to add a new value
under this tag, creating multi-valued entries.
$object->add_row('Address.Pager'=>'555-1212');
You may provide a list of values to add an entire row of data. For
example:
$sequence->add_row('Assembly_tags'=>['Finished Left',38949,38952,'AC3']);
Actually, the array reference is not entirely necessary, and if you
prefer you can use this more concise notation:
$sequence->add_row('Assembly_tags','Finished Left',38949,38952,'AC3');
No check is done against the database model for the correct data type
or tag path. The update isn't actually performed until you call
commit(), at which time a result code indicates whether the database
update was successful.
You may create objects that reference other objects this way:
$lab = new Ace::Object('Laboratory','LM',$db);
$lab->add_row('Full_name','The Laboratory of Medicine');
$lab->add_row('City','Cincinatti');
$lab->add_row('Country','USA');
$author = new Ace::Object('Author','Smith J',$db);
$author->add_row('Full_name','Joseph M. Smith');
$author->add_row('Laboratory',$lab);
$lab->commit();
$author->commit();
The result code indicates whether the addition was syntactically
correct. add_row() will fail if you attempt to add a duplicate entry
(that is, one with exactly the same tag and value). In this case, use
replace() instead. Currently there is no checking for an attempt to
add multiple values to a single-valued (UNIQUE) tag. The error will
be detected and reported at commit() time however.
The add() method is an alias for add_row().
See also the Ace->new() method.
=head2 add_tree()
$result_code = $object->add_tree($tag=>$ace_object);
$result_code = $object->add_tree(-tag=>$tag,-tree=>$ace_object);
The add_tree() method will insert an entire Ace subtree into the object
to the right of the indicated tag. This can be used to build up
complex Ace objects, or to copy portions of objects from one database
to another. The first argument is a tag path, and the second is the
tree that you wish to insert. As with add_row() the database will
only be updated when you call commit().
When inserting a subtree, you must be careful to remember that
everything to the *right* of the node that you are pointing at will be
inserted; not the node itself. For example, given this Sequence
object:
Sequence AC3
DB_info Database EMBL
Assembly_tags Finished Left 1 4 AC3
Clone left end 1 4 AC3
Clone right end 5512 5515 K07C5
38949 38952 AC3
Finished Right 38949 38952 AC3
If we use at('Assembly_tags') to fetch the subtree rooted on the
"Assembly_tags" tag, it is the tree to the right of this tag,
beginning with "Finished Left", that will be inserted.
Here is an example of copying the "Assembly_tags" subtree
from one database object to another:
$remote = Ace->connect(-port=>200005) || die "can't connect";
$ac3 = $remote->fetch(Sequence=>'AC3') || die "can't get AC7";
my $assembly = $ac3->at('Assembly_tags');
$local = Ace->connect(-path=>'~acedb') || die "can't connect";
$AC3copy = Ace::Object->new(Sequence=>'AC3copy',$local);
$AC3copy->add_tree('Assembly_tags'=>$tags);
$AC3copy->commit || warn $AC3copy->error;
Notice that this syntax will not work the way you think it should:
$AC3copy->add_tree('Assembly_tags'=>$ac3->at('Assembly_tags'));
This is because call at() in an array context returns the column to
the right of the tag, not the tag itself.
Here's an example of building up a complex structure from scratch
using a combination of add() and add_tree():
$newObj = Ace::Object->new(Sequence=>'A555',$local);
my $assembly = Ace::Object->new(tag=>'Assembly_tags');
$assembly->add('Finished Left'=>[10,20,'ABC']);
$assembly->add('Clone right end'=>[1000,2000,'DEF']);
$assembly->add('Clone right end'=>[8000,9876,'FRED']);
$assembly->add('Finished Right'=>[1000,3000,'ETHEL']);
$newObj->add_tree('Assembly_tags'=>$assembly);
$newObj->commit || warn $newObj->error;
=head2 delete() method
$result_code = $object->delete($tag_path,$value);
$result_code = $object->delete(-path=>$tag_path,
-value=>$value);
Delete the indicated tag and value from the object. This example
deletes the address line "FRANCE" from the Author's mailing address:
$object->delete('Address.Mail','FRANCE');
No actual database deletion occurs until you call commit(). The
delete() result code indicates whether the deletion was successful.
Currently it is always true, since the database model is not checked.
=head2 replace() method
$result_code = $object->replace($tag_path,$oldvalue,$newvalue);
$result_code = $object->replace(-path=>$tag_path,
-old=>$oldvalue,
-new=>$newvalue);
Replaces the indicated tag and value with the new value. This example
changes the address line "FRANCE" to "LANGUEDOC" in the Author's
mailing address:
$object->delete('Address.Mail','FRANCE','LANGUEDOC');
No actual database changes occur until you call commit(). The
delete() result code indicates whether the replace was successful.
Currently is true if the old value was identified.
=head2 commit() method
$result_code = $object->commit;
Commits all add(), replace() and delete() operations to the database.
It can also be used to write a completely new object into the
database. The result code indicates whether the object was
successfully written. If an error occurred, further details can be
found in the Ace->error() error string.
=head2 rollback() method
$object->rollback;
Discard all adds, deletions and replacements, returning the object to
the state it was in prior to the last commit().
rollback() works by deleting the object from Perl memory and fetching
the object anew from AceDB. If someone has changed the object in the
database while you were working with it, you will see this version,
ot the one you originally fetched.
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 ###
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);
$result =~ s!^//.*!!ms;
$result;
}
#### As tab-delimited table ####
sub asTable {
my $self = shift;
my $string = "$self\t";
Ace/Object.pm view on Meta::CPAN
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
$Ace::Error = "Write access denied";
} elsif (defined($result) and $result =~ /sorry|parse error/mi) {
$Ace::Error = $result;
}
return if $Ace::Error;
undef $self->{'.update'};
# this will force a fresh retrieval of the object
# and synchronize our in-memory copy with the db
delete $self->{'.right'};
delete $self->{'.PATHS'};
return 1;
}
# undo changes
sub rollback {
my $self = shift;
undef $self->{'.update'};
# this will force object to be reloaded from database
# next time it is needed.
delete $self->{'.right'};
delete $self->{'.PATHS'};
1;
}
sub debug {
my $self = shift;
Ace->debug(@_);
}
### Get or set the date style (actually calls through to the database object) ###
sub date_style {
my $self = shift;
return unless $self->db;
return $self->db->date_style(@_);
}
sub _asHTML {
my($self,$out,$position,$level,$morph_code) = @_;
do {
$$out .= "<TR ALIGN=LEFT VALIGN=TOP>" unless $position;
$$out .= "<TD></TD>" x ($level-$position-1);
my ($cell,$prune,$did_it_myself) = $morph_code->($self);
$$out .= $did_it_myself ? $cell : "<TD>$cell</TD>";
if ($self->comment) {
my ($cell,$p,$d) = $morph_code->($self->comment);
$$out .= $d ? $cell : "<TD>$cell</TD>";
$$out .= "</TR>\n" . "<TD></TD>" x $level unless $self->down && !defined($self->right);
}
$level = $self->right->_asHTML($out,$level,$level+1,$morph_code) if defined($self->right) && !$prune;
$$out .= "</TR>\n" if defined($self = $self->down);
$position = 0;
} while defined $self;
return --$level;
}
# This function is overly long because it is optimized to prevent parsing
# parts of the tree that haven't previously been parsed.
sub _asTable {
my($self,$out,$position,$level) = @_;
do {
if ($self->{'.raw'}) { # we still have raw data, so we can optimize
( run in 1.038 second using v1.01-cache-2.11-cpan-39bf76dae61 )