AcePerl
view release on metacpan or search on metacpan
Ace/Object.pm view on Meta::CPAN
# 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'};
Ace/Object.pm view on Meta::CPAN
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";
my $right = $self->right;
$right->_asTable(\$string,1,2) if defined($right);
Ace/Object.pm view on Meta::CPAN
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 .= $_;
}
return $level-1;
}
$$out .= "\t" x ($level-$position-1);
$$out .= $self->name . "\t";
if ($self->comment) {
$$out .= $self->comment;
$$out .= "\n" . "\t" x $level unless $self->down && !defined($self->right);
}
$level = $self->right->_asTable($out,$level,$level+1)
if defined $self->right;
$$out .= "\n" if defined($self = $self->down);
$position = 0;
( run in 0.496 second using v1.01-cache-2.11-cpan-e1769b4cff6 )