AcePerl
view release on metacpan or search on metacpan
can open a connection this way too:
$db = connect Ace -host=>'beta.crbm.cnrs-mop.fr',-port=>20000100;
The return value is an Ace handle to use to access the database, or
undef if the connection fails. If the connection fails, an error
message can be retrieved by calling Ace->error.
You may check the status of a connection at any time with ping(). It
will return a true value if the database is still connected. Note
that Ace will timeout clients that have been inactive for any length
of time. Long-running clients should attempt to reestablish their
connection if ping() returns false.
$db->ping() || die "not connected";
You may perform low-level calls using the Ace client C API by calling
db(). This fetches an Ace::AceDB object. See THE LOW LEVEL C API for
details on using this object.
$low_level = $db->db();
Ace/Graphics/Fk.pm view on Meta::CPAN
}
return $self->{start};
}
sub end {
my $self = shift;
if (my @segments = $self->segments) {
return $segments[-1]->end;
}
return $self->{end};
}
sub length {
my $self = shift;
return $self->end - $self->start + 1;
}
sub introns {
my $self = shift;
return;
}
sub source_tag { 'dummy' }
sub target { }
sub info {
Ace/Graphics/Glyph.pm view on Meta::CPAN
sub color {
my $self = shift;
my $factory = $self->factory;
my $color = $factory->option(shift) or return $self->fgcolor;
$factory->translate($color);
}
sub start { shift->{start} }
sub end { shift->{end} }
sub offset { shift->factory->offset }
sub length { shift->factory->length }
# this is a very important routine that dictates the
# height of the bounding box. We start with the height
# dictated by the factory, and then adjust if needed
sub height {
my $self = shift;
$self->{cache_height} = $self->calculate_height unless exists $self->{cache_height};
return $self->{cache_height};
}
Ace/Graphics/Glyph.pm view on Meta::CPAN
$val > 0 ? $val : 0;
}
sub calculate_right {
my $self = shift;
my $val = $self->{left} + $self->map_pt($self->{end} - 1);
$val = 0 if $val < 0;
$val = $self->width if $val > $self->width;
if ($self->option('label') && (my $label = $self->label)) {
my $left = $self->left;
my $label_width = $self->font->width * CORE::length $label;
my $label_end = $left + $label_width;
$val = $label_end if $label_end > $val;
}
$val;
}
sub map_pt {
my $self = shift;
my $point = shift;
$point -= $self->offset;
Ace/Graphics/Glyph.pm view on Meta::CPAN
=item $end = $glyph->end
These methods return the start and end of the glyph in base pair
units.
=item $offset = $glyph->offset
Returns the offset of the segment (the base pair at the far left of
the image).
=item $length = $glyph->length
Returns the length of the sequence segment.
=back
Retrieving formatting information:
=over 4
=item $top = $glyph->top
Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN
if ($self->feature->start < $self->offset) { # off left end
if ($x2 > $a2) {
$gd->line($x1,$center,$x1+$a2,$center-$a2,$fg); # arrowhead
$gd->line($x1,$center,$x1+$a2,$center+$a2,$fg);
}
} else {
$gd->line($x1,$center-$a2,$x1,$center+$a2,$fg); # tick/base
}
if ($self->feature->end > $self->offset + $self->length) {# off right end
if ($x1 < $x2-$a2-1) {
$gd->line($x2,$center,$x2-$a2,$center+$a2,$fg); # arrowhead
$gd->line($x2,$center,$x2-$a2,$center-$a2,$fg);
}
} else {
# problems occur right at the very end because of GD confusion
$x2-- if $self->feature->end == $self->offset + $self->length;
$gd->line($x2,$center-$a2,$x2,$center+$a2,$fg); # tick/base
}
$self->draw_ticks($gd,@_) if $self->option('tick');
# add a label if requested
$self->draw_label($gd,@_) if $self->option('label');
}
sub draw_label {
my $self = shift;
my ($gd,$left,$top) = @_;
my $label = $self->label or return;
my $start = $self->left + ($self->right - $self->left - length($label) * $self->font->width)/2;
$gd->string($self->font,$left + $start,$top + $self->top,$label,$self->fontcolor);
}
sub draw_ticks {
my $self = shift;
my ($gd,$left,$top) = @_;
my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries($left,$top);
my $a2 = ($y2-$y1)/2;
my $center = $y1+$a2;
Ace/Graphics/Glyph/anchored_arrow.pm view on Meta::CPAN
# figure out tick mark scale
# we want no more than 1 tick mark every 30 pixels
# and enough room for the labels
my $font = $self->font;
my $width = $font->width;
my $font_color = $self->fontcolor;
my $relative = $self->option('relative_coords');
my $start = $relative ? 1 : $self->feature->start;
my $stop = $start + $self->feature->length - 1;
my $reversed = 0;
if ($self->feature->strand == -1) {
$stop = -$stop;
$reversed = 1;
}
my $interval = 1;
my $mindist = 30;
my $widest = 5 + (length($stop) * $width);
$mindist = $widest if $widest > $mindist;
while (1) {
my $pixels = $interval * $scale;
last if $pixels >= $mindist;
$interval *= 10;
}
my $first_tick = $interval * int(0.5 + $start/$interval);
for (my $i = $first_tick; $i < $stop; $i += $interval) {
my $tickpos = !$reversed ? $left + $self->map_pt($i-1 + $self->feature->start)
: $left + $self->map_pt($self->feature->start - $i - 1);
$gd->line($tickpos,$center-$a2,$tickpos,$center+$a2,$fg);
my $middle = $tickpos - (length($i) * $width)/2;
$gd->string($font,$middle,$center+$a2-1,$i,$font_color)
if $middle > 0 && $middle < $self->factory->panel->width-($font->width * length $i);
}
if ($self->option('tick') >= 2) {
my $a4 = ($y2-$y1)/4;
for (my $i = $first_tick; $i < $stop; $i += $interval/10) {
my $tickpos = !$reversed ? $left + $self->map_pt($i-1 + $self->feature->start)
: $left + $self->map_pt($self->feature->start - $i - 1);
$gd->line($tickpos,$center-$a4,$tickpos,$center+$a4,$fg);
}
}
Ace/Graphics/Glyph/arrow.pm view on Meta::CPAN
# figure out tick mark scale
# we want no more than 1 tick mark every 30 pixels
# and enough room for the labels
my $font = $self->font;
my $width = $font->width;
my $font_color = $self->fontcolor;
my $interval = 1;
my $mindist = 30;
my $widest = 5 + (length($self->end) * $width);
$mindist = $widest if $widest > $mindist;
my ($gcolor,$gtop,$gbottom);
if ($self->option('grid')) {
$gcolor = $self->color('grid');
my $panel_height = $self->factory->panel->height;
$gtop = $self->factory->panel->pad_top;
$gbottom = $panel_height - $self->factory->panel->pad_bottom;
}
Ace/Graphics/Glyph/arrow.pm view on Meta::CPAN
my $a4 = $self->SUPER::height/4;
for (my $i = $first_tick - $interval; $i < $self->end; $i += $interval/10) {
my $tickpos = $left + $self->map_pt($i);
$gd->line($tickpos,$gtop,$tickpos,$gbottom,$gcolor) if defined $gcolor;
$gd->line($tickpos,$center-$a4,$tickpos,$center+$a4,$fg);
}
}
for (my $i = $first_tick; $i < $self->end; $i += $interval) {
my $tickpos = $left + $self->map_pt($i);
my $middle = $tickpos - (length($i) * $width)/2;
$gd->string($font,$middle,$center+$a2-1,$i,$font_color)
if $middle > 0 && $middle < $self->factory->panel->width-($font->width * length $i);
}
}
$gd->line($x1,$center,$x2,$center,$fg);
if ($sw) { # west arrow
$gd->line($x1,$center,$x1+$a2,$center-$a2,$fg);
$gd->line($x1,$center,$x1+$a2,$center+$a2,$fg);
}
if ($ne) { # east arrow
Ace/Graphics/Glyph/ex.pm view on Meta::CPAN
=head2 OPTIONS
In addition to the common options, the following glyph-specific
options are recognized:
Option Description Default
------ ----------- -------
-point Whether to draw an "X" the feature width
scaled width of the feature
or with arm length point.
=head1 BUGS
Please report them.
=head1 SEE ALSO
L<Ace::Sequence>, L<Ace::Sequence::Feature>, L<Ace::Graphics::Panel>,
L<Ace::Graphics::Track>, L<Ace::Graphics::Glyph::anchored_arrow>,
L<Ace::Graphics::Glyph::arrow>,
Ace/Graphics/Glyph/primers.pm view on Meta::CPAN
Ace::Graphics::Glyph::primers - The "STS primers" glyph
=head1 SYNOPSIS
See L<Ace::Graphics::Panel> and L<Ace::Graphics::Glyph>.
=head1 DESCRIPTION
This glyph draws two arrows oriented towards each other and connected
by a line of a contrasting color. The length of the arrows is
immaterial, but the length of the glyph itself corresponds to the
length of the scaled feature.
=head2 OPTIONS
In addition to the common options, the following glyph-specific
options are recognized:
Option Description Default
------ ----------- -------
-connect Whether to connect the false
Ace/Graphics/Glyph/segments.pm view on Meta::CPAN
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
Ace/Graphics/Glyph/transcript.pm view on Meta::CPAN
$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(@_);
Ace/Graphics/Glyph/triangle.pm view on Meta::CPAN
=head2 OPTIONS
In addition to the common options, the following glyph-specific
options are recognized:
Option Description Default
------ ----------- -------
-point Whether to draw a triangle feature width
with base the scaled width
of the feature or length
point.
-orient On which side shall the S
base be? (NSEW)
=head1 BUGS
Please report them.
=head1 SEE ALSO
Ace/Graphics/GlyphFactory.pm view on Meta::CPAN
my $c = $self->option('bgcolor',@_);
$self->translate($c);
}
sub fillcolor {
my $self = shift;
my $c = $self->option('fillcolor',@_) || $self->option('color',@_);
$self->translate($c);
}
sub length { shift->option('length',@_) }
sub offset { shift->option('offset',@_) }
sub translate { my $self = shift; $self->panel->translate(@_) || $self->fgcolor; }
sub rgb { shift->panel->rgb(@_) }
# create a new glyph from configuration
sub glyph {
my $self = shift;
my $feature = shift;
return $self->{glyphclass}->new(-feature => $feature,
-factory => $self);
Ace/Graphics/Panel.pm view on Meta::CPAN
my %COLORS;
# Create a new panel of a given width and height, and add lists of features
# one by one
sub new {
my $class = shift;
my %options = @_;
$class->read_colors() unless %COLORS;
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,
keycolor => $keycolor,
keyspacing => $keyspacing,
},$class;
}
sub width {
my $self = shift;
Ace/Graphics/Panel.pm view on Meta::CPAN
$d + $self->pad_left + $self->pad_right;
}
sub spacing {
my $self = shift;
my $d = $self->{spacing};
$self->{spacing} = shift if @_;
$d;
}
sub length {
my $self = shift;
my $d = $self->{length};
if (@_) {
my $l = shift;
$l = $l->length if ref($l) && $l->can('length');
$self->{length} = $l;
}
$d;
}
sub pad_top {
my $self = shift;
my $d = $self->{pad_top};
$self->{pad_top} = shift if @_;
$d || 0;
}
Ace/Graphics/Panel.pm view on Meta::CPAN
}
$self->_add_track($glyph_name,$features,-1,@_);
}
sub _add_track {
my $self = shift;
my ($glyph_type,$features,$direction,@options) = @_;
unshift @options,'-offset' => $self->{offset} if defined $self->{offset};
unshift @options,'-length' => $self->{length} if defined $self->{length};
$features = [$features] unless ref $features eq 'ARRAY';
my $track = Ace::Graphics::Track->new($glyph_type,$features,@options);
$track->set_scale(abs($self->length),$self->{width});
$track->panel($self);
if ($direction >= 0) {
push @{$self->{tracks}},$track;
} else {
unshift @{$self->{tracks}},$track;
}
return $track;
}
Ace/Graphics/Panel.pm view on Meta::CPAN
my $boxes = $panel->boxes;
print $panel->png;
=head1 DESCRIPTION
The Ace::Graphics::Panel class provides drawing and formatting
services for Ace::Sequence::Feature objects or Das::Segment::Feature
objects.
Typically you will begin by creating a new Ace::Graphics::Panel
object, passing it the width of the visual display and the length of
the segment.
You will then call add_track() one or more times to add sets of
related features to the picture. When you have added all the features
you desire, you may call png() to convert the image into a PNG-format
image, or boxes() to return coordinate information that can be used to
create an imagemap.
Note that this modules depends on GD.
Ace/Graphics/Panel.pm view on Meta::CPAN
=over 4
=item $panel = Ace::Graphics::Panel->new(@options)
The new() method creates a new panel object. The options are
a set of tag/value pairs as follows:
Option Value Default
------ ----- -------
-length Length of sequence segment, in bp 0
-segment An Ace::Sequence or Das::Segment none
object, used to derive length if
not provided
-offset Base pair to place at extreme left $segment->start
of image.
-width Desired width of image, in pixels 600
-spacing Spacing between tracks, in pixels 5
-pad_top Additional whitespace between top 0
Ace/Graphics/Panel.pm view on Meta::CPAN
of image and bottom, in pixels
-keycolor Background color for the key printed 'cornsilk'
at bottom of panel (if any)
-keyspacing Spacing between key glyphs in the 10
key printed at bottom of panel
(if any)
Typically you will pass new() an object that implements the
Bio::RangeI interface, providing a length() method, from which the
panel will derive its scale.
$panel = Ace::Graphics::Panel->new(-segment => $sequence,
-width => 800);
new() will return undef in case of an error. If the specified glyph
name is not a valid one, new() will throw an exception.
=back
Ace/Graphics/Panel.pm view on Meta::CPAN
Note that in most cases you must change attributes prior to invoking
gd(), png() or boxes(). These three methods all invoke an internal
layout() method which places the tracks and the glyphs within them,
and then caches the result.
Accessor Name Description
------------- -----------
width() Get/set width of panel
spacing() Get/set spacing between tracks
length() Get/set length of segment (bp)
pad_top() Get/set top padding
pad_left() Get/set left padding
pad_bottom() Get/set bottom padding
pad_right() Get/set right padding
=head2 INTERNAL METHODS
The following methods are used internally, but may be useful for those
implementing new glyph types.
Ace/Graphics/Track.pm view on Meta::CPAN
my $self = shift;
my $g = $self->{width};
$self->{width} = shift if @_;
$g;
}
# set scale by a segment
sub scale_to_segment {
my $self = shift;
my ($segment,$desired_width) = @_;
$self->set_scale(abs($segment->length),$desired_width);
}
sub set_scale {
my $self = shift;
my ($bp,$desired_width) = @_;
$desired_width ||= 512;
$self->scale($desired_width/$bp);
$self->width($desired_width);
}
Ace/Graphics/Track.pm view on Meta::CPAN
$top += 0; $left += 0;
my $glyphs = $self->layout;
# draw background
my $bgcolor = $self->factory->bgcolor;
# $gd->filledRectangle($left,$top,$left+$self->width,$top+$self->height,$bgcolor);
if (my $label = $self->factory->option('track_label')) {
my $font = $self->factory->font;
my $y = $top + ($self->height-$font->height)/2;
my $x = $left - length($label) * $font->width;
$gd->string($font,$x,$y,$label,$self->factory->fontcolor);
}
$_->draw($gd,$left,$top) foreach @$glyphs;
if ($self->factory->option('connectgroups')) {
$_->draw($gd,$left,$top) foreach @{$self->{groups}};
}
}
# lay out -- this uses the infamous bump algorithm
Ace/Local.pm view on Meta::CPAN
$args = $path;
}
my($rdr,$wtr) = (gensym,gensym);
my($pid) = open2($rdr,$wtr,"$program $args");
unless ($pid) {
$Ace::Error = <$rdr>;
return undef;
}
# Figure out the prompt by reading until we get zero length,
# then take whatever's at the end.
unless ($nosync) {
local($/) = "> ";
my $data = <$rdr>;
($prompt) = $data=~/^(.+> )/m;
unless ($prompt) {
$Ace::Error = "$program didn't open correctly";
return undef;
}
}
Ace/Local.pm view on Meta::CPAN
return undef;
}
sysread($rdr,$data,READSIZE);
return $data;
}
sub read {
my $self = shift;
return undef unless $self->{'status'} == STATUS_PENDING;
my $rdr = $self->{'read'};
my $len = defined $self->{'buffer'} ? length($self->{'buffer'}) : 0;
my $plen = length($self->{'prompt'});
my ($result, $bytes, $pos, $searchfrom);
while (1) {
# Read the data directly onto the end of the buffer
$bytes = sysread($rdr, $self->{'buffer'},
READSIZE, $len);
unless ($bytes > 0) {
Ace/Local.pm view on Meta::CPAN
# check for prompt
# The following checks were implemented using regexps and $' and
# friends. I have changed this to use {r}index and substr (a)
# because they're much faster than regexps and (b) because using
# $' and $` causes all regexps in a program to execute
# very slowly due to excessive and unnecessary pre/post-match
# copying -- tim.cutts@incyte.com 08 Sep 1999
# Note, don't need to search the whole buffer for the prompt;
# just need to search the new data and the prompt length from
# any previous data.
$searchfrom = ($len <= $plen) ? 0 : ($len - $plen);
if (($pos = index($self->{'buffer'},
$self->{'prompt'},
$searchfrom)) > 0) {
$self->{'status'} = STATUS_WAITING;
$result = substr($self->{'buffer'}, 0, $pos);
$self->{'buffer'} = '';
Ace/Model.pm view on Meta::CPAN
# accumulate a list of all the paths
my (@paths,@path,@path_stack);
my $current_position = 0;
LINE:
for my $line (@lines) {
TOKEN:
while ($line =~ /(\S+)/g) { # get a token
my $tag = $1;
my $position = pos($line) - length $tag;
next TOKEN if $tag =~ /$METAWORD/o;
if ($tag =~ /^[?\#]/) {
next TOKEN if $position == 0; # the name of the model, so get next token
next LINE; # otherwise abandon this line
}
if ($position > $current_position) { # here's a subtag
push @path_stack,[$current_position,[@path]]; # remember a copy of partial path
push @paths,[@path]; # remember current path
push @path,$tag; # append to the current path
Ace/Object.pm view on Meta::CPAN
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);
Ace/Sequence.pm view on Meta::CPAN
*source_tag = \&subtype;
*primary_tag = \&type;
my %plusminus = ( '+' => '-',
'-' => '+',
'.' => '.');
# internal keys
# parent => reference Sequence in "+" strand
# p_offset => our start in the parent
# length => our length
# strand => our strand (+ or -)
# refseq => reference Sequence for coordinate system
# object constructor
# usually called like this:
# $seq = Ace::Sequence->new($object);
# 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'],
],@_);
Ace/Sequence.pm view on Meta::CPAN
# object itself. The reference sequence is used to set up
# the frame of reference for the coordinate system.
# fetch the sequence object if we don't have it already
croak "Please provide either a Sequence object or a database and name"
unless ref($seq) || ($seq && $db);
# convert start into offset
$offset = $start - 1 if defined($start) and !defined($offset);
# convert stop/end into length
$length = ($end > $start) ? $end - $offset : $end - $offset - 2
if defined($end) && !defined($length);
# if just a string is passed, try to fetch a Sequence object
my $obj = ref($seq) ? $seq : $db->fetch('Sequence'=>$seq);
unless ($obj) {
Ace->error("No Sequence named $obj found in database");
return;
}
# get parent coordinates and length of this sequence
# the parent is an Ace Sequence object in the "+" strand
my ($parent,$p_offset,$p_length,$strand) = find_parent($obj);
return unless $parent;
# handle negative strands
my $r_strand = $strand;
my $r_offset = $p_offset;
$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;
# set the reference sequence
eval { $self->refseq($refseq) } or return if defined $refseq;
Ace/Sequence.pm view on Meta::CPAN
}
# return the "source" object that the user offset from
sub source {
$_[0]->{obj};
}
# return the parent object
sub parent { $_[0]->{parent} }
# return the length
#sub length { $_[0]->{length} }
sub length {
my $self = shift;
my ($start,$end) = ($self->start,$self->end);
return $end - $start + ($end > $start ? 1 : -1); # for stupid 1-based adjustments
}
sub reversed { return shift->strand < 0; }
sub automerge {
my $self = shift;
my $d = $self->{automerge};
Ace/Sequence.pm view on Meta::CPAN
}
# look up reference sequence in database if we aren't given
# database object already
$refseq = $self->db->fetch('Sequence' => $refseq)
unless $refseq->isa('Ace::Object');
croak "Invalid reference sequence" unless $refseq;
# find position of ref sequence in parent strand
my ($r_parent,$r_offset,$r_length,$r_strand) = find_parent($refseq);
croak "Reference sequence has no common ancestor with sequence"
unless $r_parent eq $self->{parent};
# set to array reference containing this information
$arrayref = [$refseq,$r_offset,$r_strand];
}
$self->{refseq} = $arrayref;
}
return unless $prev;
return $self->parent if $self->absolute;
Ace/Sequence.pm view on Meta::CPAN
else {
return $self->{offset} +1;
}
}
sub end {
my ($self,$abs) = @_;
my $start = $self->start($abs);
my $f = $self->{length} > 0 ? 1 : -1; # for stupid 1-based adjustments
if ($abs && $self->refseq ne $self->parent) {
my $r_strand = $self->r_strand;
return $start - $self->{length} + $f
if $r_strand < 0 or $self->{strand} < 0 or $self->{length} < 0;
return $start + $self->{length} - $f
}
return $start + $self->{length} - $f if $self->r_strand eq $self->{strand};
return $start - $self->{length} + $f;
}
# turn on absolute coordinates (relative to reference sequence)
sub absolute {
my $self = shift;
my $prev = $self->{absolute};
$self->{absolute} = $_[0] if defined $_[0];
return $prev;
}
Ace/Sequence.pm view on Meta::CPAN
###################### internal functions #################
# not necessarily object-oriented!!
# return parent, parent offset and strand
sub find_parent {
my $obj = shift;
# first, if we are passed an Ace::Sequence, then we can inherit
# these settings directly
return (@{$obj}{qw(parent p_offset length)},$obj->r_strand)
if $obj->isa('Ace::Sequence');
# otherwise, if we are passed an Ace::Object, then we must
# traverse upwards until we find a suitable parent
return _traverse($obj) if $obj->isa('Ace::Object');
# otherwise, we don't know what to do...
croak "Source sequence not an Ace::Object or an Ace::Sequence";
}
Ace/Sequence.pm view on Meta::CPAN
sub _get_children {
my $obj = shift;
my @pieces = $obj->get(S_Child=>2);
return @pieces if @pieces;
return @pieces = $obj->get('Subsequence');
}
# get sequence, offset and strand of topmost container
sub _traverse {
my $obj = shift;
my ($offset,$length);
# invoke seqget to find the top-level container for this sequence
my ($tl,$tl_start,$tl_end) = _get_toplevel($obj);
$tl_start ||= 0;
$tl_end ||= 0;
# make it an object
$tl = ref($obj)->new(-name=>$tl,-class=>'Sequence',-db=>$obj->db);
$offset += $tl_start - 1; # offset to beginning of toplevel
$length ||= abs($tl_end - $tl_start) + 1;
my $strand = $tl_start < $tl_end ? +1 : -1;
return ($tl,$offset,$strand < 0 ? ($length,'-1') : ($length,'+1') ) if $length;
}
sub _get_toplevel {
my $obj = shift;
my $class = $obj->class;
my $name = $obj->name;
my $smap = $obj->db->raw_query("gif smap -from $class:$name");
my ($parent,$pstart,$pstop,$tstart,$tstop,$map_type) =
$smap =~ /^SMAP\s+(\S+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(.+)/;
Ace/Sequence.pm view on Meta::CPAN
# Find all the exons predicted by various versions of "genefinder"
@exons = $seq->features('exon:genefinder.*');
# Iterate through the exons, printing their start, end and DNA
for my $exon (@exons) {
print join "\t",$exon->start,$exon->end,$exon->dna,"\n";
}
# Find the region 1000 kb upstream of the first exon
$sub = Ace::Sequence->new(-seq=>$exons[0],
-offset=>-1000,-length=>1000);
# Find all features in that area
@features = $sub->features;
# Print its DNA
print $sub->dna;
# Create a new Sequence object from the first 500 kb of chromosome 1
$seq = Ace::Sequence->new(-name=>'CHROMOSOME_I',-db=>$db,
-offset=>0,-length=>500_000);
# Get the GFF dump as a text string
$gff = $seq->gff;
# Limit dump to Predicted_genes
$gff_genes = $seq->gff(-features=>'Predicted_gene');
# Return a GFF object (using optional GFF.pm module from Sanger)
$gff_obj = $seq->GFF;
Ace/Sequence.pm view on Meta::CPAN
This class builds on top of L<Ace> and L<Ace::Object>. Please see
their manual pages before consulting this one.
=head1 Creating New Ace::Sequence Objects, the new() Method
$seq = Ace::Sequence->new($object);
$seq = Ace::Sequence->new(-source => $object,
-offset => $offset,
-length => $length,
-refseq => $reference_sequence);
$seq = Ace::Sequence->new(-name => $name,
-db => $db,
-offset => $offset,
-length => $length,
-refseq => $reference_sequence);
In order to create an I<Ace::Sequence> you will need an active I<Ace>
database accessor. Sequence regions are defined using a "source"
sequence, an offset, and a length. Optionally, you may also provide a
"reference sequence" to establish the coordinate system for all
inquiries. Sequences may be generated from existing I<Ace::Object>
sequence objects, from other I<Ace::Sequence> and
I<Ace::Sequence::Feature> objects, or from a sequence name and a
database handle.
The class method named new() is the interface to these facilities. In
its simplest, one-argument form, you provide new() with a
previously-created I<Ace::Object> that points to Sequence or
sequence-like object (the meaning of "sequence-like" is explained in
Ace/Sequence.pm view on Meta::CPAN
The sequence source. This must be an I<Ace::Object> of the "Sequence"
class, or be a sequence-like object containing the SMap tag (see
below).
=item -offset
An offset from the beginning of the source sequence. The retrieved
I<Ace::Sequence> will begin at this position. The offset can be any
positive or negative integer. Offets are B<0-based>.
=item -length
The length of the sequence to return. Either a positive or negative
integer can be specified. If a negative length is given, the returned
sequence will be complemented relative to the source sequence.
=item -refseq
The sequence to use to establish the coordinate system for the
returned sequence. Normally the source sequence is used to establish
the coordinate system, but this can be used to override that choice.
You can provide either an I<Ace::Object> or just a sequence name for
this argument. The source and reference sequences must share a common
ancestor, but do not have to be directly related. An attempt to use a
Ace/Sequence.pm view on Meta::CPAN
I<Ace::Sequence> object, and base pair 1 is its first base pair. This
behavior can be overridden by providing a reference sequence to the
new() method, in which case the orientation and position of the
reference sequence establishes the coordinate system for the object.
In addition to the reference sequence, there are two other sequences
used by I<Ace::Sequence> for internal bookeeping. The "source"
sequence corresponds to the smallest ACeDB sequence object that
completely encloses the selected sequence segment. The "parent"
sequence is the smallest ACeDB sequence object that contains the
"source". The parent is used to derive the length and orientation of
source sequences that are not directly associated with DNA objects.
In many cases, the source sequence will be identical to the sequence
initially passed to the new() method. However, there are exceptions
to this rule. One common exception occurs when the offset and/or
length cross the boundaries of the passed-in sequence. In this case,
the ACeDB database is searched for the smallest sequence that contains
both endpoints of the I<Ace::Sequence> object.
The other common exception occurs in Ace 4.8, where there is support
for "sequence-like" objects that contain the C<SMap> ("Sequence Map")
tag. The C<SMap> tag provides genomic location information for
arbitrary object -- not just those descended from the Sequence class.
This allows ACeDB to perform genome map operations on objects that are
not directly related to sequences, such as genetic loci that have been
interpolated onto the physical map. When an C<SMap>-containing object
Ace/Sequence.pm view on Meta::CPAN
$source = $seq->source_seq;
Return the source of the I<Ace::Sequence>.
=head2 parent_seq()
$parent = $seq->parent_seq;
Return the immediate ancestor of the sequence. The parent of the
top-most sequence (such as the CHROMOSOME link) is itself. This
method is used internally to ascertain the length of source sequences
which are not associated with a DNA object.
NOTE: this procedure is a trifle funky and cannot reliably be used to
traverse upwards to the top-most sequence. The reason for this is
that it will return an I<Ace::Sequence> in some cases, and an
I<Ace::Object> in others. Use get_parent() to traverse upwards
through a uniform series of I<Ace::Sequence> objects upwards.
=head2 refseq([$seq])
Ace/Sequence.pm view on Meta::CPAN
=head2 offset()
$offset = $seq->offset;
Offset of the beginning of this sequence relative to the source
sequence, using 0-based indexing. The offset may be negative if the
beginning of the sequence is to the left of the beginning of the
source sequence.
=head2 length()
$length = $seq->length;
The length of this sequence, in base pairs. The length may be
negative if the sequence's orientation is reversed relative to the
source sequence. Use abslength() to obtain the absolute value of
the sequence length.
=head2 abslength()
$length = $seq->abslength;
Return the absolute value of the length of the sequence.
=head2 strand()
$strand = $seq->strand;
Returns +1 for a sequence oriented in the natural direction of the
genomic reference sequence, or -1 otherwise.
=head2 reversed()
Returns true if the segment is reversed relative to the canonical
genomic direction. This is the same as $seq->strand < 0.
=head2 dna()
$dna = $seq->dna;
Return the DNA corresponding to this sequence. If the sequence length
is negative, the reverse complement of the appropriate segment will be
returned.
ACeDB allows Sequences to exist without an associated DNA object
(which typically happens during intermediate stages of a sequencing
project. In such a case, the returned sequence will contain the
correct number of "-" characters.
=head2 name()
Ace/Sequence/Feature.pm view on Meta::CPAN
$strand = $strand eq '-' ? '-1' : '+1';
} else {
$strand = 0;
}
# for efficiency/performance, we don't use superclass new() method, but modify directly
# 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 => {
seqname=> $sourceseq,
method => $method,
type => $type,
Ace/Sequence/Feature.pm view on Meta::CPAN
=head1 SYNOPSIS
# open database connection and get an Ace::Object sequence
use Ace::Sequence;
# get a megabase from the middle of chromosome I
$seq = Ace::Sequence->new(-name => 'CHROMOSOME_I,
-db => $db,
-offset => 3_000_000,
-length => 1_000_000);
# get all the homologies (a list of Ace::Sequence::Feature objs)
@homol = $seq->features('Similarity');
# Get information about the first one
$feature = $homol[0];
$type = $feature->type;
$subtype = $feature->subtype;
$start = $feature->start;
$end = $feature->end;
Ace/Sequence/FeatureList.pm view on Meta::CPAN
=head1 NAME
Ace::Sequence::FeatureList - Lightweight Access to Features
=head1 SYNOPSIS
# get a megabase from the middle of chromosome I
$seq = Ace::Sequence->new(-name => 'CHROMOSOME_I,
-db => $db,
-offset => 3_000_000,
-length => 1_000_000);
# find out what's there
$list = $seq->feature_list;
# Scalar context: count all the features
$feature_count = $list->types;
# Array context: list all the feature types
@feature_types = $list->types;
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
if ($segments[0]->start < $segments[-1]->start) { # positive direction
$offset = $segments[0]->{offset};
$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; }
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
my $self = shift;
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;
Ace/Sequence/GappedAlignment.pm view on Meta::CPAN
=head1 SYNOPSIS
# open database connection and get an Ace::Sequence object
use Ace::Sequence;
# get a megabase from the middle of chromosome I
$seq = Ace::Sequence->new(-name => 'CHROMOSOME_I,
-db => $db,
-offset => 3_000_000,
-length => 1_000_000);
# get all the gapped alignments
@alignments = $seq->alignments('EST_GENOME');
# get the aligned segments from the first one
@segs = $alignments[0]->segments;
# get the position of the first aligned segment on the
# source sequence:
($s_start,$s_end) = ($segs[0]->start,$segs[0]->end);
Ace/Sequence/Gene.pm view on Meta::CPAN
=head1 SYNOPSIS
# open database connection and get an Ace::Object sequence
use Ace::Sequence;
# get a megabase from the middle of chromosome I
$seq = Ace::Sequence->new(-name => 'CHROMOSOME_I,
-db => $db,
-offset => 3_000_000,
-length => 1_000_000);
# get all the genes
@genes = $seq->genes;
# get the exons from the first one
@exons = $genes[0]->exons;
# get the introns
@introns = $genes[0]->introns
Ace/Sequence/Multi.pm view on Meta::CPAN
$ref = Ace->connect(-host=>'stein.cshl.org',-port=>200009);
# open some secondary databases
$db1 = Ace->connect(-host=>'stein.cshl.org',-port=>200010);
$db2 = Ace->connect(-path=>'/usr/local/acedb/mydata');
# Make an Ace::Sequence::Multi object
$seq = Ace::Sequence::Multi->new(-name => 'CHROMOSOME_I,
-db => $ref,
-offset => 3_000_000,
-length => 1_000_000);
# add the secondary databases
$seq->add_secondary($db1,$db2);
# get all the homologies (a list of Ace::Sequence::Feature objs)
@homol = $seq->features('Similarity');
# Get information about the first one -- goes to the correct db
$feature = $homol[0];
$type = $feature->type;
Ace/Sequence/Multi.pm view on Meta::CPAN
The sequence source. This must be an I<Ace::Object> of the "Sequence"
class, or be a sequence-like object containing the SMap tag (see
below).
=item -offset
An offset from the beginning of the source sequence. The retrieved
I<Ace::Sequence> will begin at this position. The offset can be any
positive or negative integer. Offets are B<0-based>.
=item -length
The length of the sequence to return. Either a positive or negative
integer can be specified. If a negative length is given, the returned
sequence will be complemented relative to the source sequence.
=item -refseq
The sequence to use to establish the coordinate system for the
returned sequence. Normally the source sequence is used to establish
the coordinate system, but this can be used to override that choice.
You can provide either an I<Ace::Object> or just a sequence name for
this argument. The source and reference sequences must share a common
ancestor, but do not have to be directly related. An attempt to use a
Ace/Sequence/Transcript.pm view on Meta::CPAN
=head1 SYNOPSIS
# open database connection and get an Ace::Object sequence
use Ace::Sequence;
# get a megabase from the middle of chromosome I
$seq = Ace::Sequence->new(-name => 'CHROMOSOME_I,
-db => $db,
-offset => 3_000_000,
-length => 1_000_000);
# get all the transcripts
@genes = $seq->transcripts;
# get the exons from the first one
@exons = $genes[0]->exons;
# get the introns
@introns = $genes[0]->introns
Ace/SocketServer.pm view on Meta::CPAN
my ($self,$msg,$parse) = @_;
return unless my $sock = $self->{socket};
local $SIG{'PIPE'} = 'IGNORE';
$msg .= "\0"; # add terminating null
my $request;
if ($parse) {
$request = ACESERV_MSGDATA;
} else {
$request = $msg eq "encore\0" ? ACESERV_MSGENCORE : ACESERV_MSGREQ;
}
my $header = pack HEADER,WORDORDER_MAGIC,length($msg),0,$self->{client_id},0,$request;
print $sock $header,$msg;
}
sub _recv_msg {
my $self = shift;
my $strip_null = shift;
return unless my $sock = $self->{socket};
my ($header,$body);
my $bytes = CORE::read($sock,$header,HEADER_LEN);
unless ($bytes > 0) {
$self->{status} = STATUS_ERROR;
return _error("Connection closed by remote server: $!");
}
my ($magic,$length,$junk1,$clientID,$junk2,$msg) = unpack HEADER,$header;
$self->{client_id} ||= $clientID;
$msg =~ s/\0*$//;
$self->{last_msg} = $msg;
if ($length > 0) {
return _error("read of body failed: $!" )
unless CORE::read($sock,$body,$length);
$body =~ s/\0*$// if defined($strip_null) && $strip_null;
return ($msg,$body);
} else {
return $msg;
}
}
1;
__END__
#define ACEPERL_H
#define STATUS_WAITING 0
#define STATUS_PENDING 1
#define STATUS_ERROR -1
#define ACE_PARSE 3
typedef struct AceDB {
ace_handle* database;
unsigned char* answer;
int length;
int encoring;
int status;
int errcode;
} AceDB;
#endif
OUTPUT:
RETVAL
int
query(self,request, type=0)
AceDB* self
char* request
int type
PREINIT:
unsigned char* answer = NULL;
int retval,length,isWrite=0,isEncore=0;
CODE:
if (type == ACE_PARSE)
isWrite = 1;
else if (type > 0)
isEncore = 1;
retval = askServerBinary(self->database,request,
&answer,&length,&isEncore,CHUNKSIZE);
if (self->answer) {
free((void*) self->answer);
self->answer = NULL;
}
self->errcode = retval;
self->status = STATUS_WAITING;
if ((retval > 0) || (answer == NULL) ) {
self->status = STATUS_ERROR;
RETVAL = 0;
} else {
self->answer = answer;
self->length = length;
self->status = STATUS_PENDING;
self->encoring = isEncore && !isWrite;
RETVAL = 1;
}
OUTPUT:
RETVAL
SV*
read(self)
AceDB* self
PREINIT:
unsigned char* answer = NULL;
int retval,length,encore=0;
CODE:
if (self->status != STATUS_PENDING)
XSRETURN_UNDEF;
if (self->answer == NULL && self->encoring) {
retval = askServerBinary(self->database,"encore",&answer,
&length,&encore,CHUNKSIZE);
self->errcode = retval;
self->encoring = encore;
if ((retval > 0) || (answer == NULL) ) {
self->status = STATUS_ERROR;
XSRETURN_UNDEF;
}
self->answer = answer;
self->length = length;
}
if (!self->encoring)
self->status = STATUS_WAITING;
RETVAL = newSVpv((char*)self->answer,self->length);
OUTPUT:
RETVAL
CLEANUP:
if (self->answer != NULL) {
free((void*) self->answer);
self->length = 0;
self->answer = NULL;
}
acelib/aceclientlib.c view on Meta::CPAN
OUTPUT
return value:
ace_handle * pointer to structure containing open connection
and client identification information
*/
ace_handle *openServer(char *host, u_long rpc_port, int timeOut)
{
struct timeval tv;
char *answer;
int length,
clientId = 0, n,
magic1, magic3 = 0 ;
ace_reponse *reponse = 0;
ace_data question ;
ace_handle *handle;
CLIENT *clnt;
/* open rpc connection */
/* lao: */
clnt = clnt_create (host, RPC_ACE, RPC_ACE_VERS, "tcp");
acelib/aceclientlib.c view on Meta::CPAN
return 0 ;
}
if (reponse->ace_reponse_u.res_data.aceError) {
xdr_free((xdrproc_t )xdr_ace_reponse, (char *)reponse);
memset (reponse,0, sizeof(ace_reponse)) ;
clnt_destroy(clnt);
return 0;
}
answer = reponse->ace_reponse_u.res_data.reponse.reponse_val;
length = reponse->ace_reponse_u.res_data.reponse.reponse_len;
if (answer && length) {
magic3 = getMagic(magic1, answer) ;
xdr_free((xdrproc_t )xdr_ace_reponse, (char *)reponse);
memset (reponse,0, sizeof(ace_reponse)) ;
/* confirm magic by reaccessing client */
question.clientId = clientId ;
question.magic = magic3 ;
question.reponse.reponse_len = 0;
question.reponse.reponse_val = "";
question.question = "";
question.aceError = 0;
acelib/aceclientlib.c view on Meta::CPAN
JC if the server can return both an encore and an aceError at the same time
I'm in trouble. I use only one int return value for both
*/
int askServerBinary(ace_handle *handle, char *request, unsigned char **answerPtr,
int *answerLength, int *encorep, int chunkSize)
{
ace_data question ;
ace_reponse *reponse = 0 ;
unsigned char *answer, *loop ;
int aceError, length, i, encore = 0 ;
/* generate question structure */
question.clientId = handle->clientId;
question.magic = handle->magic;
question.reponse.reponse_len = 0;
question.reponse.reponse_val = "";
question.kBytes = chunkSize;
question.aceError = 0;
/* check if request contains a local command */
if (!strncasecmp(request,"encore",6))
acelib/aceclientlib.c view on Meta::CPAN
if (reponse->ace_reponse_u.res_data.reponse.reponse_len == 0) {
xdr_free((xdrproc_t )xdr_ace_reponse, (char *)reponse);
memset (reponse,0, sizeof(ace_reponse)) ;
*answerLength = 0;
*answerPtr = NULL;
return aceError;
}
*/
/* answer received. allocate memory and fill with answer */
length = reponse->ace_reponse_u.res_data.reponse.reponse_len;
loop = (unsigned char *) reponse->ace_reponse_u.res_data.reponse.reponse_val;
encore = reponse->ace_reponse_u.res_data.encore ;
if ((answer = (unsigned char *)malloc(sizeof(unsigned char)*(length+1))) == NULL)
{
/* JC Need to tell the server we have a problem ?
I guess if the server gave an encore, we need to cancel it
*/
xdr_free((xdrproc_t )xdr_ace_reponse, (char *)reponse);
return(ENOMEM);
}
for (i=0;i<length;i++)
answer[i] = loop[i];
answer[i] = 0 ; /* zero terminate */
xdr_free((xdrproc_t )xdr_ace_reponse, (char *)reponse);
*answerPtr = answer;
*answerLength = length;
*encorep = encore ;
return aceError ? aceError : - encore ; /* surcharge pour JD */
}
/***************************************************************
transfer request to server, and wait for binary answer. Convert answer
to ASCII string
INPUT
char * request string containing request
acelib/aceclientlib.c view on Meta::CPAN
answer string.
return value:
int error condition
ESUCCESS (0) no error.
EIO (5) no response received from server.
ENOMEM (12) no memory available to store answer.
or a server generated error
*/
int askServer(ace_handle *handle, char *request, char **answerPtr, int chunkSize)
{ int length, i, encore ;
int returnValue;
unsigned char *binaryAnswer;
char *answer;
char *loop;
returnValue = askServerBinary(handle, request, &binaryAnswer, &length, &encore, chunkSize) ;
if (returnValue <= 0)
{ /* allocate memory for return string */
/* if memory is more important than speed, we could run
through the string first and count the number of '\0''s
and substract this from the memoryblock we allocate */
if (!length ) /* empty string */
{ *answerPtr = 0;
return returnValue;
}
if ((answer = (char *)malloc(length+1)) == NULL)
{ free(binaryAnswer);
return(ENOMEM);
}
/* initial step of the copy process */
loop = (char *)binaryAnswer;
strcpy(answer,loop);
i = *loop ? strlen(loop): 0 ;
loop += i;
for (;(*loop == '\0')&&(i<length) ;loop++,i++);
for (;i<length;)
{ strcat(answer,loop);
i += strlen(loop);
loop += strlen(loop);
for (;(*loop == '\0')&&(i<length) ;loop++,i++);
}
*(answer+i) = '\0'; /* for safety, make sure the string is terminated */
free((char *)binaryAnswer);
*answerPtr = answer;
}
return returnValue;
}
/************** end of file **************/
acelib/arraysub.c view on Meta::CPAN
/* File: arraysub.c
* Author: Jean Thierry-Mieg (mieg@mrc-lmba.cam.ac.uk)
* Copyright (C) J Thierry-Mieg and R Durbin, 1991
*-------------------------------------------------------------------
* This file is part of the ACEDB genome database package, written by
* Richard Durbin (MRC LMB, UK) rd@mrc-lmba.cam.ac.uk, and
* Jean Thierry-Mieg (CRBM du CNRS, France) mieg@crbm.cnrs-mop.fr
*
* Description:
* Arbitrary length arrays, stacks, associators
* line breaking and all sorts of other goodies
* These functions are declared in array.h
* (part of regular.h - the header for libfree.a)
* Exported functions:
* See Header file: array.h (includes lots of macros)
* HISTORY:
* Last edited: Dec 4 11:12 1998 (fw)
* * Nov 1 16:11 1996 (srk)
* - MEM_DEBUG code clean-up
* (some loose ends crept in from WIN32)
acelib/arraysub.c view on Meta::CPAN
char *stackorigin ;
unsigned int stackused (void)
{ char x ;
if (!stackorigin) /* ideally should set in main() */
stackorigin = &x ;
return stackorigin - &x ; /* MSDOS stack grows down */
}
/************ Array : class to implement variable length arrays ************/
static int totalAllocatedMemory = 0 ;
static int totalNumberCreated = 0 ;
static int totalNumberActive = 0 ;
static Array reportArray = 0 ;
static void uArrayFinalise (void *cp) ;
#ifndef MEM_DEBUG
Array uArrayCreate (int n, int size, STORE_HANDLE handle)
{ int id = totalNumberCreated++ ;
acelib/arraysub.c view on Meta::CPAN
static Array textcopy ;
static int kLine, popLine ;
/**********/
int uLinesText (char *text, int width)
{
char *cp,*bp ;
int i ;
int nlines = 0 ;
int length = strlen (text) ;
int safe = length + 2*(length/(width > 0 ? width : 1) + 1) ; /* mieg: avoid zero divide */
static int isFirst = TRUE ;
if (isFirst)
{ isFirst = FALSE ;
lines = arrayCreate(16,char*) ;
textcopy = arrayCreate(128,char) ;
}
linesText = text ;
array(textcopy,safe,char) = 0 ; /* ensures textcopy is long enough */
acelib/bump.c view on Meta::CPAN
*py = ynew ;
return TRUE ;
}
y += 1 ; /* try next row down */
if (!doIt && bump->maxDy && y - *py > bump->maxDy)
return FALSE ;
}
}
/* abbreviate text, if vertical bump exceeds dy
return accepted length
*/
int bumpText (BUMP bump, char *text, int *px, float *py, float dy, BOOL vertical)
{
int w, n, x = *px;
float y = *py, h, old = bump->maxDy ;
if (bump->magic != &BUMP_MAGIC)
messcrash ("bumpText received corrupt bump->magic");
acelib/freeout.c view on Meta::CPAN
/* $Id: freeout.c,v 1.1 2002/11/14 20:00:06 lstein Exp $ */
#include "freeout.h"
#include <ctype.h>
typedef struct outStruct { int magic ;
FILE *fil ;
Stack s ;
int line ; /* line number */
int pos ; /* char number in line */
int byte ; /* total byte length */
int level ;
struct outStruct *next ;
} OUT ;
static int MAGIC = 245393 ;
static int outLevel = 0 ;
static Array outArray = 0 ;
static OUT *outCurr ;
static Stack outBuf = 0 ; /* buffer for messages */
#define BUFSIZE 65536
( run in 1.428 second using v1.01-cache-2.11-cpan-65fba6d93b7 )