AcePerl
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;
}
}
Ace/Object.pm view on Meta::CPAN
# 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
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.
In addition to these built-in types, there are constructed types known
as classes. These types are specified by the data model. In the
above example, "Thierry-Mieg J" is an object of the "Author" class,
and "Genome Project Database" is an object of the "Paper" class. An
interesting feature of objects is that you can follow them into the
database, retrieving further information. For example, after
retrieving the "Genome Project Database" Paper from the Author object,
you could fetch more information about it, either by following B<its>
right pointer, or by using one of the specialized navigation routines
described below.
=head2 new() method
$object = new Ace::Object($class,$name,$database);
$object = new Ace::Object(-class=>$class,
-name=>$name,
-db=>database);
You can create a new Ace::Object from scratch by calling the new()
routine with the object's class, its identifier and a handle to the
database to create it in. The object won't actually be created in the
database until you add() one or more tags to it and commit() it (see
below). If you do not provide a database handle, the object will be
created in memory only.
Arguments can be passed positionally, or as named parameters, as shown
above.
This routine is usually used internally. See also add_row(),
add_tree(), delete() and replace() for ways to manipulate this object.
=head2 name() method
$name = $object->name();
Return the name of the Ace::Object. This happens automatically
whenever you use the object in a context that requires a string or a
number. For example:
$object = $db->fetch(Author,"Thierry-Mieg J");
print "$object did not write 'Pride and Prejudice.'\n";
=head2 class() method
$class = $object->class();
Return the class of the object. The return value may be one of
"float," "int," "date," "tag," "txt," "dna," "peptide," and "scalar."
(The last is used internally by Perl to represent objects created
programatically prior to committing them to the database.) The class
may also be a user-constructed type such as Sequence, Clone or
Author. These user-constructed types usually have an initial capital
letter.
=head2 db() method
$db = $object->db();
Return the database that the object is associated with.
=head2 isClass() method
$bool = $object->isClass();
Returns true if the object is a class (can be fetched from the
database).
=head2 isTag() method
$bool = $object->isTag();
Returns true if the object is a tag.
=head2 tags() method
@tags = $object->tags();
Return all the top-level tags in the object as a list. In the Author
example above, the returned list would be
('Full_name','Laboratory','Address','Paper').
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;
Ace/Object.pm view on Meta::CPAN
You must explicitly step over the non-tag node in order to make this
query work. This syntax will work:
my $left = $clone->get('Map',1)->get('Left'); # works
my $left = $clone->get('Map',1)->get('Right'); # works
Or you might prefer to use the tag[2] syntax here:
my($left,$right) = $clone->get('Map',1)->at('Ends[2]');
Although not frequently used, there is a form of get() which allows
you to stack subtags:
$locus = $object->get('Positive'=>'Positive_locus');
Only on subtag is allowed. You can follow this by a position if wish
to offset from the subtag.
$locus = $object->get('Positive'=>'Positive_locus',1);
=head2 search() method
This is a deprecated synonym for get().
=head2 Autogenerated Access Methods
$scalar = $object->Name_of_tag;
$scalar = $object->Name_of_tag($position);
@array = $object->Name_of_tag;
@array = $object->Name_of_tag($position);
@array = $object->Name_of_tag($subtag=>$position);
@array = $object->Name_of_tag(-fill=>$tag);
The module attempts to autogenerate data access methods as needed.
For example, if you refer to a method named "Fax" (which doesn't
correspond to any of the built-in methods), then the code will call
the B<get()> method to find a tag named "Fax" and return its
contents.
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);
B<col()> flattens a portion of the tree by returning the column one
hop to the right of the current subtree. You can provide an additional
positional index to navigate through the tree using "tag[2]" behavior.
This example returns the author's mailing address:
@mailing_address = $object->at('Address.Mail')->col();
This example returns the author's entire address including mail,
e-mail and phone:
@address = $object->at('Address')->col(2);
It is equivalent to any of these calls:
$object->at('Address[2]');
$object->get('Address',2);
$object->Address(2);
Use whatever syntax is most comfortable for you.
In a scalar context, B<col()> returns the number of items in the
column.
=head2 row() method
@row=$object->row();
@row=$object->row($position);
B<row()> will return the row of data to the right of the object. The
first member of the list will be the object itself. In the case of
the "Thierry-Mieg J" object, the example below will return the list
('Address','Mail','CRBM duCNRS').
@row = $object->Address->row();
You can provide an optional position to move rightward one or more
places before retrieving the row. This code fragment will return
('Mail','CRBM duCNRS'):
@row = $object->Address->row(1);
In a scalar context, B<row()> returns the number of items in the row.
=head2 asString() method
$object->asString;
asString() returns a pretty-printed ASCII representation of the object
tree.
=head2 asTable() method
$object->asTable;
asTable() returns the object as a tab-delimited text table.
=head2 asAce() method
$object->asAce;
asAce() returns the object as a tab-delimited text table in ".ace"
format.
=head2 asHTML() method
$object->asHTML;
$object->asHTML(\&tree_traversal_code);
asHTML() returns an HTML 3 table representing the object, suitable for
incorporation into a Web browser page. The callback routine, if
provided, will have a chance to modify the object representation
before it is incorporated into the table, for example by turning it
into an HREF link. The callback takes a single argument containing
the object, and must return a string-valued result. It may also
return a list as its result, in which case the first member of the
list is the string representation of the object, and the second
member is a boolean indicating whether to prune the table at this
level. For example, you can prune large repetitive lists.
Here's a complete example:
sub process_cell {
my $obj = shift;
return "$obj" unless $obj->isObject || $obj->isTag;
my @col = $obj->col;
my $cnt = scalar(@col);
return ("$obj -- $cnt members",1); # prune
if $cnt > 10 # if subtree to big
# tags are bold
return "<B>$obj</B>" if $obj->isTag;
# objects are blue
return qq{<FONT COLOR="blue">$obj</FONT>} if $obj->isObject;
}
$object->asHTML(\&process_cell);
=head2 asXML() method
$result = $object->asXML;
asXML() returns a well-formed XML representation of the object. The
particular representation is still under discussion, so this feature
is primarily for demonstration.
=head2 asGIF() method
Ace/Object.pm view on Meta::CPAN
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";
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);
if ($getcoords) { # just want the coordinates
my ($start,$stop);
my $data = $self->db->raw_query(join(' ; ',@commands));
return unless $data =~ /\"[^\"]+\" ([\d.-]+) ([\d.-]+)/;
($start,$stop) = ($1,$2);
Ace/Object.pm view on Meta::CPAN
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'
( run in 0.651 second using v1.01-cache-2.11-cpan-0bb4e1dffa6 )