AcePerl
65 results

 view release on metacpan or  search on metacpan

Ace.pm  view on Meta::CPAN 

$Error = '';

# Pseudonyms and deprecated methods.
*list      = \&fetch;
*Ace::ERR  = *Error;

# now completely deprecated and gone
# *find_many = \&fetch_many;
# *models    = \&classes;

sub connect {
  my $class = shift;
  my ($host,$port,$user,$pass,$path,$program,
      $objclass,$timeout,$query_timeout,$database,
      $server_type,$url,$u,$p,$cache,$other);

  # one-argument single "URL" form
  if (@_ == 1) {
    return $class->connect(-url=>shift);
  }

Ace/Browser/TreeSubs.pm  view on Meta::CPAN 

# less than or equal to this number
use constant MAXEXPAND => 4;


# A hack to allow access to external images.
# We use the name of the database as a URL to an external image.
# The URL will look like this:
#     /ace_images/external/database_name/foo.gif
# You must arrange for the URL to return the correct image, either with
# a CGI script, a symbolic link, or a redirection directive.
sub AceImageHackURL {
  my $image_name = shift;
  # correct some bad image file names in the database
  $image_name .= '.jpeg' unless $image_name =~ /\.(gif|jpg|jpeg|png|tiff|ps)$/;
  my $picture_path = Configuration->Pictures->[0];
  return join('/',$picture_path,Configuration->Name,'external',escape("$image_name"));
}


1;

Ace/Graphics/Fk.pm  view on Meta::CPAN 

# usage:
# Ace::Graphics::Fk->new(
#                         -start => 1,
#                         -end   => 100,
#                         -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};

Ace/Graphics/Glyph/anchored_arrow.pm  view on Meta::CPAN 

package Ace::Graphics::Glyph::anchored_arrow;
# package to use for drawing an arrow

use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

sub calculate_height {
  my $self = shift;
  my $val = $self->SUPER::calculate_height;
  $val += $self->font->height if $self->option('tick');
  $val;
}

# override draw method
sub draw {
  my $self = shift;
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);

  my $fg = $self->fgcolor;
  my $a2 = ($y2-$y1)/2;
  my $center = $y1+$a2;

  $gd->line($x1,$center,$x2,$center,$fg);

Ace/Graphics/Glyph/dot.pm  view on Meta::CPAN 

package Ace::Graphics::Glyph::dot;
# DAS-compatible package to use for drawing a ring or filled circle

use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

sub draw {
  my $self = shift;
#  $self->SUPER::draw(@_);
  my $gd = shift;
  my $fg = $self->fgcolor;

  # now draw a circle
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
  my $fg = $self->fgcolor;
  my $xmid   = (($x1+$x2)/2);  my $width  = abs($x2-$x1);
  my $ymid   = (($y1+$y2)/2);  my $height = abs($y2-$y1);

Ace/Graphics/Glyph/ex.pm  view on Meta::CPAN 

package Ace::Graphics::Glyph::ex;
# DAS-compatible package to use for drawing an "X"

use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

sub draw {
  my $self = shift;
  my $gd = shift;
  my $fg = $self->fgcolor;

  # now draw a cross
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
  my $fg = $self->fgcolor;

  if ($self->option('point')){
    my $p = $self->option('point');

Ace/Graphics/Glyph/graded_segments.pm  view on Meta::CPAN 

# (has the segment() method) and that has a score associated
# with each segment

use strict;
use vars '@ISA';
use GD;
use Ace::Graphics::Glyph::segments;
@ISA = 'Ace::Graphics::Glyph::segments';

# override draw method
sub draw {
  my $self = shift;

  # bail out if this isn't the right kind of feature
  # handle both das-style and Bio::SeqFeatureI style,
  # which use different names for subparts.
  my @segments;
  my $f = $self->feature;
  if ($f->can('segments')) {
    @segments = $f->segments;

Ace/Graphics/Glyph/group.pm  view on Meta::CPAN 


use strict;
use vars '@ISA';
use GD;
use Carp 'croak';

@ISA = 'Ace::Graphics::Glyph';

# override new() to accept an array ref for -feature
# the ref is not a set of features, but a set of other glyphs!
sub new {
  my $class = shift;
  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];

Ace/Graphics/Glyph/primers.pm  view on Meta::CPAN 

# package to use for drawing something that looks like
# primer pairs.

use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

use constant HEIGHT => 4;

# we do not need the default amount of room
sub calculate_height {
  my $self = shift;
  return $self->option('label') ? HEIGHT + $self->labelheight + 2 : HEIGHT;
}

# override draw method
sub draw {
  my $self = shift;
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);

  my $fg = $self->fgcolor;
  my $a2 = HEIGHT/2;
  my $center = $y1 + $a2;

  # just draw us as a solid line -- very simple
  if ($x2-$x1 < HEIGHT*2) {

Ace/Graphics/Glyph/segments.pm  view on Meta::CPAN 


use strict;
use vars '@ISA';
use GD;
@ISA = 'Ace::Graphics::Glyph';

use constant GRAY  => 'lightgrey';
my %BRUSHES;

# override right to allow for label
sub calculate_right {
  my $self = shift;
  my $left = $self->left;
  my $val = $self->SUPER::calculate_right(@_);

  if ($self->option('label') && (my $description = $self->description)) {
    my $description_width = $self->font->width * length $self->description;
    $val = $left + $description_width if $left + $description_width > $val;
  }
  $val;
}

# override draw method
sub draw {
  my $self = shift;

  # bail out if this isn't the right kind of feature
  # handle both das-style and Bio::SeqFeatureI style,
  # which use different names for subparts.
  my @segments;
  my $f = $self->feature;
  if ($f->can('merged_segments')) {
    @segments = $f->merged_segments;

Ace/Graphics/Glyph/transcript.pm  view on Meta::CPAN 


use strict;
use vars '@ISA';
@ISA = 'Ace::Graphics::Glyph';

use constant IMPLIED_INTRON_COLOR  => 'gray';
use constant ARROW => 4;

# override the left and right methods in order to
# provide extra room for arrows at the end
sub calculate_left {
  my $self = shift;
  my $val = $self->SUPER::calculate_left(@_);
  $val -= ARROW if $self->feature->strand < 0 && $val >= 4;
  $val;
}

sub calculate_right {
  my $self = shift;
  my $left = $self->left;
  my $val = $self->SUPER::calculate_right(@_);
  $val = $left + ARROW if $left + ARROW > $val;

  if ($self->option('label') && (my $description = $self->description)) {
    my $description_width = $self->font->width * length $description;
    $val = $left + $description_width if $left + $description_width > $val;
  }
  $val;
}

# override the bottom method in order to provide extra room for
# the label
sub calculate_height {
  my $self = shift;
  my $val = $self->SUPER::calculate_height(@_);
  $val += $self->labelheight if $self->option('label') && $self->description;
  $val;
}

# override filled_box method
sub filled_box {
  my $self = shift;
  my $gd = shift;
  my ($x1,$y1,$x2,$y2,$color) = @_;

  my $linewidth = $self->option('linewidth') || 1;
  $color ||= $self->fillcolor;
  $gd->filledRectangle($x1,$y1,$x2,$y2,$color);
  $gd->rectangle($x1,$y1,$x2,$y2,$self->fgcolor);

  # if the left end is off the end, then cover over
  # the leftmost line
  my ($width) = $gd->getBounds;
  $gd->line($x1,$y1,$x1,$y2,$color)
    if $x1 < 0;

  $gd->line($x2,$y1,$x2,$y2,$color)
    if $x2 > $width;
}

# override draw method
sub draw {
  my $self = shift;

  # bail out if this isn't the right kind of feature
  return $self->SUPER::draw(@_) unless $self->feature->can('segments');

  # get parameters
  my $gd = shift;
  my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_);
  my ($left,$top) = @_;

Ace/Graphics/GlyphFactory.pm  view on Meta::CPAN 

package Ace::Graphics::GlyphFactory;
# parameters for creating sequence glyphs of various sorts
# you *do* like glyphs, don't you?

use strict;
use Carp qw(carp croak confess);
use Ace::Graphics::Glyph;
use GD;

sub DESTROY { }

sub new {
  my $class   = shift;
  my $type    = shift;
  my @options = @_;

  # normalize options
  my %options;
  while (my($key,$value) = splice (@options,0,2)) {
    $key =~ s/^-//;
    $options{lc $key} = $value;
  }

Ace/Local.pm  view on Meta::CPAN 

use constant DEFAULT_DB=>'/usr/local/acedb';

# Changed readsize to be 4k rather than 5k.  Most flavours of UNIX
# have a page size of 4kb or a multiple thereof.  It improves
# efficiency to read an integer number of pages
# -- tim.cutts@incyte.com 08 Sep 1999

use constant READSIZE   => 1024 * 4;  # read 4k units

# this seems gratuitous, but don't delete it just yet
# $SIG{'CHLD'} = sub { wait(); } ;

sub connect {
  my $class = shift;
  my ($path,$program,$host,$port,$nosync) = rearrange(['PATH','PROGRAM','HOST','PORT','NOSYNC'],@_);
  my $args;
  
  # some pretty insane heuristics to handle BOTH tace and aceclient
  die "Specify either -path or -host and -port" if ($program && ($host || $port));
  die "-path is not relevant for aceclient, use -host and/or -port"
    if defined($program) && $program=~/aceclient/ && defined($path);
  die "-host and -port are not relevant for tace, use -path"
    if defined($program) && $program=~/tace/ and (defined $port || defined $host);

Ace/Model.pm  view on Meta::CPAN 

  '""' => 'asString',
  fallback => 'TRUE';

$VERSION = '1.51';

my $TAG     = '\b\w+\b';
my $KEYWORD  = q[^(XREF|UNIQUE|ANY|FREE|REPEAT|Int|Text|Float|DateType)$];
my $METAWORD = q[^(XREF|UNIQUE|ANY|FREE|REPEAT|Int|Text|Float|DateType)$];

# 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,

Ace/Object.pm  view on Meta::CPAN 


$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);

Ace/Object/Wormbase.pm  view on Meta::CPAN 

package Ace::Object::Wormbase;
use strict;
use Carp;
use Ace::Object;

# $Id: Wormbase.pm,v 1.3 2003/12/27 15:52:35 todd Exp $
use vars '@ISA';
@ISA = 'Ace::Object';

# override the Locus method for backward compatibility with model shift
sub Locus {
  my $self = shift;
  return $self->SUPER::Locus(@_) unless $self->class eq 'Sequence';
  if (wantarray) {
    return ($self->Locus_genomic_seq,$self->Locus_other_seq);
  } else {
    return $self->Locus_genomic_seq || $self->Locus_other_seq;
  }
}

sub Sequence {
  my $self = shift;
  return $self->SUPER::Sequence(@_) unless $self->class eq 'Locus';
  if (wantarray) {
#    return ($self->Genomic_sequence,$self->Other_sequence);
    return ($self->CDS,$self->Other_sequence);
  } else {
#    return $self->Genomic_sequence || $self->Other_sequence;
    return $self->CDS || $self->Other_sequence;
  }
}

Ace/Sequence.pm  view on Meta::CPAN 

# but can be called like this:
# $seq = Ace::Sequence->new(-db=>$db,-name=>$name);
# or
# $seq = Ace::Sequence->new(-seq    => $object,
#                           -offset => $offset,
#                           -length => $length,
#                           -ref    => $refseq
#                           );
# $refseq, if provided, will be used to establish the coordinate
# system.  Otherwise the first base pair will be set to 1.
sub new {
  my $pack = shift;
  my ($seq,$start,$end,$offset,$length,$refseq,$db) = 
    rearrange([
	       ['SEQ','SEQUENCE','SOURCE'],
	      'START',
	       ['END','STOP'],
	       ['OFFSET','OFF'],
	       ['LENGTH','LEN'],
	       'REFSEQ',
	       ['DATABASE','DB'],

 view all matches for this distribution
 view release on metacpan -  search on metacpan

( run in 1.075 second using v1.00-cache-2.02-grep-82fe00e-cpan-2c419f77a38b )