AcePerl
view release on metacpan or search on metacpan
Ace/Object.pm view on Meta::CPAN
# 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 {
Ace/Object.pm view on Meta::CPAN
# 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);
}
Ace/Object.pm view on Meta::CPAN
You can fetch tags more deeply nested in the structure by navigating
inwards using the methods listed below.
=head2 right() and down() methods
$subtree = $object->right;
$subtree = $object->right($position);
$subtree = $object->down;
$subtree = $object->down($position);
B<right()> and B<down()> provide a low-level way of traversing the
tree structure by following the tree's right and down pointers.
Called without any arguments, these two methods will move one step.
Called with a numeric argument >= 0 they will move the indicated
number of steps (zero indicates no movement).
$full_name = $object->right->right;
$full_name = $object->right(2);
$city = $object->right->down->down->right->right->down->down;
$city = $object->right->down(2)->right(2)->down(2);
If $object contains the "Thierry-Mieg J" Author object, then the first
series of accesses shown above retrieves the string "Jean
Thierry-Mieg" and the second retrieves "34033 Montpellier." If the
right or bottom pointers are NULL, these methods will return undef.
In addition to being somewhat awkard, you will probably never need to
use these methods. A simpler way to retrieve the same information
would be to use the at() method described in the next section.
The right() and down() methods always walk through the tree of the
current object. They do not follow object pointers into the database.
Use B<fetch()> (or the deprecated B<pick()> or B<follow()> methods)
instead.
=head2 at() method
$subtree = $object->at($tag_path);
@values = $object->at($tag_path);
at() is a simple way to fetch the portion of the tree that you are
interested in. It takes a single argument, a simple tag or a path. A
simple tag, such as "Full_name", must correspond to a tag in the
column immediately to the right of the root of the tree. A path such
as "Address.Mail" is a dot-delimited path to the subtree. Some
examples are given below.
($full_name) = $object->at('Full_name');
@address_lines = $object->at('Address.Mail');
The second line above is equivalent to:
@address = $object->at('Address')->at('Mail');
Called without a tag name, at() just dereferences the object,
returning whatever is to the right of it, the same as
$object->right
If a path component already has a dot in it, you may escape the dot
with a backslash, as in:
$s=$db->fetch('Sequence','M4');
@homologies = $s->at('Homol.DNA_homol.yk192f7\.3';
This also demonstrates that path components don't necessarily have to
be tags, although in practice they usually are.
at() returns slightly different results depending on the context in
which it is called. In a list context, it returns the column of
values to the B<right> of the tag. However, in a scalar context, it
returns the subtree rooted at the tag. To appreciate the difference,
consider these two cases:
$name1 = $object->at('Full_name');
($name2) = $object->at('Full_name');
After these two statements run, $name1 will be the tag object named
"Full_name", and $name2 will be the text object "Jean Thierry-Mieg",
The relationship between the two is that $name1->right leads to
$name2. This is a powerful and useful construct, but it can be a trap
for the unwary. If this behavior drives you crazy, use this
construct:
$name1 = $object->at('Full_name')->at();
For finer control over navigation, path components can include
optional indexes to indicate navigation to the right of the current
path component. Here is the syntax:
$object->at('tag1[index1].tag2[index2].tag3[index3]...');
Indexes are zero-based. An index of [0] indicates no movement
relative to the current component, and is the same as not using an
index at all. An index of [1] navigates one step to the right, [2]
moves two steps to the right, and so on. Using the Thierry-Mieg
object as an example again, here are the results of various indexes:
$object = $db->fetch(Author,"Thierry-Mieg J");
$a = $object->at('Address[0]') --> "Address"
$a = $object->at('Address[1]') --> "Mail"
$a = $object->at('Address[2]') --> "CRBM duCNRS"
In an array context, the last index in the path does something very
interesting. It returns the entire column of data K steps to the
right of the path, where K is the index. This is used to implement
so-called "tag[2]" syntax, and is very useful in some circumstances.
For example, here is a fragment of code to return the Thierry-Mieg
object's full address without having to refer to each of the
intervening "Mail", "E_Mail" and "Phone" tags explicitly.
@address = $object->at('Address[2]');
--> ('CRBM duCNRS','BP 5051','34033 Montpellier','FRANCE',
'mieg@kaa.cnrs-mop.fr,'33-67-613324','33-67-521559')
Similarly, "tag[3]" will return the column of data three hops to the
right of the tag. "tag[1]" is identical to "tag" (with no index), and
will return the column of data to the immediate right. There is no
special behavior associated with using "tag[0]" in an array context;
it will always return the subtree rooted at the indicated tag.
Ace/Object.pm view on Meta::CPAN
=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";
my $right = $self->right;
$right->_asTable(\$string,1,2) if defined($right);
return $string . "\n";
}
#### In "ace" format ####
sub asAce {
my $self = shift;
my $string = $self->isRoot ? join(' ',$self->class,':',$self->escape) . "\n" : '';
$self->right->_asAce(\$string,0,[]);
return "$string\n\n";
}
### Pretty-printed version ###
sub asString {
my $self = shift;
my $MAXWIDTH = shift || $DEFAULT_WIDTH;
my $tabs = $self->asTable;
return "$self" unless $tabs;
my(@lines) = split("\n",$tabs);
my($result,@max);
foreach (@lines) {
my(@fields) = split("\t");
for (my $i=0;$i<@fields;$i++) {
$max[$i] = length($fields[$i]) if
!defined($max[$i]) or $max[$i] < length($fields[$i]);
}
}
foreach (@max) { $_ = $MAXWIDTH if $_ > $MAXWIDTH; } # crunch long lines
my $format1 = join(' ',map { "^"."<"x $max[$_] } (0..$#max)) . "\n";
my $format2 = ' ' . join(' ',map { "^"."<"x ($max[$_]-1) } (0..$#max)) . "~~\n";
$^A = '';
foreach (@lines) {
my @data = split("\t");
push(@data,('')x(@max-@data));
formline ($format1,@data);
formline ($format2,@data);
}
return ($result = $^A,$^A='')[0];
}
# run a series of GIF commands and return the Gif and the semi-parsed
# "boxes" structure. Commands is typically a series of mouseclicks
# ($gif,$boxes) = $aceObject->asGif(-clicks=>[[$x1,$y1],[$x2,$y2]...],
# -dimensions=>[$x,$y]);
sub asGif {
my $self = shift;
my ($clicks,$dimensions,$display,$view,$coords,$getcoords) = rearrange(['CLICKS',
['DIMENSIONS','DIM'],
'DISPLAY',
'VIEW',
'COORDS',
'GETCOORDS',
],@_);
$display = "-D $display" if $display;
$view = "-view $view" if $view;
my $c;
if ($coords) {
$c = ref($coords) ? "-coords @$coords" : "-coords $coords";
}
my @commands;
if ($view || $c || $self->class =~ /Map/i) {
@commands = "gif map \"@{[$self->name]}\" $view $c";
} else {
@commands = "gif display $display $view @{[$self->class]} \"@{[$self->name]}\"";
}
push(@commands,"Dimensions @$dimensions") if ref($dimensions);
push(@commands,map { "mouseclick @{$_}" } @$clicks) if ref($clicks);
Ace/Object.pm view on Meta::CPAN
} while defined $self;
return --$level;
}
# This is the default code that will be called during construction of
# the HTML table. It returns a two-member list consisting of the modified
# entry and (optionally) a true value if we are to prune here. The returned string
# will be placed inside a <TD></TD> tag. There's nothing you can do about that.
sub _default_makeHTML {
my $self = shift;
my ($string,$prune) = ("$self",0);
return ($string,$prune) unless $self->isObject || $self->isTag;
if ($self->isTag) {
$string = "<B>$self</B>";
} elsif ($self->isComment) {
$string = "<I>$self</I>";
} else {
$string = qq{<FONT COLOR="blue">$self</FONT>} ;
}
return ($string,$prune);
}
# Insert a new tag or value.
# Local only. Will not affect the database.
# Returns the inserted tag, or the preexisting
# tag, if already there.
sub _insert {
my ($self,$tag) = @_;
my $p = $self->{'.right'};
return $self->{'.right'} = $self->new('tag',$tag)
unless $p;
while ($p) {
return $p if "$p" eq $tag;
last unless $p->{'.down'};
$p = $p->{'.down'};
}
# if we get here, then we didn't find it, so
# insert at the bottom
return $p->{'.down'} = $self->new('tag',$tag);
}
# This is unsatisfactory because it duplicates much of the code
# of asTable.
sub _asAce {
my($self,$out,$level,$tags) = @_;
# ugly optimization for speed
if ($self->{'.raw'}){
my ($a,$start,$end) = @{$self}{qw(.col .start_row .end_row)};
my (@last);
foreach (@{$self->{'.raw'}}[$start..$end]){
my $j=1;
$$out .= join("\t",@$tags) . "\t" if ($level==0) && (@$tags);
my (@to_modify) = @{$_}[$a..$#{$_}];
foreach (@to_modify) {
my ($class,$name) =Ace->split($_);
if (defined($name)) {
$name = $self->_ace_format($class,$name);
if (_isObject($class) || $name=~/[^\w.-]/) {
$name=~s/"/\\"/g; #escape quotes with slashes
$name = qq/\"$name\"/;
}
} else {
$name = $last[$j] if $name eq '';
}
$_ = $last[$j++] = $name;
$$out .= "$_\t";
}
$$out .= "\n";
$level = 0;
}
chop($$out);
return;
}
$$out .= join("\t",@$tags) . "\t" if ($level==0) && (@$tags);
$$out .= $self->escape . "\t";
if (defined $self->right) {
push(@$tags,$self->escape);
$self->right->_asAce($out,$level+1,$tags);
pop(@$tags);
}
if ($self->down) {
$$out .= "\n";
$self->down->_asAce($out,0,$tags);
}
}
sub _to_ace_date {
my $self = shift;
my $string = shift;
return $string unless lc($self->date_style) eq 'ace';
%MO = (Jan=>1,Feb=>2,Mar=>3,
Apr=>4,May=>5,Jun=>6,
Jul=>7,Aug=>8,Sep=>9,
Oct=>10,Nov=>11,Dec=>12) unless %MO;
my ($day,$mo,$yr) = split(" ",$string);
return "$yr-$MO{$mo}-$day";
}
### Return an XML syntax representation ###
### Consider this feature experimental ###
sub asXML {
my $self = shift;
return unless defined($self->right);
my ($do_content,$do_class,$do_value,$do_timestamps) = rearrange([qw(CONTENT CLASS VALUE TIMESTAMPS)],@_);
$do_content = 0 unless defined $do_content;
$do_class = 1 unless defined $do_class;
$do_value = 1 unless defined $do_value;
$do_timestamps = 1 unless (defined $do_timestamps && !$do_timestamps) || !$self->db->timestamps;
my %options = (content => $do_content,
class => $do_class,
value => $do_value,
timestamps => $do_timestamps);
my $name = $self->escapeXML($self->name);
my $class = $self->class;
my $string = '';
$self->_asXML(\$string,0,0,'',0,\%options);
return $string;
}
sub _asXML {
my($self,$out,$position,$level,$current_tag,$tag_level,$opts) = @_;
do {
my $name = $self->escapeXML($self->name);
my $class = $self->class;
my ($tagname,$attributes,$content) = ('','',''); # prevent uninitialized variable warnings
my $tab = " " x ($level-$position); # four spaces
$current_tag ||= $class;
$content = $name if $opts->{content};
if ($self->isTag) {
$current_tag = $tagname = $name;
$tag_level = 0;
} else {
$tagname = $tag_level > 0 ? sprintf "%s-%d",$current_tag,$tag_level + 1 : $current_tag;
$class = "#$class" unless $self->isObject;
$attributes .= qq( class="$class") if $opts->{class};
$attributes .= qq( value="$name") if $opts->{value};
}
if (my $c = $self->comment) {
$c = $self->escapeXML($c);
$attributes .= qq( comment="$c");
}
if ($opts->{timestamps} && (my $timestamp = $self->timestamp)) {
$timestamp = $self->escapeXML($timestamp);
$attributes .= qq( timestamp="$timestamp");
}
$tagname = $self->_xmlNumber($tagname) if $tagname =~ /^\d/;
unless (defined $self->right) { # lone tag
$$out .= $self->isTag || !$opts->{content} ? qq($tab<$tagname$attributes />\n)
: qq($tab<$tagname$attributes>$content</$tagname>\n);
} elsif ($self->isTag) { # most tags are implicit in the XML tag names
if (!XML_COLLAPSE_TAGS or $self->right->isTag) {
$$out .= qq($tab<$tagname$attributes>\n);
$level = $self->right->_asXML($out,$position,$level+1,$current_tag,$tag_level + !XML_COLLAPSE_TAGS,$opts);
$$out .= qq($tab</$tagname>\n);
} else {
$level = $self->right->_asXML($out,$position+1,$level+1,$current_tag,$tag_level,$opts);
}
} else {
$$out .= qq($tab<$tagname$attributes>$content\n);
$level = $self->right->_asXML($out,$position,$level+1,$current_tag,$tag_level+1,$opts);
$$out .= qq($tab</$tagname>\n);
}
$self = $self->down;
} while defined $self;
return --$level;
}
sub escapeXML {
my ($self,$string) = @_;
$string =~ s/&/&/g;
$string =~ s/\"/"/g;
$string =~ s/</</g;
$string =~ s/>/>/g;
return $string;
}
sub _xmlNumber {
my $self = shift;
my $tag = shift;
$tag =~ s/^(\d)/
$1 eq '0' ? 'zero'
: $1 eq '1' ? 'one'
: $1 eq '2' ? 'two'
: $1 eq '3' ? 'three'
: $1 eq '4' ? 'four'
: $1 eq '5' ? 'five'
: $1 eq '6' ? 'six'
: $1 eq '7' ? 'seven'
: $1 eq '8' ? 'eight'
: $1 eq '9' ? 'nine'
: $1/ex;
$tag;
}
( run in 0.609 second using v1.01-cache-2.11-cpan-8f98c5d2c55 )