AcePerl
view release on metacpan or search on metacpan
'path' => $path,
'class' => $objclass || 'Ace::Object',
'timeout' => $query_timeout,
'user' => $user,
'pass' => $pass,
'other' => $other,
'date_style' => 'java',
'auto_save' => 0,
};
my $self = bless $contents,ref($class)||$class;
$self->_create_cache($cache) if $cache;
$self->name2db("$self",$self);
return $self;
}
sub reopen {
my $self = shift;
return 1 if $self->ping;
my $class = ref($self->{database});
Ace/Browser/SiteDefs.pm view on Meta::CPAN
$data{ucfirst(lc $_)} = \&symbol if defined(&symbol);
undef *symbol unless defined &symbol; # conserve some memory
}
# special case: get the search scripts as both an array and as a hash
if (my @searches = @{"$namespace\:\:SEARCHES"}) {
$data{Searches} = [ @searches[map {2*$_} (0..@searches/2-1)] ];
%{$data{Search_titles}} = @searches;
}
# return this thing as a blessed object
return bless \%data,$package;
}
sub resolvePath {
my $self = shift;
my $file = shift;
my $root = $self->Root || '/cgi-bin';
return "$root/$file";
}
sub resolveConf {
Ace/Graphics/Fk.pm view on Meta::CPAN
# -name => 'fred feature',
# -info => $additional_stuff_to_store,
# -strand => +1);
#
# Alternatively, use -segments => [ [start,stop],[start,stop]...]
# to create a multisegmented feature.
sub new {
my $class= shift;
my %arg = @_;
my $self = bless {},$class;
$arg{-strand} ||= 0;
$self->{strand} = $arg{-strand} >= 0 ? +1 : -1;
$self->{name} = $arg{-name};
$self->{info} = $arg{-info};
if (my $s = $arg{-segments}) {
my @segments;
for my $seg (@$s) {
Ace/Graphics/Glyph.pm view on Meta::CPAN
# simple glyph class
# args: -feature => $feature_object
# args: -factory => $factory_object
sub new {
my $class = shift;
my %arg = @_;
my $feature = $arg{-feature};
my ($start,$end) = ($feature->start,$feature->end);
($start,$end) = ($end,$start) if $start > $end;
return bless {
@_,
top => 0,
left => 0,
right => 0,
start => $start,
end => $end
},$class;
}
# delegates
Ace/Graphics/Glyph/group.pm view on Meta::CPAN
my %arg = @_;
my $parts = $arg{-feature};
croak('Usage: Ace::Graphics::Glyph::group->new(-features=>$glypharrayref,-factory=>$factory)')
unless ref $parts eq 'ARRAY';
# sort parts horizontally
my @sorted = sort { $a->left <=> $b->left } @$parts;
my $leftmost = $sorted[0];
my $rightmost = (sort { $a->right <=> $b->right } @$parts)[-1];
my $self = bless {
@_,
top => 0,
left => 0,
right => 0,
leftmost => $leftmost,
rightmost => $rightmost,
members => \@sorted,
},$class;
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
$options{fontcolor} ||= 'black';
$type = $options{glyph} if defined $options{glyph};
my $glyphclass = 'Ace::Graphics::Glyph';
$glyphclass .= "\:\:$type" if $type && $type ne 'generic';
confess("the requested glyph class, ``$type'' is not available: $@")
unless (eval "require $glyphclass");
return bless {
glyphclass => $glyphclass,
scale => 1, # 1 pixel per kb
options => \%options,
},$class;
}
sub clone {
my $self = shift;
my %val = %$self;
$val{options} = {%{$self->{options}}};
return bless \%val,ref($self);
}
# set the scale for glyphs we create
sub scale {
my $self = shift;
my $g = $self->{scale};
$self->{scale} = shift if @_;
$g;
}
Ace/Graphics/Panel.pm view on Meta::CPAN
my $length = $options{-length} || 0;
my $offset = $options{-offset} || 0;
my $spacing = $options{-spacing} || 5;
my $keycolor = $options{-keycolor} || KEYCOLOR;
my $keyspacing = $options{-keyspacing} || KEYSPACING;
$length ||= $options{-segment}->length if $options{-segment};
$offset ||= $options{-segment}->start-1 if $options{-segment};
return bless {
tracks => [],
width => $options{-width} || 600,
pad_top => $options{-pad_top}||0,
pad_bottom => $options{-pad_bottom}||0,
pad_left => $options{-pad_left}||0,
pad_right => $options{-pad_right}||0,
length => $length,
offset => $offset,
height => 0, # AUTO
spacing => $spacing,
Ace/Graphics/Track.pm view on Meta::CPAN
# Pass a list of Ace::Sequence::Feature objects, and a glyph name
sub new {
my $class = shift;
my ($glyph_name,$features,@options) = @_;
$glyph_name ||= 'generic';
$features ||= [];
my $glyph_factory = $class->make_factory($glyph_name,@options);
my $self = bless {
features => [], # list of Ace::Sequence::Feature objects
factory => $glyph_factory, # the glyph class associated with this track
glyphs => undef, # list of glyphs
},$class;
$self->add_feature($_) foreach @$features;
$self;
}
# control bump direction:
# +1 => bump downward
Ace/Iterator.pm view on Meta::CPAN
my ($db,$query,$filled,$chunksize) = rearrange([qw/DB QUERY FILLED CHUNKSIZE/],@_);
my $self = {
'db' => $db,
'query' => $query,
'valid' => undef,
'cached_answers' => [],
'filled' => ($filled || 0),
'chunksize' => ($chunksize || 40),
'current' => 0
};
bless $self,$pack;
$db->_register_iterator($self) if $db && ref($db);
$self;
}
sub next {
my $self = shift;
croak "Attempt to use an expired iterator" unless $self->{db};
$self->_fill_cache() unless @{$self->{'cached_answers'}};
my $cache = $self->{cached_answers};
my $result = shift @{$cache};
Ace/Local.pm view on Meta::CPAN
unless ($nosync) {
local($/) = "> ";
my $data = <$rdr>;
($prompt) = $data=~/^(.+> )/m;
unless ($prompt) {
$Ace::Error = "$program didn't open correctly";
return undef;
}
}
return bless {
'read' => $rdr,
'write' => $wtr,
'prompt' => $prompt,
'pid' => $pid,
'auto_save' => 1,
'status' => $nosync ? STATUS_PENDING : STATUS_WAITING, # initial stuff to read
},$class;
}
sub debug {
Ace/Model.pm view on Meta::CPAN
# construct a new Ace::Model
sub new {
my $class = shift;
my ($data,$db,$break_cycle) = @_;
$break_cycle ||= {};
$data=~s!\s+//.*$!!gm; # remove all comments
$data=~s!\0!!g;
my ($name) = $data =~ /\A[\?\#](\w+)/;
my $self = bless {
name => $name,
raw => $data,
submodels => [],
},$class;
if (!$break_cycle->{$name} && $db && (my @hashes = grep {$_ ne $name} $data =~ /\#(\S+)/g)) {
$break_cycle->{$name}++;
my %seen;
my @submodels = map {$db->model($_,$break_cycle)} grep {!$seen{$_}++} @hashes;
$self->{submodels} = \@submodels;
Ace/Object.pm view on Meta::CPAN
###################### 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 {
Ace/Object.pm view on Meta::CPAN
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;
Ace/Object.pm view on Meta::CPAN
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.
Ace/Sequence.pm view on Meta::CPAN
$offset ||= 0;
$offset *= -1 if $strand < 0;
# handle feature objects
$offset += $obj->offset if $obj->can('smapped');
# get source
my $source = $obj->can('smapped') ? $obj->source : $obj;
# store the object into our instance variables
my $self = bless {
obj => $source,
offset => $offset,
length => $length || $p_length,
parent => $parent,
p_offset => $p_offset,
refseq => [$source,$r_offset,$r_strand],
strand => $strand,
absolute => 0,
automerge => 1,
},$pack;
Ace/Sequence/Feature.pm view on Meta::CPAN
# handling coordinates. See SCRAPS below for what should be in here
$strand = '+1' if $strand < 0 && $r_strand < 0; # two wrongs do make a right
($start,$end) = ($end,$start) if $strand < 0;
my $offset = $start - 1;
my $length = ($end > $start) ? $end - $offset : $end - $offset - 2;
# handle negative strands
$offset ||= 0;
$offset *= -1 if $r_strand < 0 && $strand != $r_strand;
my $self= bless {
obj => $ref,
offset => $offset,
length => $length,
parent => $parent,
p_offset => $r_offset,
refseq => [$ref,$r_offset,$r_strand],
strand => $r_strand,
fstrand => $strand,
absolute => $abs,
info => {
Ace/Sequence/FeatureList.pm view on Meta::CPAN
my $package =shift;
my @lines = split("\n",$_[0]);
my (%parsed);
foreach (@lines) {
next if m!^//!;
my ($minor,$major,$count) = split "\t";
next unless $count > 0;
$parsed{$major}{$minor} += $count;
$parsed{_TOTAL} += $count;
}
return bless \%parsed,$package;
}
# no arguments, scalar context -- count all features
# no arguments, array context -- list of major types
# 1 argument, scalar context -- count of major type
# 1 argument, array context -- list of minor types
# 2 arguments -- count of subtype
sub types {
my $self = shift;
my ($type,$subtype) = @_;
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
$len = $segments[-1]->end - $segments[0]->start + 1;
} else {
$offset = $segments[-1]->{offset};
$len = $segments[0]->end - $segments[-1]->start + 1;
}
my $base = { %{$segments[0]} };
$base->{offset} = $offset;
$base->{length} = $len;
bless $base,ref($segments[0]);
return bless {
base => $base,
segments => $segments,
},$class;
}
sub smapped { 1; }
sub asString {
shift->{base}->info;
}
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
return @{$self->{merged_segs}} if exists $self->{merged_segs};
my @segs = sort {$a->start <=> $b->start} $self->segments;
# attempt to merge overlapping segments
my @merged;
for my $s (@segs) {
my $previous = $merged[-1];
if ($previous && $previous->end+1 >= $s->start) {
$previous->{length} = $s->end - $previous->start + 1; # extend
} else {
my $clone = bless {%$s},ref($s);
push @merged,$clone;
}
}
$self->{merged_segs} = \@merged;
return @merged;
}
1;
__END__
Ace/Sequence/Gene.pm view on Meta::CPAN
# contained in base
sub AUTOLOAD {
my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
my $self = shift;
$self->{base}->$func_name(@_);
}
sub new {
my $class = shift;
my $args = shift;
bless $args,$class;
return $args;
# for documentation only
# my %args = @_;
# my $introns = $args{intron};
# my $exons = $args{exon};
# my $sequence = $args{base}; # this is the Ace::Sequence::Feature object
# return bless {base => $sequence,
# introns => $introns,
# exons => $exons},$class;
}
sub asString {
shift->{base}->info;
}
sub relative {
Ace/Sequence/Homol.pm view on Meta::CPAN
# this was a mistake!
# use overload '""' => 'asString';
# *stop = \&end;
sub new_homol {
my ($pack,$tclass,$tname,$db,$start,$end) = @_;
return unless my $obj = $db->class->new($tclass,$tname,$db,1);
@$obj{'start','end'} = ($start,$end);
return bless $obj,$pack;
}
sub start { return $_[0]->{'start'}; }
sub end { return $_[0]->{'end'}; }
sub stop { return $_[0]->{'end'}; }
# sub _clone {
# my $self = shift;
Ace/Sequence/Multi.pm view on Meta::CPAN
sub new {
my $pack = shift;
my ($secondary,$rest) = rearrange([['SECONDARY','DBS']],@_);
return unless my $obj = $pack->SUPER::new($rest);
if (defined $secondary) {
my @s = ref $secondary eq 'ARRAY' ? @$secondary : $secondary;
$obj->{'secondary'} = { map { $_=> $_} @s };
}
return bless $obj,$pack;
}
sub secondary {
return unless my $s = $_[0]->{'secondary'};
return values %{$s};
}
sub add_secondary {
my $self = shift;
foreach (@_) {
Ace/Sequence/Transcript.pm view on Meta::CPAN
my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/;
my $self = shift;
$self->{base}->$func_name(@_);
}
sub DESTROY { }
sub new {
my $class = shift;
my $args = shift;
bless $args,$class;
return $args;
# for documentation only
# my %args = @_;
# my $introns = $args{intron};
# my $exons = $args{exon};
# my $sequence = $args{base}; # this is the Ace::Sequence::Feature object
# return bless {base => $sequence,
# intron => $introns,
# exon => $exons,
# cds => $cds,},$class;
}
sub smapped { 1; }
sub asString {
shift->{base}->info;
Ace/SocketServer.pm view on Meta::CPAN
use constant ACESERV_SERVER_HELLO => "et bonjour a vous";
sub connect {
my $class = shift;
my ($host,$port,$timeout,$user,$pass) = rearrange(['HOST','PORT','TIMEOUT','USER','PASS'],@_);
$user ||= DEFAULT_USER;
$pass ||= DEFAULT_PASS;
$timeout ||= DEFAULT_TIMEOUT;
my $s = IO::Socket::INET->new("$host:$port") ||
return _error("Couldn't establish connection");
my $self = bless { socket => $s,
client_id => 0, # client ID provided by server
timeout => $timeout,
},$class;
return unless $self->_handshake($user,$pass);
$self->{status} = STATUS_WAITING;
$self->{encoring} = 0;
return $self;
}
sub DESTROY {
GFF/Filehandle.pm view on Meta::CPAN
# this is a dumb trick to work around GFF.pm's current inability to
# take data from memory. It makes the in-memory data look like a filehandle.
package GFF::Filehandle;
sub TIEHANDLE {
my ($package,$datalines) = @_;
return bless $datalines,$package;
}
sub READLINE {
my $self = shift;
return shift @$self;
}
1;
TYPEMAP
ace_handle* T_PTR
AceDB* O_OBJECT
AceObject* O_OBJECT
OUTPUT
# The Perl object is blessed into 'CLASS', which should be a
# char* having the name of the package for the blessing.
O_OBJECT
sv_setref_pv( $arg, CLASS, (void*)$var );
INPUT
O_OBJECT
if( sv_isobject($arg) && (SvTYPE(SvRV($arg)) == SVt_PVMG) )
$var = ($type)SvIV((SV*)SvRV( $arg ));
else{
warn( \"${Package}::$func_name() -- $var is not a blessed SV reference\" );
XSRETURN_UNDEF;
}
( run in 0.417 second using v1.01-cache-2.11-cpan-de7293f3b23 )