AcePerl
view release on metacpan or search on metacpan
Ace/Object.pm view on Meta::CPAN
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;
}
Ace/Object.pm view on Meta::CPAN
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
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,
strings, text, floating point numbers, as well as specialized
biological types, such as "dna" and "peptide." Another fundamental
type is "tag," which is a text identifier used to label portions of
the tree. Examples of tags include "Paper" and "Laboratory" in the
example above.
Ace/Object.pm view on Meta::CPAN
Unlike get(), this method will B<always step into objects>. This
means that:
$map = $clone->Map;
will return the Sequence_Map object pointed to by the Clone's Map tag
and not simply a pointer to a portion of the Clone tree. Therefore
autogenerated methods are functionally equivalent to the following:
$map = $clone->get('Map')->fetch;
The scalar context semantics are also slightly different. In a scalar
context, the autogenerated function will *always* move one step to the
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);
Ace/Object.pm view on Meta::CPAN
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
Ace/Object.pm view on Meta::CPAN
$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'};
}
$p->{'.down'} = $values[0];
} else {
$p->{'.right'} = $values[0];
}
push(@{$self->{'.update'}},join(' ',map { Ace->freeprotect($_) } (@tags,@values)));
delete $self->{'.PATHS'}; # uncache cached values
$self->_dirty(1);
1;
}
# Use this method to add an entire subobject to the right of the tag.
# The tree may come from another database.
sub add_tree {
my $self = shift;
my($tag,$value,@rest) = rearrange([['TAG','PATH'],['VALUE','TREE']],@_);
croak "Value must be an Ace::Object" unless ref($value) && $value->isa('Ace::Object');
unless ($tag =~ /\./) {
my $model = $self->model;
my @intermediate_tags = $model->path($tag);
$tag = join '.',@intermediate_tags,$tag;
}
# position at the indicated tag, creating it if necessary
my (@tags) = $self->_split_tags($tag);
my $p = $self;
foreach (@tags) {
$p = $p->_insert($_);
}
# Copy the subtree too
if ($p->{'.right'}) {
$p = $p->{'.right'};
while (1) {
last unless $p->{'.down'};
$p = $p->{'.down'};
}
$p->{'.down'} = $value->{'.right'};
} else {
$p->{'.right'} = $value->{'.right'};
}
push(@{$self->{'.update'}},map { join(' ',@tags,$_) } split("\n",$value->asAce));
delete $self->{'.PATHS'}; # uncache cached values
$self->_dirty(1);
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 delete {
my $self = shift;
my($tag,$oldvalue,@rest) = rearrange([['TAG','PATH'],['VALUE','OLDVALUE','OLD']],@_);
# flatten array refs into array
my @values;
@values = map { ref($_) && ref($_) eq 'ARRAY' ? @$_ : $_ } ($oldvalue,@rest)
if defined($oldvalue);
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));
my $subtree = $self->at($row,undef,1); # returns the parent
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
my ($a,$start,$end) = @{$self}{ qw(.col .start_row .end_row) };
my @to_append = map { join("\t",@{$_}[$a..$#{$_}]) } @{$self->{'.raw'}}[$start..$end];
my $new_row;
foreach (@to_append) {
# hack alert
s/(\?.*?[^\\]\?.*?[^\\]\?)\S*/$self->_ace_format(Ace->split($1))/eg;
if ($new_row++) {
$$out .= "\n";
$$out .= "\t" x ($level-1)
}
$$out .= $_;
}
( run in 1.051 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )