AcePerl-1.92/0000755000175000017500000000000011106333223012330 5ustar lsteinlsteinAcePerl-1.92/t/0000755000175000017500000000000011106333223012573 5ustar lsteinlsteinAcePerl-1.92/t/update.t0000644000175000017500000000351710216610354014254 0ustar lsteinlstein#!/usr/local/bin/perl -w # Tests of object-level fetches and following ######################### We start with some black magic to print on failure. use lib '../blib/lib','../blib/arch'; use constant HOST => $ENV{ACEDB_HOST} || 'aceserver.cshl.org'; use constant PORT => $ENV{ACEDB_PORT} || 2007; BEGIN {$| = 1; print "1..17\n"; } END {print "not ok 1\n" unless $loaded;} use Ace; $loaded = 1; print "ok 1\n"; ######################### End of black magic. sub test { local($^W) = 0; my($num, $true,$msg) = @_; print($true ? "ok $num\n" : "not ok $num $msg\n"); } # Test code: my ($db,$obj); test(2,$db = Ace->connect(-host=>HOST,-port=>PORT,-timeout=>50), "couldn't establish connection"); die "Couldn't establish connection to database. Aborting tests.\n" unless $db; test(3,$me = Ace::Object->new('Author','Dent AD',$db),"couldn't create new object"); test(4,$me->add('Also_known_as','Arthur D. Dent')); test(5,$me->add('Laboratory','FF')); test(6,$me->add('Address.Mail','Heart of Gold')); test(7,$me->add('Address.Mail','Western End')); test(8,$me->add('Address.Mail','Unfashionable Outer Rim of the Milky Way')); test(9,$me->add('Address.Fax','1111111')); test(10,$me->replace('Address.Fax','1111111','2222222')); test(11,$me->add('Address.Phone','123456')); test(12,$me->delete('Address.Phone')); # Either the commit should succeed, or it should fail with a Write Access denied failure test(13,$me->commit || $me->error eq 'Write access denied',"commit failure:\n $Ace::Error"); test(14,$me->kill || $me->error eq 'Write access denied',"kill failure:\n $Ace::Error"); # Now we're going to test whether parse errors are correctly reported test(15,$me = Ace::Object->new('Author','Dent AD',$db),"couldn't create new object"); test(16,$me->add('Address.VideoPhone','123456')); test(17,!$me->commit,"failed to catch parse error"); $me->kill; AcePerl-1.92/t/object.t0000644000175000017500000001022110157647561014244 0ustar lsteinlstein#!/opt/bin/perl -w # Tests of object-level fetches and following ######################### We start with some black magic to print on failure. use lib '../blib/lib','../blib/arch'; use constant HOST => $ENV{ACEDB_HOST} || 'aceserver.cshl.org'; use constant PORT => $ENV{ACEDB_PORT} || 2007; BEGIN {$| = 1; print "1..36\n"; } END {print "not ok 1\n" unless $loaded;} use Ace; use constant TEST_CACHE=>0; $loaded = 1; print "ok 1\n"; ######################### End of black magic. sub test { local($^W) = 0; my($num, $true,$msg) = @_; print($true ? "ok $num\n" : "not ok $num $msg\n"); } # Test code: my ($db,$obj,@obj,$lab); my $DATA = q{Address Mail The Sanger Centre Hinxton Hall Hinxton Cambridge CB10 1SA U.K. E_mail jes@sanger.ac.uk Phone 1223-834244 1223-494958 Fax 1223-494919 }; my @args = (-host=>HOST,-port=>PORT,-timeout=>50); push @args,(-cache=>{} ) if TEST_CACHE || $ENV{TEST_CACHE}; Ace->debug(0); test(2,$db = Ace->connect(@args),"connection failure"); die "Couldn't establish connection to database. Aborting tests.\n" unless $db; test(3,$obj = $db->fetch('Author','Sulston JE'),"fetch failure"); print STDERR "\n ...Failed to get test object. Wrong database?\n Expect more failures... " unless $obj; test(4,defined($obj) && $obj eq 'Sulston JE',"string overload failure"); test(5,@obj = $db->fetch('Author','Sulston*'),"wildcard failure"); test(6,@obj==2,"failed to recover two authors from Sulston*"); test(7,defined($obj) && $obj->right eq 'Also_known_as',"auto fill failure"); test(8,defined($obj) && $obj->Also_known_as eq 'John Sulston',"automatic method generation failure"); test(9,defined($obj) && $obj->Also_known_as->pick eq 'John Sulston',"pick failure"); test(10,defined($obj) && (@obj = $obj->Address(2)) == 9,"col failure"); test(11,defined($obj) && ($lab = $obj->Laboratory),"fetch failure"); test(12,defined($lab) && join(' ',sort($lab->tags)) =~ /^Address CGC Staff$/,"tags failure"); test(13,defined($lab) && $lab->at('CGC.Allele_designation')->at eq 'e',"compound path failure"); test(14,defined($obj) && $obj->Address(0)->asString eq $DATA,"asString() method"); test(15,$db->ping,"can't ping"); test(16,$db->classes,"can't count classes"); test(17,defined($obj) && join(' ',sort $obj->fetch('Laboratory')->tags) =~ /^Address CGC Staff/,"fetch failure"); test(18,defined($obj) && join(' ',$obj->Address(0)->row) eq "Address Mail The Sanger Centre","row() failure"); test(19,defined($obj) && join(' ',$obj->Address(0)->row(1)) eq "Mail The Sanger Centre","row() failure"); test(20,defined($obj) && (@h=$obj->Address(2)),"tag[2] failure"); test(21,defined($obj) && (@h==9),"tag[2] failure"); test(22,$iterator1 = $db->fetch_many('Author','S*'),"fetch_many() failure (1)"); test(23,$iterator2 = $db->fetch_many('Clone','*'),"fetch_many() failure (2)"); test(24,$obj1 = $iterator1->next,"iterator failure (1)"); test(25,!$obj1->filled,"got filled object, expected unfilled"); test(26,($obj2 = $iterator1->next) && $obj1 ne $obj2,"iterator failure (2)"); test(27,($obj3 = $iterator2->next) && $obj3->class eq 'Clone',"iterator failure (3)"); test(28,($obj4 = $iterator1->next) && $obj4->class eq 'Author',"iterator failure (4)"); test(29,$iterator1 = $db->fetch_many(-class=>'Author',-name=>'S*',-filled=>1),"fetch_many(filled) failure"); test(30,($obj1 = $iterator1->next) && $obj1 && $obj1->filled,"expected filled object, got unfilled or null"); # test scalar/array contexts $obj = $db->fetch('Author','S*'); test(31,$obj=~/^\d+$/,"did not get object count in scalar context with wildcard"); $obj = $db->fetch('Author','Sulston JE'); test(32,$obj eq 'Sulston JE',"did not get object in scalar context without wildcard"); @obj = $db->fetch('Author','Su*'); test(33,@obj>1,"did not get list of objects in array context with wildcard"); @papers = $obj->follow('Paper'); test(34,@papers>1,"did not get list of papers from follow()"); test(35,@papers && $papers[0]->Title,"did not get title from first paper"); @papers_new = $db->find(-query=>qq{Author IS "Sulston JE" ; >Paper}); test(36,@papers == @papers_new,"find() did not find right number of papers") AcePerl-1.92/t/basic.t0000644000175000017500000000267707617020565014073 0ustar lsteinlstein#!/usr/local/bin/perl -w # Low level tests of connectivity ######################### We start with some black magic to print on failure. use lib '../blib/lib','../blib/arch'; use constant HOST => $ENV{ACEDB_HOST} || 'aceserver.cshl.org'; use constant PORT => $ENV{ACEDB_PORT} || 2007; BEGIN { $| = 1; print "1..10\n"; print STDERR "Waiting for remote acedb regression database to start up. This may take a few minutes.\n"; } END {print "not ok 1\n" unless $loaded;} use Ace qw/STATUS_WAITING STATUS_PENDING/; use Ace::SocketServer; $loaded = 1; print "ok 1\n"; ######################### End of black magic. sub test { local($^W) = 0; my($num, $true,$msg) = @_; print($true ? "ok $num\n" : "not ok $num $msg\n"); } # Test code: my $ptr = Ace::SocketServer->connect(HOST,PORT,50); test(2,$ptr,"connection failed"); die "Couldn't establish connection to database. Aborting tests.\n" unless $ptr; test(3,$ptr->status() == STATUS_WAITING,"did not get wait status"); test(4,$ptr->query("Find Paper"),"query() returned undef"); test(5,$ptr->status() == STATUS_PENDING,"did not get pending status"); test(6,$ptr->read,"read failed"); test(7,$ptr->status() == STATUS_WAITING,"did not get wait status"); test(8,$ptr->query("List"),"query(list) returned undef"); my $data; while ($ptr->status() == STATUS_PENDING) { $data = $ptr->read(); } test(9,length($data)>0,"didn't get data"); test(10,$ptr->status() == STATUS_WAITING,"did not get waiting status"); AcePerl-1.92/t/sequence.t0000644000175000017500000001320107657737140014613 0ustar lsteinlstein#!/usr/local/bin/perl -w # Tests of Ace::Sequence and Ace::Sequence::Feature ######################### We start with some black magic to print on failure. use lib '..','../blib/lib','../blib/arch'; use constant HOST => $ENV{ACEDB_HOST} || 'aceserver.cshl.org'; use constant PORT => $ENV{ACEDB_PORT} || 2007; BEGIN {$| = 1; print "1..54\n"; } END {print "not ok 1\n" unless $loaded;} use Ace::Sequence; $loaded = 1; print "ok 1\n"; ######################### End of black magic. sub test { local($^W) = 0; my($num, $true,$msg) = @_; print($true ? "ok $num\n" : "not ok $num $msg\n"); } test(2,$db = Ace->connect(-host=>HOST,-port=>PORT,-timeout=>50),"connection failure"); # uncomment to use with SMap test database (only valid on Lincoln's test machine) #test(2,$db = Ace->connect(-path=>'~acedb/tempdb'),"connection failure"); die "Couldn't establish connection to database. Aborting tests.\n" unless $db; # test whole clones test(3,$clone = $db->fetch(Sequence=>'ZK154'),"fetch failure"); test(4,$zk154 = Ace::Sequence->new($clone),"new() failure"); test(5,$zk154->start==1,"start() failure"); test(6,$zk154->end==26547,"end() failure"); test(7,$zk154s = Ace::Sequence->new(-seq=>$clone, -offset=>100, -Length=>100),"new() failure"); test(8,$zk154s->start==101,"start() failure (2)"); test(9,$zk154s->end==200,"end() failure (2)"); test(10,$zk154s->length == 100,"length() failure"); test(11,length($zk154s->dna)==100,"dna() failure"); test(12,$zk154r = Ace::Sequence->new(-seq=>$clone, -offset => 100, -Length => -100),"new() failure"); test(13,$zk154r->start==101,"start() failure (3)"); test(14,$zk154r->end==2,"end() failure (3)"); test(15,$zk154r->length == -100,"length() failure"); test(16,length($zk154r->dna) == 100,"dna() failure"); # print "ok 14 # Skip, persistent off-by-one errors\n"; # print "ok 15 # Skip, persistent off-by-one errors\n"; # print "ok 16 # Skip, persistent off-by-one errors\n"; @features = sort { $a->start <=> $b->start; } $zk154->features('exon'); test(17,@features,'features() error'); test(18,$features[0]->start > 0,'features()->start error'); test(19,$features[0]->end-$features[0]->start +1 == $features[0]->length,'features()->end error'); test(20,$gff = $zk154->gff,'gff() error'); if (eval q{local($^W)=0; require GFF;}) { # print STDERR "Expect a seek() on unopened file error from GFF module...\n"; test(21,$gff = $zk154->GFF,'GFF() error'); } else { print "ok 21 # Skip no GFF module installed\n"; } # Test that we can do the same thing on forward and reverse predicted genes test(22,$gene = $db->fetch(Predicted_gene=>'ZK154.1'),"fetch failure"); test(23,$zk154_1 = Ace::Sequence->new($gene),"new() failure"); test(24,$zk154_1->start > 0,"start() failure"); test(25,$zk154_1->length ==$zk154_1->end-$zk154_1->start+1,"length() failure"); @features = sort { $a->start <=> $b->start; } $zk154_1->features('exon'); test(26,$features[0]->start == 1,'features() error'); test(27,$features[0]->end == 99,'features() error'); test(28,length($features[0]->dna) == 99,'dna() error'); # ZK154.3 is a reversed gene test(29,$gene = $db->fetch(Predicted_gene=>'ZK154.3'),"fetch failure"); test(30,$zk154_3 = Ace::Sequence->new($gene),"new() failure"); test(31,$zk154_3->start > 0,"start() failure"); test(32,$zk154_3->end-$zk154_3->start+1 == $zk154_3->length,"length() failure"); @features = $zk154_3->features('exon'); @features = sort { $a->start <=> $b->start; } @features; test(33,$features[0]->start == 1,'features() error'); test(34,$features[0]->end == 57,'features() error'); test(35,length($features[0]->dna) == 57,'dna() error'); # test that relative offsets are working $zk154 = Ace::Sequence->new(-seq=>$gene,-Length=>11); $zk154_3 = Ace::Sequence->new(-seq=>$gene,-offset=>1,-Length=>10); test(36,substr($zk154->dna,1,10) eq $zk154_3->dna,'offset error'); # Test that absolute coordinates are working test(37,$zk154_3 = Ace::Sequence->new(-seq=>$gene,-refseq=>'CHROMOSOME_X'),'absolute coordinate error'); test(38,abs($zk154_3->end-$zk154_3->start) + 1 == 1596,'absolute coordinate error'); @features = sort {$b->start <=> $a->start } $zk154_3->features('exon'); test(39,@features,'absolute coordinate error'); test(40,abs($features[0]->end-$features[0]->start) + 1 == 57,'absolute coordinate error'); $features[0]->refseq('ZK154.3'); test(41,$features[0]->start == 1,'absolute coordinate error'); test(42,$features[0]->end == 57,'absolute coordinate error'); test(43,$features[0]->length == 57,'absolute coordinate error'); # Test the Ace::Sequence::Gene thing $zk154 = Ace::Sequence->new(-seq=>'ZK154',-db=>$db); @genes = $zk154->transcripts; test(44,scalar(@genes),'gene fetch error'); $forward = (grep {$_->strand > 0} @genes)[0]; $reverse = (grep {$_->strand < 0} @genes)[0]; test(45,$forward && $reverse,'failed to find forward and reverse genes'); @exons1 = $forward->exons; test(46,scalar @exons1,'failed to find exons on forward gene'); $forward->relative(1); @exons2 = $forward->exons; test(47,scalar @exons2,'failed to find relative exons on forward gene'); test(48,$exons2[0]->start == 1,"relative exons on forward gene don't start with 1"); test(49,$exons1[0]->dna eq $exons2[0]->dna,"absolute and relative exons don't match"); @exons1 = $reverse->exons; test(50,scalar @exons1,'failed to find exons on reverse gene'); $reverse->relative(1); @exons2 = $reverse->exons; test(51,scalar @exons2,'failed to find relative exons on reverse gene'); test(52,$exons2[0]->start == 1,"relative exons on reverse gene don't start with 1"); test(53,$exons1[-1]->dna eq $exons2[0]->dna,"absolute and relative exons don't match (1)"); test(54,$exons1[0]->dna eq $exons2[-1]->dna,"absolute and relative exons don't match (2)"); AcePerl-1.92/Ace/0000755000175000017500000000000011106333223013020 5ustar lsteinlsteinAcePerl-1.92/Ace/Model.pm0000644000175000017500000001376107666266556014464 0ustar lsteinlsteinpackage Ace::Model; # file: Ace/Model.pm # This is really just a placeholder class. It doesn't do anything interesting. use strict; use vars '$VERSION'; use Text::Tabs 'expand'; use overload '""' => '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, 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; } return $self; } sub name { return shift()->{name}; } # return all the tags in the model as a hashref. # in a list context returns the tags as a long list result sub tags { my $self = shift; $self->{tags} ||= { map {lc($_)=>1} grep {!/^[\#\?]/o} grep {!/$KEYWORD/o} $self->{raw}=~m/(\S+)/g, map {$_->tags} @{$self->{submodels}} }; return wantarray ? keys %{$self->{tags}} : $self->{tags}; } # return the path to a particular tag sub path { my $self = shift; my $tag = lc shift; $self->parse; return unless exists $self->{path}{$tag}; return @{$self->{path}{$tag}}; } # parse out the paths to each of the tags sub parse { my $self = shift; return if exists $self->{path}; my @lines = grep { !m[^\s*//] } $self->_untabulate; # 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 } elsif ($position == $current_position) { # here's a sibling tree push @paths,[@path]; # remember current path $path[-1] = $tag; # replace last item # otherwise, we're done with a subtree and need to restore context of parent } else { push @paths,[@path]; # remember current path @path = (); # nuke path while (@path_stack) { my $s = pop @path_stack; # pop off an earlier partial path if ($s->[0] == $position) { # found correct context to restore @path = @{$s->[1]}; # restore last; } } $path[-1] = $tag; # replace sibling } $current_position = $position; } } push @paths,[@path] if @path; # at this point, @paths contains a list of paths to each terminal tag foreach (@paths) { my $tag = pop @{$_}; $self->{path}{lc($tag)} = $_; } } sub _untabulate { my $self = shift; my @lines = split "\n",$self->{raw}; return expand(@lines); } # return true if the tag is a valid one sub valid_tag { my $self = shift; my $tag = lc shift; return $self->tags->{$tag}; } # just return the model as a string sub asString { return shift()->{'raw'}; } 1; __END__ =head1 NAME Ace::Model - Get information about AceDB models =head1 SYNOPSIS use Ace; my $db = Ace->connect(-path=>'/usr/local/acedb/elegans'); my $model = $db->model('Author'); print $model; $name = $model->name; @tags = $model->tags; print "Paper is a valid tag" if $model->valid_tag('Paper'); =head1 DESCRIPTION This class is provided for access to AceDB class models. It provides the model in human-readable form, and does some limited but useful parsing on your behalf. Ace::Model objects are obtained either by calling an Ace database handle's model() method to retrieve the model of a named class, or by calling an Ace::Object's model() method to retrieve the object's particular model. =head1 METHODS =head2 new() $model = Ace::Model->new($model_data); This is a constructor intended only for use by Ace and Ace::Object classes. It constructs a new Ace::Model object from the raw string data in models.wrm. =head2 name() $name = $model->name; This returns the class name for the model. =head2 tags() @tags = $model->tags; This returns a list of all the valid tags in the model. =head2 valid_tag() $boolean = $model->valid_tag($tag); This returns true if the given tag is part of the model. =head2 path() @path = $model->path($tag) Returns the path to the indicated tag, returning a list of intermediate tags. For example, in the C elegans ?Locus model, the path for 'Compelementation_data" will return the list ('Type','Gene'). =head2 asString() print $model->asString; asString() returns the human-readable representation of the model with comments stripped out. Internally this method is called to automatically convert the model into a string when appropriate. You need only to start performing string operations on the model object in order to convert it into a string automatically: print "Paper is unique" if $model=~/Paper ?Paper UNIQUE/; =head1 SEE ALSO L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg 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. =cut AcePerl-1.92/Ace/Object/0000755000175000017500000000000011106333223014226 5ustar lsteinlsteinAcePerl-1.92/Ace/Object/Wormbase.pm0000644000175000017500000000153710126545473016366 0ustar lsteinlsteinpackage 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; } } 1; AcePerl-1.92/Ace/Iterator.pm0000644000175000017500000001172707154470776015206 0ustar lsteinlsteinpackage Ace::Iterator; use strict; use vars '$VERSION'; use Carp; use Ace 1.50 qw(rearrange); $VERSION = '1.51'; sub new { my $pack = shift; 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}; $self->{'current'}++; unless ($result) { $self->{db}->_unregister_iterator; delete $self->{db}; } return $result; } sub invalidate { my $self = shift; return unless $self->_active; $self->save_context; $self->_active(0); } sub save_context { my $self = shift; return unless my $db = $self->{db}; return unless $self->_active; $self->{saved_ok} = $db->_save_iterator($self); } # Fill up cache for iterator sub _fill_cache { my $self = shift; return unless my $db = $self->{db}; $self->restore_context() if !$self->{active}; my @objects = $self->{filled} ? $db->_fetch($self->{'chunksize'},$self->{'current'}) : $db->_list($self->{'chunksize'},$self->{'current'}); $self->{cached_answers} = \@objects; $self->_active(1); } # prevent reentry sub _active { my $self = shift; my $val = $self->{active}; $self->{active} = shift if @_; return $val; } sub restore_context { my $self = shift; return unless my $db = $self->{db}; $db->raw_query($self->{query}) unless $self->{saved_ok} and $db->_restore_iterator($self); undef $self->{saved_ok}; # no longer there! } 1; __END__ =head1 NAME Ace::Iterator - Iterate Across an ACEDB Query =head1 SYNOPSIS use Ace; $db = Ace->connect(-host => 'beta.crbm.cnrs-mop.fr', -port => 20000100); $i = $db->fetch_many(Sequence=>'*'); # fetch a cursor while ($obj = $i->next) { print $obj->asTable; } =head1 DESCRIPTION The Ace::Iterator class implements a persistent query on an Ace database. You can create multiple simultaneous queries and retrieve objects from each one independently of the others. This is useful when a query is expected to return more objects than can easily fit into memory. The iterator is essentially a database "cursor." =head2 new() Method $iterator = Ace::Iterator->new(-db => $db, -query => $query, -filled => $filled, -chunksize => $chunksize); An Ace::Iterator is returned by the Ace accessor's object's fetch_many() method. You usually will not have cause to call the new() method directly. If you do so, the parameters are as follows: =over 4 =item -db The Ace database accessor object to use. =item -query A query, written in Ace query language, to pass to the database. This query should return a list of objects. =item -filled If true, then retrieve complete objects from the database, rather than empty object stubs. Retrieving filled objects uses more memory and network bandwidth than retrieving unfilled objects, but it's recommended if you know in advance that you will be accessing most or all of the objects' fields, for example, for the purposes of displaying the objects. =item -chunksize The iterator will fetch objects from the database in chunks controlled by this argument. The default is 40. You may want to tune the chunksize to optimize the retrieval for your application. =back =head2 next() method $object = $iterator->next; This method retrieves the next object from the query, performing whatever database accesses it needs. After the last object has been fetched, the next() will return undef. Usually you will call next() inside a loop like this: while (my $object = $iterator->next) { # do something with $object } Because of the way that object caching works, next() will be most efficient if you are only looping over one iterator at a time. Although parallel access will work correctly, it will be less efficient than serial access. If possible, avoid this type of code: my $iterator1 = $db->fetch_many(-query=>$query1); my $iterator2 = $db->fetch_many(-query=>$query2); do { my $object1 = $iterator1->next; my $object2 = $iterator2->next; } while $object1 && $object2; =head1 SEE ALSO L, L, L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg Copyright (c) 1997-1998 Cold Spring Harbor Laboratory 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 __END__ AcePerl-1.92/Ace/Browser/0000755000175000017500000000000011106333223014443 5ustar lsteinlsteinAcePerl-1.92/Ace/Browser/AceSubs.pm0000644000175000017500000007413510231520255016341 0ustar lsteinlsteinpackage Ace::Browser::AceSubs; =head1 NAME Ace::Browser::AceSubs - Subroutines for AceBrowser =head1 SYNOPSIS use Ace; use Ace::Browser::AceSubs; use CGI qw(:standard); use CGI::Cookie; my $obj = GetAceObject() || AceNotFound(); PrintTop($obj); print $obj->asHTML; PrintBottom(); =head1 DESCRIPTION Ace::Browser::AceSubs exports a set of routines that are useful for creating search pages and displays for AceBrowser CGI pages. See http://stein.cshl.org/AcePerl/AceBrowser. The following subroutines are exported by default: AceError AceMissing AceNotFound Configuration DoRedirect GetAceObject Object2URL ObjectLink OpenDatabase PrintTop PrintBottom Url The following subroutines are exported if explicitly requested: AceAddCookie AceInit AceHeader AceMultipleChoices AceRedirect DB_Name Footer Header ResolveUrl Style Toggle TypeSelector To load the default subroutines load the module with: use Ace::Browser::AceSubs; To bring in a set of optionally routines, load the module with: use Ace::Browser::AceSubs qw(AceInit AceRedirect); To bring in all the default subroutines, plus some of the optional ones: use Ace::Browser::AceSubs qw(:DEFAULT AceInit AceRedirect); There are two main types of AceBrowser scripts: =over 4 =item display scripts These are called with the CGI parameters b and b, corresponding to the name and class of an AceDB object to display. The subroutine GetAceObject() will return the requested object, or undef if the object does not exist. To retrieve the parameters, use the CGI.pm param() method: $name = param('name'); $class = param('class'); =item search scripts These are not called with any CGI parameters on their first invocation, but can define their own parameter lists by creating fill-out forms. The AceBrowser system remembers the last search performed by a search script in a cookie and regenerates the CGI parameters the next time the user selects that search script. =back =head1 SUBROUTINES The following sections describe the exported subroutines. =over 4 =cut use strict; use Ace::Browser::SiteDefs; use Ace 1.76; use CGI qw(:standard escape); use CGI::Cookie; use File::Path 'mkpath'; use vars qw/@ISA @EXPORT @EXPORT_OK $VERSION %EXPORT_TAGS %DB %OPEN $HEADER $TOP @COOKIES $APACHE_CONF/; require Exporter; @ISA = qw(Exporter); $VERSION = 1.21; ######################### This is the list of exported subroutines ####################### @EXPORT = qw( GetAceObject AceError AceNotFound AceMissing DoRedirect OpenDatabase Object2URL Url ObjectLink Configuration PrintTop PrintBottom); @EXPORT_OK = qw(AceRedirect Toggle ResolveUrl AceInit AceAddCookie AceHeader TypeSelector Style AcePicRoot Header Footer DB_Name AceMultipleChoices); %EXPORT_TAGS = ( ); use constant DEFAULT_DATABASE => 'default'; use constant PRIVACY => 'misc/privacy'; # privacy/cookie statement use constant SEARCH_BROWSE => 'search'; # a fallback search script my %VALID; # cache for get_symbolic() lookups =item AceError($message) This subroutine will print out an error message and exit the script. The text of the message is taken from $message. =cut sub AceError { my $msg = shift; PrintTop(undef,undef,'Error'); print CGI::font({-color=>'red'},$msg); PrintBottom(); Apache->exit(0) if defined &Apache::exit; exit(0); } =item AceHeader() This function prints the HTTP header and issues a number of cookies used for maintaining AceBrowser state. It is not exported by default. =cut =item AceAddCookie(@cookies) This subroutine, which must be called b OpenDatabase() and/or GetAceObject() and b PrintTop(), will add one or more cookies to the outgoing HTTP headers that are emitted by AceHeader(). Cookies must be CGI::Cookie objects. =cut sub AceAddCookie { push @COOKIES,@_; # add caller's to our globals } ################## canned header ############ sub AceHeader { my %searches = map {$_=>1} Configuration()->searches; my $quovadis = url(-relative=>1); my $db = get_symbolic(); my $referer = referer(); $referer =~ s!^http://[^/]+!! if defined $referer; my $home = Configuration()->Home->[0] if Configuration()->Home; if ($referer && $home && index($referer,$home) >= 0) { my $bookmark = cookie( -name=>"HOME_${db}", -value=>$referer, -path=>'/'); push(@COOKIES,$bookmark); } if ($searches{$quovadis}) { Delete('Go'); my $search_name = "SEARCH_${db}_${quovadis}"; my $search_data = cookie(-name => $search_name, -value => query_string(), -path=>'/', ); my $last_search = cookie(-name=>"ACEDB_$db", -value=>$quovadis, -path=>'/'); push(@COOKIES,$search_data,$last_search); } print @COOKIES ? header(-cookie=>\@COOKIES,@_) : header(@_); @COOKIES = (); $HEADER++; } =item AceInit() This subroutine initializes the AcePerl connection to the configured database. If the database cannot be opened, it generates an error message and exits. This subroutine is not exported by default, but is called by PrintTop() and Header() internally. =cut # Subroutines used by all scripts. # Will generate an HTTP 'document not found' error if you try to get an # undefined database name. Check the return code from this function and # return immediately if not true (actually, not needed because we exit). sub AceInit { $HEADER = 0; $TOP = 0; @COOKIES = (); # keeps track of what sections should be open %OPEN = param('open') ? map {$_ => 1} split(' ',param('open')) : () ; return 1 if Configuration(); # if we get here, it is a big NOT FOUND error print header(-status=>'404 Not Found',-type=>'text/html'); $HEADER++; print start_html(-title => 'Database Not Found', -style => Ace::Browser::SiteDefs->getConfig(DEFAULT_DATABASE)->Style, ), h1('Database not found'), p('The requested database',i(get_symbolic()),'is not recognized', 'by this server.'); print p('Please return to the',a({-href=>referer()},'referring page.')) if referer(); print end_html; Apache::exit(0) if defined &Apache::exit; # bug out of here! exit(0); } =item AceMissing([$class,$name]) This subroutine will print out an error message indicating that an object is present in AceDB, but that the information the user requested is absent. It will then exit the script. This is infrequently encountered when following XREFed objects. If the class and name of the object are not provided as arguments, they are taken from CGI's param() function. =cut sub AceMissing { my ($class,$name) = @_; $class ||= param('class'); $name ||= param('name'); PrintTop(undef,undef,$name); print strong('There is no further information about this object in the database.'); PrintBottom(); Apache->exit(0) if defined &Apache::exit; exit(0); } =item AceMultipleChoices($symbol,$report,$objects) This function is called when a search has recovered multiple objects and the user must make a choice among them. The user is presented with an ordered list of the objects, and asked to click on one of them. The three arguements are: $symbol The keyword or query string the user was searching on, undef if none. $report The symbolic name of the current display, or undef if none. $objects An array reference containing the Ace objects in question. This subroutine is not exported by default. =cut sub AceMultipleChoices { my ($symbol,$report,$objects) = @_; if ($objects && @$objects == 1) { my $destination = Object2URL($objects->[0]); AceHeader(-Refresh => "1; URL=$destination"); print start_html ( '-Title' => 'Redirect', '-Style' => Style(), ), h1('Redirect'), p("Automatically transforming this query into a request for corresponding object", ObjectLink($objects->[0],$objects->[0]->class.':'.$objects->[0])), p("Please wait..."), Footer(), end_html(); return; } PrintTop(undef,undef,'Multiple Choices'); print p("Multiple $report objects correspond to $symbol.", "Please choose one:"), ol( li([ map {ObjectLink($_,font({-color=>'red'},$_->class).': '.$_)} @$objects ]) ); PrintBottom(); } =item AceNotFound([$class,$name]) This subroutine will print out an error message indicating that the requested object is not present in AceDB, even as a name. It will then exit the script. If the class and name of the object are not provided as arguments, they are taken from CGI's param() function. =cut sub AceNotFound { my $class = shift || param('class'); my $name = shift || param('name'); PrintTop(undef,undef,"$class: $name not found"); print p(font({-color => 'red'}, strong("The $class named \"$name\" is not found in the database."))); PrintBottom(); Apache->exit(0) if defined &Apache::exit; exit(0); } =item ($uri,$physical_path) = AcePicRoot($directory) This function returns the physical and URL paths of a temporary directory in which the pic script can write pictures. Not exported by default. Returns a two-element list containing the URL and physical path. =cut sub AcePicRoot { my $path = shift; my $umask = umask(); umask 002; # want this writable by group my ($picroot,$uri); if ($ENV{MOD_PERL} && Apache->can('request')) { # we have apache, so no reason not to take advantage of it my $r = Apache->request; $uri = join('/',Configuration()->Pictures->[0],"/",$path); my $subr = $r->lookup_uri($uri); $picroot = $subr->filename if $subr; } else { ($uri,$picroot) = @{Configuration()->Pictures} if Configuration()->Pictures; $uri .= "/$path"; $picroot .= "/$path"; } mkpath ($picroot,0,0777) || AceError("Can't create directory to store image in") unless -d $picroot; umask $umask; return ($uri,$picroot); } =item AceRedirect($report,$object) This function redirects the user to a named display script for viewing an Ace object. It is used, for example, to convert a request for a sequence into a request for a protein: $obj = GetAceObject(); if ($obj->CDS) { my $protein = $obj->Corresponding_protein; AceRedirect('protein',$protein); } AceRedirect must be called b PrintTop() or AceHeader(). It invokes exit(), so it will not return. This subroutine is not exported by default. It differs from DoRedirect() in that it displays a message to the user for two seconds before it generates the new page. It also allows the display to be set explicitly, rather than determined automatically by the AceBrowser system. =cut ############### redirect to a different report ##################### sub AceRedirect { my ($report,$object) = @_; my $url = Configuration()->display($report,'url'); my $args = ref($object) ? "name=$object&class=".$object->class : "name=$object"; my $destination = ResolveUrl($url => $args); AceHeader(-Refresh => "1; URL=$destination"); print start_html ( '-Title' => 'Redirect', '-Style' => Style(), '-head' => meta({-http_equiv=>'Refresh',-content=>"1; URL=$destination"}) ), h1('Redirect'), p("This request is being redirected to the \U$report\E display"), p("This page will automatically display the requested object in", "one seconds",a({-href=>$destination},'Click on this link'), 'to load the page immediately.'), end_html(); Apache->exit(0) if defined &Apache::exit; exit(0); } =item $configuration = Configuration() The Configuration() function returns the Ace::Browser::SiteDefs object for the current session. From this object you can retrieve information from the configuration file. =cut # get the configuration object for this database sub Configuration { my $s = get_symbolic()||return; return Ace::Browser::SiteDefs->getConfig($s); } =item $name = DB_Name() This function returns the symbolic name of the current database, for example "default". =cut *DB_Name = \&get_symbolic; =item DoRedirect($object) This subroutine immediately redirects to the default display for the Ace::Object indicated by $object and exits the script. It must be called before PrintTop() or any other HTML-generating code. It differs from AceRedirect() in that it generates a fast redirect without alerting the user. This function is not exported by default. =cut # redirect to the URL responsible for an object sub DoRedirect { my $obj = shift; print redirect(Object2URL($obj)); Apache->exit(0) if defined &Apache::exit; exit(0); } =item $footer = Footer() This function returns the contents of the footer as a string, but does not print it out. It is not exported by default. =cut # Contents of the HTML footer. It gets printed immediately before the tag. # The one given here generates a link to the "feedback" page, as well as to the # privacy statement. You may or may not want these features. sub Footer { if (my $footer = Configuration()->Footer) { return $footer; } my $webmaster = $ENV{SERVER_ADMIN} || 'webmaster@sanger.ac.uk'; my $obj_name = escape(param('name')); my $obj_class = escape(param('class')) || ucfirst url(-relative=>1); my $referer = escape(self_url()); my $name = get_symbolic(); # set up the feedback link my $feedback_link = Configuration()->Feedback_recipients && $obj_name && (url(-relative=>1) ne 'feedback') ? a({-href=>ResolveUrl("misc/feedback/$name","name=$obj_name;class=$obj_class;referer=$referer")}, "Click here to send data or comments to the maintainers") : ''; # set up the privacy statement link my $privacy_link = ( Configuration()->Print_privacy_statement && url(-relative=>1) ne PRIVACY()) ? a({ -href=>ResolveUrl(PRIVACY."/$name") },'Privacy Statement') : ''; my ($home,$label) = @{Configuration()->Home}; my $hlink = $home ? a({-href=>$home},$label) : ''; # Either generate a pointer to ACeDB home page, or the copyright statement. my $clink = Configuration()->Copyright ? a({-href=>Configuration()->Copyright,-target=>"_new"},'Copyright Statement') : qq(AcePerl Home Page); return < $hlink
$clink

$feedback_link
$privacy_link

$webmaster

END } =item $object = GetAceObject() This function is called by display scripts to return the Ace::Object.that the user wishes to view. It automatically opens or refreshes the database, and performs the request using the values of the "name" and "class" CGI variables. If a single object is found, the function returns it as the function result. If no objects are found, it returns undef. If more than one object is found, the function invokes AceMultipleChoices() and exits the script. =cut # open database, return object requested by CGI parameters sub GetAceObject { my $db = OpenDatabase() || AceError("Couldn't open database."); # exits my $name = param('name') or return; my $class = param('class') or return; my @objs = $db->fetch($class => $name); if (@objs > 1) { AceMultipleChoices($name,'',\@objs); Apache->exit(0) if defined &Apache::exit; exit(0); } return $objs[0]; } =item $html = Header() This subroutine returns the boilerplate at the top of the HTML page as a string, but does not print it out. It is not exported by default. =cut sub Header { my $config = Configuration(); my $dbname = get_symbolic(); return unless my $searches = $config->Searches; my $banner = $config->Banner; # next select the correct search script my @searches = @{$searches}; my $self = url(-relative=>1); my $modperl = $ENV{MOD_PERL} && Apache->can('request') && eval {Apache->request->dir_config('AceBrowserConf')}; my @row; foreach (@searches) { my ($name,$url,$on,$off,$size) = @{$config->searches($_)}{qw/name url onimage offimage size/}; my $active = $url =~ /\b$self\b/; my $image = $active ? $on : $off; # replace the url with a cookie, if one is defined my $cookie_name = "SEARCH_${dbname}_${_}"; my $query_string = cookie($cookie_name) unless /blast/; $url .= "/$dbname" unless $url =~ /\b$dbname\b/ or $modperl; $url .= "?$query_string" if $query_string; if ($image) { push @row,a({-href=>$url},img({-src=>$image,-border=>0, -width=>$size->[0],-height=>$size->[1], -alt=>$name})); } else { push @row,$active ? font({-color=>'black'},$name) : a({-href=>$url,-class=>'searchbanner'},$name); } } my ($home,$label) = @{$config->Home} if $config->Home; return table({-border=>0,-cellspacing=>1,-width=>'100%'}, Tr(td({-align=>'CENTER',-class=>'searchbanner'},\@row)), Tr(td({-align=>'CENTER',-valign=>'BOTTOM',colspan=>scalar(@row)}, a({-href=>$home},$banner)) ) ); } =item $url = Object2URL($object) =item $url = Object2URL($name,$class) In its single-argument form, this function takes an AceDB Object and returns an AceBrowser URL. The URL chosen is determined by the configuration settings. It is also possible to pass Object2URL an object name and class, in the case that an AceDB object isn't available. The return value is a URL. =cut # general mapping from a display to a url sub Object2URL { my ($object,$extra) = @_; my ($name,$class); if (ref($object)) { ($name,$class) = ($object,$object->class); } else { ($name,$class) = ($object,$extra); } my $display = url(-relative=>1); my ($disp,$parameters) = Configuration()->map_url($display,$name,$class); return $disp unless $parameters; return Url($disp,$parameters); } =item $link = ObjectLink($object [,$link_text]) This function converts an AceDB object into a hypertext link. The first argument is an Ace::Object. The second, optional argument is the text to use for the link. If not provided, the object's name becomes the link text. This function is used extensively to create cross references between Ace::Objects on AceBrowser pages. Example: my $author = $db->fetch(Author => 'Sulston JE'); print ObjectLink($author,$author->Full_name); This will print out a link to a page that will display details on the author page. The text of the link will be the value of the Full_name tag. =cut sub ObjectLink { my $object = shift; my $link_text = shift; my $target = shift; my $url = Object2URL($object,@_) or return ($link_text || "$object"); my @targ = $target ? (-target=>$target) : (); return a({-href=>Object2URL($object,@_),-name=>"$object",@targ},($link_text || "$object")); } =item $db = OpenDatabase() This function opens the Acedb database designated by the configuration file. In modperl environments, this function caches database handles and reuses them, pinging and reopening them in the case of timeouts. This function is not exported by default. =cut use Carp 'cluck'; ################ open a database ################# sub OpenDatabase { my $name = shift || get_symbolic(); AceInit(); $name =~ s!/$!!; my $db = $DB{$name}; return $db if $db && $db->ping; my ($host,$port,$user,$password, $cache_root,$cache_size,$cache_expires,$auto_purge_interval) = getDatabasePorts($name); my @auth = (-user=>$user,-pass=>$password) if $user && $password; my @cache = (-cache => { cache_root=>$cache_root, max_size => $cache_size || $Cache::SizeAwareCache::NO_MAX_SIZE || -1, # hardcoded $NO_MAX_SIZE constant default_expires_in => $cache_expires || '1 day', auto_purge_interval => $auto_purge_interval || '6 hours', } ) if $cache_root; $DB{$name} = Ace->connect(-host=>$host,-port=>$port,-timeout=>50,@auth,@cache); return $DB{$name}; } =item PrintTop($object,$class,$title,@html_headers) The PrintTop() function generates all the boilerplate at the top of a typical AceBrowser page, including the HTTP header information, the page title, the navigation bar for searches, the web site banner, the type selector for choosing alternative displays, and a level-one header. Call it with one or more arguments. The arguments are: $object An AceDB object. The navigation bar and title will be customized for the object. $class If no AceDB object is available, then you can pass a string containing the AceDB class that this page is designed to display. $title A title to use for the HTML page and the first level-one header. If not provided, a generic title "Report for Object" is generated. @html_headers Additional HTML headers to pass to the the CGI.pm start_html. =cut # boilerplate for the top of the page sub PrintTop { my ($object,$class,$title,@additional_header_stuff) = @_; return if $TOP++; $class = $object->class if defined $object && ref($object); $class ||= param('class') unless defined($title); AceHeader(); $title ||= defined($object) ? "$class Report for: $object" : $class ? "$class Report" : '' unless defined($title); print start_html ( '-Title' => $title, '-Style' => Style(), @additional_header_stuff, ); print Header(); print TypeSelector($object,$class) if defined $object; print h1($title) if $title; } =item PrintBottom() The PrintBottom() function outputs all the boilerplate at the bottom of a typical AceBrowser page. If a user-defined footer is present in the configuration file, that is printed. Otherwise, the method prints a horizontal rule followed by links to the site home page, the AcePerl home page, the privacy policy, and the feedback page. =cut sub PrintBottom { print hr,Footer(),end_html(); } =item $hashref = Style() This subroutine returns a hashref containing a reference to the configured stylesheet, in the following format: { -src => '/ace/stylesheets/current_stylesheet.css' } This hash is suitable for passing to the -style argument of CGI.pm's start_html() function, or for use as an additional header in PrintTop(). You may add locally-defined stylesheet elements to the hash before calling start_html(). See the pic script for an example of how this is done this. This function is not exported by default. =cut =item $url = ResolveUrl($url,$param) Given a URL and a set of parameters, this function does the necessary magic to add the symbolic database name to the end of the URL (if needed) and then tack the parameters onto the end. A typical call is: $url = ResolveUrl('/cgi-bin/ace/generic/tree','name=fred;class=Author'); This function is not exported by default. =cut sub ResolveUrl { my ($url,$param) = @_; my ($main,$query,$frag) = $url =~ /^([^?\#]+)\??([^\#]*)\#?(.*)$/ if defined $url; $main ||= ''; if (!defined $APACHE_CONF) { $APACHE_CONF = eval { Apache->request->dir_config('AceBrowserConf') } ? 1 : 0; } $main = Configuration()->resolvePath($main) unless $main =~ m!^/!; if (my $id = get_symbolic()) { $main .= "/$id" unless $main =~ /$id/ or $APACHE_CONF; } $main .= "?$query" if $query; # put the query string back $main .= "?$param" if $param and !$query; $main .= ";$param" if $param and $query; $main .= "#$frag" if $frag; return $main; } # A consistent stylesheet across pages sub Style { my $stylesheet = Configuration()->Stylesheet; return { -src => $stylesheet }; } =item $boolean = Toggle($section,[$label,$object_count,$add_plural,$add_count]) =item ($link,$bool) = Toggle($section,$label,$object_count,$add_plural,$add_count) The Toggle() subroutine makes it easy to create HTML sections that open and close when the user selects a toggle icon (a yellow triangle). Toggle() can be used to manage multiple collapsible HTML sections, but each section must have a unique name. The required first argument is the section name. Optional arguments are: $label The text of the generated link, for example "sequence" $object_count The number of objects that opening the section will reveal $add_plural If true, the label will be pluralized when appropriate $add_count If true, the label will have the object count added when appropriate In a scalar context, Toggle() prints the link HTML and returns a boolean flag. A true result indicates that the section is expanded and should be generated. A false result indicates that the section is collapsed. In a list context, Toggle() returns a two-element list. The first element is the HTML link that expands and contracts the section. The second element is a boolean that indicates whether the section is currently open or closed. This example indicates typical usage: my $sequence = GetAceObject(); print "sequence name = ",$sequence,"\n"; print "sequence clone = ",$sequence->Clone,"\n"; if (Toggle('dna','Sequence DNA')) { print $sequence->asDNA; } An alternative way to do the same thing: my $sequence = GetAceObject(); print "sequence name = ",$sequence,"\n"; print "sequence clone = ",$sequence->Clone,"\n"; my ($link,$open) = Toggle('dna','Sequence DNA'); print $link; print $sequence->asDNA if $open; =cut # Toggle a subsection open and close sub Toggle { my ($section,$label,$count,$addplural,$addcount,$max_open) = @_; $OPEN{$section}++ if defined($max_open) && $count <= $max_open; my %open = %OPEN; $label ||= $section; my $img; if (exists $open{$section}) { delete $open{$section}; $img = img({-src=>'/ico/triangle_down.gif',-alt=>'^', -height=>6,-width=>11,-border=>0}), } else { $open{$section}++; $img = img({-src=>'/ico/triangle_right.gif',-alt=>'>', -height=>11,-width=>6,-border=>0}), my $plural = ($addplural and $label !~ /s$/) ? "${label}s" : "$label"; $label = font({-class=>'toggle'},!$addcount ? $plural : "$count $plural"); } param(-name=>'open',-value=>join(' ',keys %open)); my $url = url(-absolute=>1,-path_info=>1,-query=>1); my $link = a({-href=>"$url#$section",-name=>$section},$img.' '.$label); if (wantarray ){ return ($link,$OPEN{$section}) } else { print $link,br; return $OPEN{$section}; } } =item $html = TypeSelector($name,$class) This subroutine generates the HTML for the type selector navigation bar. The links in the bar are dynamically generated based on the values of $name and $class. This function is called by PrintTop(). It is not exported by default. =cut # Choose a set of displayers based on the type. sub TypeSelector { my ($name,$class) = @_; return unless $class; my ($n,$c) = (escape("$name"),escape($class)); my @rows; # add the special displays my @displays = Configuration()->class2displays($class,$name); my @basic_displays = Configuration()->class2displays('default'); @basic_displays = Ace::Browser::SiteDefs->getConfig(DEFAULT_DATABASE)->class2displays('default') unless @basic_displays; my $display = url(-absolute=>1,-path=>1); foreach (@displays,@basic_displays) { my ($url,$icon,$label) = @{$_}{qw/url icon label/}; next unless $url; my $u = ResolveUrl($url,"name=$n;class=$c"); ($url = $u) =~ s/[?\#].*$//; my $active = $url =~ /^$display/; my $cell; unless ($active) { $cell = defined $icon ? a({-href=>$u,-target=>'_top'}, img({-src=>$icon,-border=>0}).br().$label) : a({-href=>$u,-target=>'_top'},$label); } else { $cell = defined $icon ? img({-src=>$icon,-border=>0}).br().font({-color=>'red'},$label) : font({-color=>'red'},$label); } push (@rows,td({-align=>'CENTER',-class=>'small'},$cell)); } return table({-width=>'100%',-border=>0,-class=>'searchtitle'}, TR({-valign=>'bottom'},@rows)); } =item $url = Url($display,$params) Given a symbolic display name, such as "tree" and a set of parameters, this function looks up its URL and then calls ResolveUrl() to create a single Url. When hard-coding relative URLs into AceBrowser scripts, it is important to pass them through Url(). The reason for this is that AceBrowser may need to attach the database name to the URL in order to identify it. Example: my $url = Url('../sequence_dump',"name=$name;long_dump=yes"); print a({-href=>$url},'Dump this sequence'); =cut sub Url { my ($display,$parameters) = @_; my $url = Configuration()->display($display,'url'); return ResolveUrl($url,$parameters); } sub Open_table{ print '
'; } sub Close_table{ print '
'; } # return host and port for symbolic database name sub getDatabasePorts { my $name = shift; my $config = Ace::Browser::SiteDefs->getConfig($name); return ($config->Host,$config->Port, $config->Username,$config->Password, $config->Cacheroot,$config->Cachesize,$config->Cacheexpires,$config->Cachepurge, ) if $config; # If we get here, then try getservbynam() # I think this is a bit of legacy code. my @s = getservbyname($name,'tcp'); return unless @s; return unless $s[2]>1024; # don't allow connections to reserved ports return ('localhost',$s[2]); } sub get_symbolic { if (exists $ENV{MOD_PERL} && Apache->can('request')) { # the easy way if (my $r = Apache->request) { if (my $conf = $r->dir_config('AceBrowserConf')) { my ($name) = $conf =~ m!([^/]+)\.(?:pm|conf)$!; return $name if $name; } } } # otherwise, the hard way (my $name = path_info())=~s!^/!!; return $name if defined $name && $name ne ''; # get from additional path info my $path = url(-absolute=>1); return $VALID{$path} if exists $VALID{$path}; my @path = split '/',$path; pop @path; for my $name ((reverse @path),'default') { next unless $name; return $VALID{$path} if exists $VALID{$name}; return $VALID{$path} = $name if Ace::Browser::SiteDefs->getConfig($name); $VALID{$path} = undef; } return; } 1; __END__ =back =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, the README.ACEBROWSER file. =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Browser/GeneSubs.pm0000644000175000017500000000173610126545473016540 0ustar lsteinlstein# -*- Mode: perl -*- # file: GeneSubs.pm # Some URL constants useful for molecular biology package Ace::Browser::GeneSubs; use strict 'vars'; use vars qw/@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS/; require Exporter; @ISA = Exporter; @EXPORT = qw(ENTREZ ENTREZP PROTEOME SWISSPROT PUBMED NCBI); @EXPORT_OK = (); %EXPORT_TAGS = (); # Foreign URLs use constant ENTREZ => 'http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Search&db=Nucleotide&doptcmdl=GenBank&term='; use constant ENTREZP => 'http://www.ncbi.nlm.nih.gov:80/entrez/query.fcgi?cmd=Search&db=Protein&doptcmdl=GenPep&term='; use constant NCBI => 'http://www.ncbi.nlm.nih.gov/htbin-post/Entrez/query'; use constant PROTEOME => 'http://www.proteome.com/WormPD/'; use constant SWISSPROT => 'http://www.ncbi.nlm.nih.gov/htbin-post/Entrez/query?db=p&form=1&field=Sequence+ID&term='; use constant PUBMED => 'http://www.ncbi.nlm.nih.gov/htbin-post/Entrez/query?db=m&form=4&term=nematode [ORGANISM]+AND+'; 1; AcePerl-1.92/Ace/Browser/SearchSubs.pm0000644000175000017500000001751310522136070017054 0ustar lsteinlsteinpackage Ace::Browser::SearchSubs; =head1 NAME Ace::Browser::SearchSubs - Subroutines for AceBrowser search scripts =head1 SYNOPSIS use Ace; use Ace::Browser::AceSubs; use Ace::Browser::SearchSubs; use CGI qw(:standard); my $form = p(start_form, textfield(-name=>'query'), end_form); AceSearchTable('Search for stuff',$form); ... my $query = param('query'); my $offset = AceSearchOffset; my ($objects,$count) = do_search($query,$offset); AceResultsTable($objects,$count,$offset,'Here are results'); =head1 DESCRIPTION Ace::Browser::SearchSubs exports a set of constants and subroutines that are useful for creating AceBrowser search scripts. =head2 CONSTANTS This package exports the following constants: MAXOBJECTS The maximum number of objects that can be displayed per page. SEARCH_ICON An icon to use for search links. This is deprecated. Use Configuration->Search_icon instead. =head2 FUNCTIONS These functions are exported: =over 4 =cut # Common constants and subroutines used by the various search scripts use strict; use vars qw(@ISA @EXPORT $VERSION); use Ace::Browser::AceSubs qw(Configuration Url ResolveUrl); use CGI qw(:standard *table *Tr *td); require Exporter; @ISA = qw(Exporter); $VERSION = '1.30'; ######################### This is the list of exported subroutines ####################### @EXPORT = qw( MAXOBJECTS SEARCH_ICON AceSearchTable AceResultsTable AceSearchOffset DisplayInstructions ); # ----- constants used by the pattern search script ------ use constant ROWS => 10; # how many rows to allocate for search results use constant COLS => 5; # " " columns " " " " use constant MAXOBJECTS => ROWS * COLS; # total objects per screen use constant ICONS => '/ico'; use constant SEARCH_ICON => '/ico/search.gif'; use constant SPACER_ICON => 'spacer.gif'; use constant LEFT_ICON => 'cylarrw.gif'; use constant RIGHT_ICON => 'cyrarrw.gif'; =item $offset = AceSearchOffset() When the user is paging back and forth among a multi-page list of results, this function returns the index of the first item to display. =cut sub AceSearchOffset { my $offset = param('offset') || 0; $offset += param('scroll') if param('scroll'); $offset; } =item AceSearchTable([{hash}],$title,@contents) Given a title and the HTML contents, this formats the search into a table and gives it the background and foreground colors used elsewhere for searches. The formatted search is then printed. The HTML contents are usually a fill-out form. For convenience, you can provide the contents in multiple parts (lines or elements) and they will be concatenated together. If the first argument is a hashref, then its contents will be passed to start_form() to override the form arguments. =cut sub AceSearchTable { my %attributes = %{shift()} if ref($_[0]) eq 'HASH'; my ($title,@body) = @_; print start_form(-action=>url(-absolute=>1,-path_info=>1).'#results',%attributes), a({-name=>'search'},''), table({-border=>0,-width=>'100%'}, TR({-valign=>'MIDDLE'}, td({-class=>'searchbody'},@body))), end_form; } =item AceResultsTable($objects,$count,$offset,$title) This subroutine formats the results of a search into a pageable list and prints out the resulting HTML. The following arguments are required: $objects An array reference containing the objects to place in the table. $count The total number of objects. $offset The offset into the array, as returned by AceSearchOffset() $title A title for the table. The array reference should contain no more than MAXOBJECTS objects. The AceDB query should be arranged in such a way that this is the case. A typical idiom is the following: my $offset = AceSearchOffset(); my $query = param('query'); my $count; my @objs = $db->fetch(-query=> $query, -count => MAXOBJECTS, -offset => $offset, -total => \$count ); AceResultsTable(\@objs,$count,$offset,'Here are the results'); =cut sub AceResultsTable { my ($objects,$count,$offset,$title) = @_; Delete('scroll'); param(-name=>'offset',-value=>$offset); my @cheaders = map { $offset + ROWS * $_ } (0..(@$objects-1)/ROWS) if @$objects; my @rheaders = (1..min(ROWS,$count)); $title ||= 'Search Results'; print a({-name=>'results'},''), start_table({-border=>0,-cellspacing=>2,-cellpadding=>2,-width=>'100%',-align=>'CENTER',-class=>'resultsbody'}), TR(th({-class=>'resultstitle'},$title)); unless (@$objects) { print end_table,p(); return; } print start_Tr,start_td; my $need_navbar = $offset > 0 || $count >= MAXOBJECTS; my @buttons = make_navigation_bar($offset,$count) if $need_navbar; print table({-width=>'50%',-align=>'CENTER'},Tr(@buttons)) if $need_navbar; print table({-width=>'100%'},tableize(ROWS,COLS,\@rheaders,\@cheaders,@$objects)); print end_td,end_Tr,end_table,p(); } # ------ ugly internal routines for scrolling along the search results list ----- sub make_navigation_bar { my($offset,$count) = @_; my (@buttons); my ($page,$pages) = (1+int($offset/MAXOBJECTS),1+int($count/MAXOBJECTS)); my $c = Configuration(); my $icons = $c->Icons || '/ico'; my $spacer = "$icons/". SPACER_ICON; my $left = "$icons/". LEFT_ICON; my $right = "$icons/". RIGHT_ICON; my $url = url(-absolute=>1,-query=>1); # my $url = self_url(); push(@buttons,td({-align=>'RIGHT',-valign=>'MIDDLE'}, $offset > 0 ? a({-href=>$url . '&scroll=-' . MAXOBJECTS}, img({-src=>$left,-alt=>'< PREVIOUS',-border=>0})) : img({-src=>$spacer,-alt=>''}) ) ); my $p = 1; while ($pages/$p > 25) { $p++; } my (@v,%v); for (my $i=1;$i<=$pages;$i++) { next unless ($i == $page) or (($i-1) % $p == 0); my $s = ($i - $page) * MAXOBJECTS; push(@v,$s); $v{$s}=$i; } my @hidden; Delete('scroll'); Delete('Go'); foreach (param()) { push(@hidden,hidden(-name=>$_,-value=>[param($_)])); } push(@buttons, td({-valign=>'MIDDLE',-align=>'CENTER'}, start_form({-name=>'form1'}), submit(-name=>'Go',-label=>'Go to'), 'page', popup_menu(-name=>'scroll',-Values=>\@v,-labels=>\%v, -default=>($page-1)*MAXOBJECTS-$offset, -override=>1, -onChange=>'document.form1.submit()'), "of $pages", @hidden, end_form() ) ); push(@buttons,td({-align=>'LEFT',-valign=>'MIDDLE'}, $offset + MAXOBJECTS <= $count ? a({-href=>$url . '&scroll=+' . MAXOBJECTS}, img({-src=>$right,-alt=>'NEXT >',-border=>0})) : img({-src=>$spacer,-alt=>''}) ) ); @buttons; } sub min { return $_[0] < $_[1] ? $_[0] : $_[1] } #line 295 sub tableize { my($rows,$columns,$rheaders,$cheaders,@elements) = @_; my($result); my($row,$column); $result .= TR($rheaders ? th(' ') : (),th({-align=>'LEFT'},$cheaders)) if $cheaders and @$cheaders > 1; for ($row=0;$row<$rows;$row++) { next unless defined($elements[$row]); $result .= ""; $result .= qq($rheaders->[$row]) if $rheaders; for ($column=0;$column<$columns;$column++) { $result .= qq() . $elements[$column*$rows + $row] . "" if defined($elements[$column*$rows + $row]); } $result .= ""; } return $result; } 1; __END__ =back =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, the README.ACEBROWSER file. =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Browser/TreeSubs.pm0000644000175000017500000000241207237070315016546 0ustar lsteinlsteinpackage Ace::Browser::TreeSubs; # constants used by the tree program (and its ilk) use strict; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); use Ace::Browser::AceSubs qw(Configuration); use CGI 'escape'; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(OPENCOLOR CLOSEDCOLOR MAXEXPAND AceImageHackURL); @EXPORT_OK = (); %EXPORT_TAGS = (); # colors use constant OPENCOLOR => '#FF0000'; # color when a tree is expanded use constant CLOSEDCOLOR => '#909090'; # color when a tree is collapsed # auto-expand subtrees when the number of subobjects is # 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; AcePerl-1.92/Ace/Browser/SiteDefs.pm0000644000175000017500000001660210522136070016516 0ustar lsteinlsteinpackage Ace::Browser::SiteDefs; =head1 NAME Ace::Browser::SiteDefs - Access to AceBrowser configuration files =head1 SYNOPSIS use Ace; use Ace::Browser::AceSubs; use CGI qw(:standard); my $configuration = Configuration; my $docroot = $configuration->Docroot; my @pictures = @{$configuration->Pictures}; my %displays = %{$configuration->Displays}; my $coderef = $configuration->Url_mapper; $coderef->($param1,$param2); =head1 DESCRIPTION Ace::Browser::SiteDefs evaluates an AceBrowser configuration file and returns a configuration object ("config object" for short). A config object is a bag of dynamically-generated methods, derived from the scalar variables, arrays, hashes and subroutines in the configuration file. The config object methods are a canonicalized form of the configuration file variables, in which the first character of the method is uppercase, and subsequent characters are lower case. For example, if the configuration variable was $ROOT, the method will be $config_object->Root. =head2 Working with Configuration Objects To fetch a configuration object, use the Ace::Browser::AceSubs Configuration() function. This will return a configuration object for the current database: $config_object = Configuration(); Thereafter, it's just a matter of making the proper method calls. If the Configuration file is a.... The method call returns a... ---------------------------------- ---------------------------- Scalar variable Scalar Array variable Array reference Hash variable Hash reference Subroutine Code reference If a variable is not defined, the corresponding method will return undef. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, the README.ACEBROWSER file. =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 use CGI(); use Ace(); use strict; use Carp; use vars qw($AUTOLOAD); # get location of configuration file use Ace::Browser::LocalSiteDefs '$SITE_DEFS'; my %CONFIG; my %CACHETIME; my %CACHED; sub getConfig { my $package = shift; my $name = shift; croak "Usage: getConfig(\$database_name)" unless defined $name; $package = ref $package if ref $package; my $file = "${name}.pm"; # make search relative to SiteDefs.pm file my $path = $package->get_config || $package->resolveConf($file); return unless -r $path; return $CONFIG{$name} if exists $CONFIG{$name} and $CACHETIME{$name} >= (stat($path))[9]; return unless $CONFIG{$name} = $package->_load($path); $CONFIG{$name}->{'name'} ||= $name; # remember name $CACHETIME{$name} = (stat($path))[9]; return $CONFIG{$name}; } sub modtime { my $package = shift; my $name = shift; if (!$name && ref($package)) { $name = $package->Name; } return $CACHETIME{$name}; } sub AUTOLOAD { my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; my $self = shift; croak "Unknown field \"$func_name\"" unless $func_name =~ /^[A-Z]/; return $self->{$func_name} = $_[0] if defined $_[0]; return $self->{$func_name} if defined $self->{$func_name}; # didn't find it, so get default return if (my $dflt = $pack->getConfig('default')) == $self; return $dflt->{$func_name}; } sub DESTROY { } sub map_url { my $self = shift; my ($display,$name,$class) = @_; $class ||= $name->class if ref($name) and $name->can('class'); my (@result,$url); if (my $code = $self->Url_mapper) { if (@result = $code->($display,$name,$class)) { return @result; } } # if we get here, then take the first display my @displays = $self->displays($class,$name); push @displays,$self->displays('default') unless @displays; my $n = CGI::escape($name); my $c = CGI::escape($class); return ($displays[0],"name=$n;class=$c") if $displays[0]; return unless @result = $self->getConfig('default')->Url_mapper->($display,$name,$class); return unless $url = $self->display($result[0],'url'); return ($url,$result[1]); } sub searches { my $self = shift; return unless my $s = $self->Searches; return @{$s} unless defined $_[0]; return $self->Search_titles->{$_[0]}; } # displays() => list of display names # displays($name) => hash reference for display # displays($name=>$field) => displays at {field} sub display { my $self = shift; return unless my $d = $self->Displays; return keys %{$d} unless defined $_[0]; return unless exists $d->{$_[0]}; return $d->{$_[0]} unless defined $_[1]; return $d->{$_[0]}{$_[1]}; } sub displays { my $self = shift; return unless my $d = $self->Classes; return keys %$d unless @_; my ($class,$name) = @_; my $type = ucfirst(lc($class)); return unless exists $d->{$type}; my $value = $d->{$type}; if (ref $value eq 'CODE') { # oh, wow, a subroutine my @v = $value->($type,$name); # invoke to get list of displays return wantarray ? @v : \@v; } else { return wantarray ? @{$value} : $value; } } sub class2displays { my $self = shift; my ($class,$name) = @_; # No class specified. Return name of all defined classes. return $self->displays unless defined $class; # A class is specified. Map it into the list of display records. my @displays = map {$self->display($_)} $self->displays($class,$name); return @displays; } sub _load { my $package = shift; my $file = shift; no strict 'vars'; no strict 'refs'; $file =~ m!([/a-zA-Z0-9._-]+)!; my $safe = $1; (my $ns = $safe) =~ s/\W/_/g; my $namespace = __PACKAGE__ . '::Config::' . $ns; unless (eval "package $namespace; require '$safe';") { die "compile error while parsing config file '$safe': $@\n"; } # build the object up from the values compiled into the $namespace area my %data; # get the scalars local *symbol; foreach (keys %{"${namespace}::"}) { *symbol = ${"${namespace}::"}{$_}; $data{ucfirst(lc $_)} = $symbol if defined($symbol); $data{ucfirst(lc $_)} = \%symbol if defined(%symbol); $data{ucfirst(lc $_)} = \@symbol if defined(@symbol); $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 { my $pack = shift; my $file = shift; unless ($SITE_DEFS) { (my $rpath = __PACKAGE__) =~ s{::}{/}g; my $path = $INC{"${rpath}.pm"} || warn "Unexpected error: can't locate acebrowser SiteDefs.pm file"; $path =~ s![^/]*$!!; # trim to directory $SITE_DEFS = $path; } return "$SITE_DEFS/$file"; } sub get_config { my $pack = shift; return unless exists $ENV{MOD_PERL}; my $r = Apache->request; return $r->dir_config('AceBrowserConf'); } sub Name { Ace::Browser::AceSubs->get_symbolic(); } 1; AcePerl-1.92/Ace/Object.pm0000644000175000017500000022667210231520117014601 0ustar lsteinlsteinpackage 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; } } sub DESTROY { my $self = shift; return unless defined $self->{class}; # avoid working with temp objects from a search() return if caller() =~ /^(Cache\:\:|DB)/; # prevent recursion in FileCache code my $db = $self->db or return; return if $self->{'.nocache'}; return unless $self->isRoot; if ($self->_dirty) { warn "Destroy for ",overload::StrVal($self)," ",$self->class,':',$self->name if Ace->debug; $self->_dirty(0); $db->file_cache_store($self); } # remove our in-memory cache # shouldn't be necessary with weakref # $db->memory_cache_delete($self); } ###################### object constructor ################# # IMPORTANT: The _clone subroutine will copy all instance variables that # do NOT begin with a dot (.). If you do not want an instance variable # shared with cloned copies, proceed them with a dot!!! # sub new { my $pack = shift; my($class,$name,$db,$isRoot) = rearrange([qw/CLASS NAME/,[qw/DATABASE DB/],'ROOT'],@_); $pack = ref($pack) if ref($pack); my $self = bless { 'name' => $name, 'class' => $class },$pack; $self->db($db) if $self->isObject; $self->{'.root'}++ if defined $isRoot && $isRoot; # $self->_dirty(1) if $isRoot; return $self } ######### construct object from serialized input, not usually called directly ######## sub newFromText { my ($pack,$text,$db) = @_; $pack = ref($pack) if ref($pack); my @array; foreach (split("\n",$text)) { next unless $_; # this is a hack to fix some txt fields with unescaped tabs # unfortunately it breaks other things s/\?txt\?([^?]*?)\t([^?]*?)\?/?txt?$1\\t$2?/g; push(@array,[split("\t")]); } my $obj = $pack->_fromRaw(\@array,0,0,$#array,$db); $obj->_dirty(1); $obj; } ################### name of the object ################# sub name { my $self = shift; $self->{'name'} = shift if defined($_[0]); my $name = $self->_ace_format($self->{'class'},$self->{'name'}); $name; } ################### class of the object ################# sub class { my $self = shift; defined($_[0]) ? $self->{'class'} = shift : $self->{'class'}; } ################### name and class together ################# sub id { my $self = shift; return "$self->{class}:$self->{name}"; } ############## return true if two objects are equivalent ################## # to be equivalent, they must have identical names, classes and databases # # We handle comparisons between objects and numbers ourselves, and let # # Perl handle comparisons between objects and strings # sub eq { my ($a,$b,$rev) = @_; unless (UNIVERSAL::isa($b,'Ace::Object')) { $a = $a->name + 0; # convert to numeric return $a == $b; # do a numeric comparison } return 1 if ($a->name eq $b->name) && ($a->class eq $b->class) && ($a->db eq $b->db); return; } sub ne { return !&eq; } ############ returns true if this is a top-level object ####### sub isRoot { return exists shift()->{'.root'}; } ################### handle to ace database ################# sub db { my $self = shift; if (@_) { my $db = shift; $self->{db} = "$db"; # store string representation, not object } Ace->name2db($self->{db}); } ### Return a portion of the tree at the indicated tag path ### #### In a list context returns the column. In an array context ### #### returns a pointer to the subtree #### #### Usually returns what is pointed to by the tag. Will return #### the parent object if you pass a true value as the second argument sub at { my $self = shift; my($tag,$pos,$return_parent) = rearrange(['TAG','POS','PARENT'],@_); return $self->right unless $tag; $tag = lc $tag; # Removed a $` here to increase speed -- tim.cutts@incyte.com 2 Sep 1999 if (!defined($pos) and $tag=~/(.*?)\[(\d+)\]$/) { $pos = $2; $tag = $1; } my $o = $self; my ($parent,$above,$left); my (@tags) = $self->_split_tags($tag); foreach $tag (@tags) { $tag=~s/$;/./g; # unprotect backslashed dots my $p = $o; ($o,$above,$left) = $o->_at($tag); return unless defined($o); } return $above || $left if $return_parent; return defined $pos ? $o->right($pos) : $o unless wantarray; return $o->col($pos); } ### Flatten out part of the tree into an array #### ### along the row. Will not follow object references. ### sub row { my $self = shift; my $pos = shift; my @r; my $o = defined $pos ? $self->right($pos) : $self; while (defined($o)) { push(@r,$o); $o = $o->right; } return @r; } ### Flatten out part of the tree into an array #### ### along the column. Will not follow object references. ### sub col { my $self = shift; my $pos = shift; $pos = 1 unless defined $pos; croak "Position must be positive" unless $pos >= 0; return ($self) unless $pos > 0; my @r; # This is for tag[1] semantics if ($pos == 1) { for (my $o=$self->right; defined($o); $o=$o->down) { push (@r,$o); } } else { # This is for tag[2] semantics for (my $o=$self->right; defined($o); $o=$o->down) { next unless defined(my $right = $o->right($pos-2)); push (@r,$right->col); } } return @r; } #### Search for a tag, and return the column #### #### Uses a breadth-first search (cols then rows) #### sub search { my $self = shift; my $tag = shift unless $_[0]=~/^-/; my ($subtag,$pos,$filled) = rearrange(['SUBTAG','POS',['FILL','FILLED']],@_); my $lctag = lc $tag; # With caching, the old way of following ends up cloning the object # -- which we don't want. So more-or-less emulate the earlier # behavior with an explicit get and fetch # return $self->follow(-tag=>$tag,-filled=>$filled) if $filled; if ($filled) { my @node = $self->search($tag) or return; # watch out for recursion! my @obj = map {$_->fetch} @node; foreach (@obj) {$_->right if defined $_}; # trigger a fill return wantarray ? @obj : $obj[0]; } TRY: { # look in our tag cache first if (exists $self->{'.PATHS'}) { # we've already cached the desired tree last TRY if exists $self->{'.PATHS'}{$lctag}; # not cached, so try parents of tag my $m = $self->model; my @parents = $m->path($lctag) if $m; my $tree; foreach (@parents) { ($tree = $self->{'.PATHS'}{lc $_}) && last; } if ($tree) { $self->{'.PATHS'}{$lctag} = $tree->search($tag); $self->_dirty(1); last TRY; } } # If the object hasn't been filled already, then we can use # acedb's query mechanism to fetch the subobject. This is a # big win for large objects. ...However, we have to disable # this feature if timestamps are active. unless ($self->filled) { my $subobject = $self->newFromText( $self->db->show($self->class,$self->name,$tag), $self->db ); if ($subobject) { $subobject->{'.nocache'}++; $self->_attach_subtree($lctag => $subobject); } else { $self->{'.PATHS'}{$lctag} = undef; } $self->_dirty(1); last TRY; } my @col = $self->col; foreach (@col) { next unless $_->isTag; if (lc $_ eq $lctag) { $self->{'.PATHS'}{$lctag} = $_; $self->_dirty(1); last TRY; } } # if we get here, we didn't find it in the column, # so we call ourselves recursively to find it foreach (@col) { next unless $_->isTag; if (my $r = $_->search($tag)) { $self->{'.PATHS'}{$lctag} = $r; $self->_dirty(1); last TRY; } } # If we got here, we just didn't find it. So tag the cache # as empty so that we don't try again $self->{'.PATHS'}{$lctag} = undef; $self->_dirty(1); } my $t = $self->{'.PATHS'}{$lctag}; return unless $t; if (defined $subtag) { if ($subtag =~ /^\d+$/) { $pos = $subtag; } else { # position on subtag and search again return $t->fetch->search($subtag,$pos) if $t->isObject || (defined($t->right) and $t->right->isObject); return $t->search($subtag,$pos); } } return defined $pos ? $t->right($pos) : $t unless wantarray; # We do something verrrry interesting in an array context. # If no position is defined, we return the column to the right. # If a position is defined, we return everything $POS tags # to the right (so-called tag[2] system). return $t->col($pos); } # utility routine used in partial tree caching sub _attach_subtree { my $self = shift; my ($tag,$subobject) = @_; my $lctag = lc($tag); my $obj; if (lc($subobject->right) eq $lctag) { # new version of aceserver as of 11/30/98 $obj = $subobject->right; } else { # old version of aceserver $obj = $self->new('tag',$tag,$self->db); $obj->{'.right'} = $subobject->right; } $self->{'.PATHS'}->{$lctag} = $obj; } sub _dirty { my $self = shift; $self->{'.dirty'} = shift if @_ && $self->isRoot; $self->{'.dirty'}; } #### return true if tree is populated, without populating it ##### sub filled { my $self = shift; return exists($self->{'.right'}) || exists($self->{'.raw'}); } #### return true if you can follow the object in the database (i.e. a class ### sub isPickable { return shift->isObject; } #### Return a string representation of the object subject to Ace escaping rules ### sub escape { my $self = shift; my $name = $self->name; my $needs_escaping = $name=~/[^\w.-]/ || $self->isClass; return $name unless $needs_escaping; $name=~s/\"/\\"/g; #escape quotes" return qq/"$name"/; } ############### object on the right of the tree ############# sub right { my ($self,$pos) = @_; $self->_fill; $self->_parse; return $self->{'.right'} unless defined $pos; croak "Position must be positive" unless $pos >= 0; my $node = $self; while ($pos--) { defined($node = $node->right) || return; } $node; } ################# object below on the tree ################# sub down { my ($self,$pos) = @_; $self->_parse; return $self->{'.down'} unless defined $pos; my $node = $self; while ($pos--) { defined($node = $node->down) || return; } $node; } ############################################# # fetch current node from the database # sub fetch { my ($self,$tag) = @_; return $self->search($tag) if defined $tag; my $thing_to_pick = ($self->isTag and defined($self->right)) ? $self->right : $self; return $thing_to_pick unless $thing_to_pick->isObject; my $obj = $self->db->get($thing_to_pick->class,$thing_to_pick->name) if $self->db; return $obj; } ############################################# # follow a tag into the database, returning a # list of followed objects. sub follow { my $self = shift; my ($tag,$filled) = rearrange(['TAG','FILLED'],@_); return unless $self->db; return $self->fetch() unless $tag; my $class = $self->class; my $name = Ace->freeprotect($self->name); my @options; if ($filled) { @options = $filled =~ /^[a-zA-Z]/ ? ('filltag' => $filled) : ('filled'=>1); } return $self->db->fetch(-query=>"find $class $name ; follow $tag",@options); } # returns true if the object has a Model, i.e, can be followed into # the database. sub isObject { my $self = shift; return _isObject($self->class); 1; } # returns true if the object is a tag. sub isTag { my $self = shift; return 1 if $self->class eq 'tag'; return; } # return the most recent error message sub error { $Ace::Error=~s/\0//g; # get rid of nulls 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; # temporary object, don't cache it. my $new = $self->newFromText($data,$self->db); %{$self}=%{$new}; $new->{'.nocache'}++; # this line prevents the thing from being cached $self->_dirty(1); } sub _parse { my $self = shift; return unless my $raw = $self->{'.raw'}; my $ts = $self->db->timestamps; my $col = $self->{'.col'}; my $current_obj = $self; my $current_row = $self->{'.start_row'}; my $db = $self->db; my $changed; for (my $r=$current_row+1; $r<=$self->{'.end_row'}; $r++) { next unless $raw->[$r][$col] ne ''; $changed++; my $obj_right = $self->_fromRaw($raw,$current_row,$col+1,$r-1,$db); # comment handling if ( defined($obj_right) ) { my ($t,$i); my $row = $current_row+1; while ($obj_right->isComment) { $current_obj->comment($obj_right) if $obj_right->isComment; $t = $obj_right; last unless defined ($obj_right = $self->_fromRaw($raw,$row++,$col+1,$r-1,$db)); } } $current_obj->{'.right'} = $obj_right; my ($class,$name,$timestamp) = Ace->split($raw->[$r][$col]); my $obj_down = $self->new($class,$name,$db); $obj_down->timestamp($timestamp) if $ts && $timestamp; # comments never occur at down pointers $current_obj = $current_obj->{'.down'} = $obj_down; $current_row = $r; } my $obj_right = $self->_fromRaw($raw,$current_row,$col+1,$self->{'.end_row'},$db); # comment handling if (defined($obj_right)) { my ($t,$i); my $row = $current_row + 1; while ($obj_right->isComment) { $current_obj->comment($obj_right) if $obj_right->isComment; $t = $obj_right; last unless defined($obj_right = $self->_fromRaw($raw,$row++,$col+1,$self->{'.end_row'},$db)); } } $current_obj->{'.right'} = $obj_right; $self->_dirty(1) if $changed; delete @{$self}{qw[.raw .start_row .end_row .col]}; } sub _fromRaw { my $pack = shift; # this breaks inheritance... # $pack = $pack->factory(); my ($raw,$start_row,$col,$end_row,$db) = @_; $db = "$db" if ref $db; return unless defined $raw->[$start_row][$col]; # HACK! Some LongText entries may begin with newlines. This is within the Acedb spec. # Let's purge text entries of leading space and format them appropriate. # This should probably be handled in Freesubs.xs / Ace::split my $temp = $raw->[$start_row][$col]; # if ($temp =~ /^\?txt\?\s*\n*/) { # $temp =~ s/^\?txt\?(\s*\\n*)/\?txt\?/; # $temp .= '?'; # } my ($class,$name,$ts) = Ace->split($temp); my $self = $pack->new($class,$name,$db,!($start_row || $col)); @{$self}{qw(.raw .start_row .end_row .col db)} = ($raw,$start_row,$end_row,$col,$db); $self->{'.timestamp'} = $ts if defined $ts; return $self; } # Return partial ace subtree at indicated tag sub _at { my ($self,$tag) = @_; my $pos=0; # Removed a $` here to increase speed -- tim.cutts@incyte.com 2 Sep 1999 if ($tag=~/(.*?)\[(\d+)\]$/) { $pos=$2; $tag=$1; } my $p; my $o = $self->right; while ($o) { return ($o->right($pos),$p,$self) if (lc($o) eq lc($tag)); $p = $o; $o = $o->down; } return; } # 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 is the base class for objects returned from ACEDB databases. Currently there is only one type of I, but this may change in the future to support more interesting object-specific behaviors. Using the I interface, you can explore the internal structure of an I, 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. =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 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 and B 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; $city = $object->right->down(2)->right(2)->down(2); If $object contains the "Thierry-Mieg J" Author object, then the first series of accesses shown above retrieves the string "Jean Thierry-Mieg" and the second retrieves "34033 Montpellier." If the right or bottom pointers are NULL, these methods will return undef. In addition to being somewhat awkard, you will probably never need to use these methods. A simpler way to retrieve the same information would be to use the at() method described in the next section. The right() and down() methods always walk through the tree of the current object. They do not follow object pointers into the database. Use B (or the deprecated B or B methods) instead. =head2 at() method $subtree = $object->at($tag_path); @values = $object->at($tag_path); at() is a simple way to fetch the portion of the tree that you are interested in. It takes a single argument, a simple tag or a path. A simple tag, such as "Full_name", must correspond to a tag in the column immediately to the right of the root of the tree. A path such as "Address.Mail" is a dot-delimited path to the subtree. Some examples are given below. ($full_name) = $object->at('Full_name'); @address_lines = $object->at('Address.Mail'); The second line above is equivalent to: @address = $object->at('Address')->at('Mail'); Called without a tag name, at() just dereferences the object, returning whatever is to the right of it, the same as $object->right If a path component already has a dot in it, you may escape the dot with a backslash, as in: $s=$db->fetch('Sequence','M4'); @homologies = $s->at('Homol.DNA_homol.yk192f7\.3'; This also demonstrates that path components don't necessarily have to be tags, although in practice they usually are. at() returns slightly different results depending on the context in which it is called. In a list context, it returns the column of values to the B of the tag. However, in a scalar context, it returns the subtree rooted at the tag. To appreciate the difference, consider these two cases: $name1 = $object->at('Full_name'); ($name2) = $object->at('Full_name'); After these two statements run, $name1 will be the tag object named "Full_name", and $name2 will be the text object "Jean Thierry-Mieg", The relationship between the two is that $name1->right leads to $name2. This is a powerful and useful construct, but it can be a trap for the unwary. If this behavior drives you crazy, use this construct: $name1 = $object->at('Full_name')->at(); For finer control over navigation, path components can include optional indexes to indicate navigation to the right of the current path component. Here is the syntax: $object->at('tag1[index1].tag2[index2].tag3[index3]...'); Indexes are zero-based. An index of [0] indicates no movement relative to the current component, and is the same as not using an index at all. An index of [1] navigates one step to the right, [2] moves two steps to the right, and so on. Using the Thierry-Mieg object as an example again, here are the results of various indexes: $object = $db->fetch(Author,"Thierry-Mieg J"); $a = $object->at('Address[0]') --> "Address" $a = $object->at('Address[1]') --> "Mail" $a = $object->at('Address[2]') --> "CRBM duCNRS" In an array context, the last index in the path does something very interesting. It returns the entire column of data K steps to the right of the path, where K is the index. This is used to implement so-called "tag[2]" syntax, and is very useful in some circumstances. For example, here is a fragment of code to return the Thierry-Mieg object's full address without having to refer to each of the intervening "Mail", "E_Mail" and "Phone" tags explicitly. @address = $object->at('Address[2]'); --> ('CRBM duCNRS','BP 5051','34033 Montpellier','FRANCE', 'mieg@kaa.cnrs-mop.fr,'33-67-613324','33-67-521559') Similarly, "tag[3]" will return the column of data three hops to the right of the tag. "tag[1]" is identical to "tag" (with no index), and will return the column of data to the immediate right. There is no special behavior associated with using "tag[0]" in an array context; it will always return the subtree rooted at the indicated tag. Internal indices such as "Homol[2].BLASTN", do not have special behavior in an array context. They are always treated as if they were called in a scalar context. Also see B and B. =head2 get() method $subtree = $object->get($tag); @values = $object->get($tag); @values = $object->get($tag, $position); @values = $object->get($tag => $subtag, $position); The get() method will perform a breadth-first search through the object (columns first, followed by rows) for the tag indicated by the argument, returning the column of the portion of the subtree it points to. For example, this code fragment will return the value of the "Fax" tag. ($fax_no) = $object->get('Fax'); --> "33-67-521559" The list versus scalar context semantics are the same as in at(), so if you want to retrieve the scalar value pointed to by the indicated tag, either use a list context as shown in the example, above, or a dereference, as in: $fax_no = $object->get('Fax'); --> "Fax" $fax_no = $object->get('Fax')->at; --> "33-67-521559" An optional second argument to B, $position, allows you to navigate the tree relative to the retrieved subtree. Like the B navigational indexes, $position must be a number greater than or equal to zero. In a scalar context, $position moves rightward through the tree. In an array context, $position implements "tag[2]" semantics. For example: $fax_no = $object->get('Fax',0); --> "Fax" $fax_no = $object->get('Fax',1); --> "33-67-521559" $fax_no = $object->get('Fax',2); --> undef # nothing beyond the fax number @address = $object->get('Address',2); --> ('CRBM duCNRS','BP 5051','34033 Montpellier','FRANCE', 'mieg@kaa.cnrs-mop.fr,'33-67-613324','33-67-521559') It is important to note that B only traverses tags. It will not traverse nodes that aren't tags, such as strings, integers or objects. This is in keeping with the behavior of the Ace query language "show" command. This restriction can lead to confusing results. For example, consider the following object: Clone: B0280 Position Map Sequence-III Ends Left 3569 Right 3585 Pmap ctg377 -1040 -1024 Positive Positive_locus nhr-10 Sequence B0280 Location RW FingerPrint Gel_Number 0 Canonical_for T20H1 K10E5 Bands 1354 18 The following attempt to fetch the left and right positions of the clone will fail, because the search for the "Left" and "Right" tags cannot traverse "Sequence-III", which is an object, not a tag: my $left = $clone->get('Left'); # will NOT work my $right = $clone->get('Right'); # neither will this one 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 method to find a tag named "Fax" and return its contents. Unlike get(), this method will B. 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 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 returns the number of items in the column. =head2 row() method @row=$object->row(); @row=$object->row($position); B 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 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 "$obj" if $obj->isTag; # objects are blue return qq{$obj} 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 ($gif,$boxes) = $object->asGIF(); ($gif,$boxes) = $object->asGIF(-clicks=>[[$x1,$y1],[$x2,$y2]...] -dimensions=> [$width,$height], -coords => [$top,$bottom], -display => $display_type, -view => $view_type, -getcoords => $true_or_false ); asGIF() returns the object as a GIF image. The contents of the GIF will be whatever xace would ordinarily display in graphics mode, and will vary for different object classes. You can optionally provide asGIF with a B<-clicks> argument to simulate the action of a user clicking on the image. The click coordinates should be formatted as an array reference that contains a series of two-element subarrays, each corresponding to the X and Y coordinates of a single mouse click. There is currently no way to pass information about middle or right mouse clicks, dragging operations, or keystrokes. You may also specify a B<-dimensions> to control the width and height of the returned GIF. Since there is no way of obtaining the preferred size of the image in advance, this is not usually useful. The optional B<-display> argument allows you to specify an alternate display for the object. For example, Clones can be displayed either with the PMAP display or with the TREE display. If not specified, the default display is used. The optional B<-view> argument allows you to specify an alternative view for MAP objects only. If not specified, you'll get the default view. The option B<-coords> argument allows you to provide the top and bottom of the display for MAP objects only. These coordinates are in the map's native coordinate system (cM, bp). By default, AceDB will show most (but not necessarily all) of the map according to xace's display rules. If you call this method with the B<-getcoords> argument and a true value, it will return a two-element array containing the coordinates of the top and bottom of the map. asGIF() returns a two-element array. The first element is the GIF data. The second element is an array reference that indicates special areas of the image called "boxes." Boxes are rectangular areas that surround buttons, and certain displayed objects. Using the contents of the boxes array, you can turn the GIF image into a client-side image map. Unfortunately, not everything that is clickable is represented as a box. You still have to pass clicks on unknown image areas back to the server for processing. Each box in the array is a hash reference containing the following keys: 'coordinates' => [$left,$top,$right,$bottom] 'class' => object class or "BUTTON" 'name' => object name, if any 'comment' => a text comment of some sort I points to an array of points indicating the top-left and bottom-right corners of the rectangle. I indicates the class of the object this rectangle surrounds. It may be a database object, or the special word "BUTTON" for one of the display action buttons. I indicates the name of the object or the button. I is some piece of information about the object in question. You can display it in the status bar of the browser or in a popup window if your browser provides that facility. =head2 asDNA() and asPeptide() methods $dna = $object->asDNA(); $peptide = $object->asPeptide(); If you are dealing with a sequence object of some sort, these methods will return strings corresponding to the DNA or peptide sequence in FASTA format. =head2 add_row() method $result_code = $object->add_row($tag=>$value); $result_code = $object->add_row($tag=>[list,of,values]); $result_code = $object->add(-path=>$tag, -value=>$value); add_row() updates the tree by adding data to the indicated tag path. The example given below adds the value "555-1212" to a new Address entry named "Pager". You may call add_row() a second time to add a new value under this tag, creating multi-valued entries. $object->add_row('Address.Pager'=>'555-1212'); You may provide a list of values to add an entire row of data. For example: $sequence->add_row('Assembly_tags'=>['Finished Left',38949,38952,'AC3']); Actually, the array reference is not entirely necessary, and if you prefer you can use this more concise notation: $sequence->add_row('Assembly_tags','Finished Left',38949,38952,'AC3'); No check is done against the database model for the correct data type or tag path. The update isn't actually performed until you call commit(), at which time a result code indicates whether the database update was successful. You may create objects that reference other objects this way: $lab = new Ace::Object('Laboratory','LM',$db); $lab->add_row('Full_name','The Laboratory of Medicine'); $lab->add_row('City','Cincinatti'); $lab->add_row('Country','USA'); $author = new Ace::Object('Author','Smith J',$db); $author->add_row('Full_name','Joseph M. Smith'); $author->add_row('Laboratory',$lab); $lab->commit(); $author->commit(); The result code indicates whether the addition was syntactically correct. add_row() will fail if you attempt to add a duplicate entry (that is, one with exactly the same tag and value). In this case, use replace() instead. Currently there is no checking for an attempt to add multiple values to a single-valued (UNIQUE) tag. The error will be detected and reported at commit() time however. The add() method is an alias for add_row(). See also the Ace->new() method. =head2 add_tree() $result_code = $object->add_tree($tag=>$ace_object); $result_code = $object->add_tree(-tag=>$tag,-tree=>$ace_object); The add_tree() method will insert an entire Ace subtree into the object to the right of the indicated tag. This can be used to build up complex Ace objects, or to copy portions of objects from one database to another. The first argument is a tag path, and the second is the tree that you wish to insert. As with add_row() the database will only be updated when you call commit(). When inserting a subtree, you must be careful to remember that everything to the *right* of the node that you are pointing at will be inserted; not the node itself. For example, given this Sequence object: Sequence AC3 DB_info Database EMBL Assembly_tags Finished Left 1 4 AC3 Clone left end 1 4 AC3 Clone right end 5512 5515 K07C5 38949 38952 AC3 Finished Right 38949 38952 AC3 If we use at('Assembly_tags') to fetch the subtree rooted on the "Assembly_tags" tag, it is the tree to the right of this tag, beginning with "Finished Left", that will be inserted. Here is an example of copying the "Assembly_tags" subtree from one database object to another: $remote = Ace->connect(-port=>200005) || die "can't connect"; $ac3 = $remote->fetch(Sequence=>'AC3') || die "can't get AC7"; my $assembly = $ac3->at('Assembly_tags'); $local = Ace->connect(-path=>'~acedb') || die "can't connect"; $AC3copy = Ace::Object->new(Sequence=>'AC3copy',$local); $AC3copy->add_tree('Assembly_tags'=>$tags); $AC3copy->commit || warn $AC3copy->error; Notice that this syntax will not work the way you think it should: $AC3copy->add_tree('Assembly_tags'=>$ac3->at('Assembly_tags')); This is because call at() in an array context returns the column to the right of the tag, not the tag itself. Here's an example of building up a complex structure from scratch using a combination of add() and add_tree(): $newObj = Ace::Object->new(Sequence=>'A555',$local); my $assembly = Ace::Object->new(tag=>'Assembly_tags'); $assembly->add('Finished Left'=>[10,20,'ABC']); $assembly->add('Clone right end'=>[1000,2000,'DEF']); $assembly->add('Clone right end'=>[8000,9876,'FRED']); $assembly->add('Finished Right'=>[1000,3000,'ETHEL']); $newObj->add_tree('Assembly_tags'=>$assembly); $newObj->commit || warn $newObj->error; =head2 delete() method $result_code = $object->delete($tag_path,$value); $result_code = $object->delete(-path=>$tag_path, -value=>$value); Delete the indicated tag and value from the object. This example deletes the address line "FRANCE" from the Author's mailing address: $object->delete('Address.Mail','FRANCE'); No actual database deletion occurs until you call commit(). The delete() result code indicates whether the deletion was successful. Currently it is always true, since the database model is not checked. =head2 replace() method $result_code = $object->replace($tag_path,$oldvalue,$newvalue); $result_code = $object->replace(-path=>$tag_path, -old=>$oldvalue, -new=>$newvalue); Replaces the indicated tag and value with the new value. This example changes the address line "FRANCE" to "LANGUEDOC" in the Author's 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 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 for details. =head2 timestamp() method $stamp = $object->timestamp; The B 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 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 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, L, L, L, L,L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg 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 = "\n"; $modify_code = \&_default_makeHTML unless $modify_code; $self->right->_asHTML(\$string,1,2,$modify_code); $string .= "\n
$self
\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); return ($start,$stop); } push(@commands,"gifdump -"); # do the query my $data = $self->db->raw_query(join(' ; ',@commands)); # A $' has been removed here to improve speed -- tim.cutts@incyte.com 2 Sep 1999 # did this query succeed? my ($bytes, $trim); return unless ($bytes, $trim) = $data=~m!^// (\d+) bytes\n\0*(.+)!sm; my $gif = substr($trim,0,$bytes); # now process the boxes my @b; my @boxes = split("\n",substr($trim,$bytes)); foreach (@boxes) { last if m!^//!; chomp; my ($left,$top,$right,$bottom,$class,$name,$comments) = m/^\s*\d*\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\w+):"(.+)"\s*(.*)/; next unless defined $left; $comments=~s/\s+$//; # sometimes there's extra white space at the end my $box = {'coordinates'=>[$left,$top,$right,$bottom], 'class'=>$class, 'name' =>$name, 'comment'=>$comments}; push (@b,$box); } return ($gif,\@b); } ############## timestamp and comment information ############ sub timestamp { my $self = shift; return $self->{'.timestamp'} = $_[0] if defined $_[0]; if ($self->db && !$self->{'.timestamp'}) { $self->_fill; $self->_parse; } return $self->{'.timestamp'} if $self->{'.timestamp'}; return unless defined $self->right; return $self->{'.timestamp'} = $self->right->timestamp; } sub comment { my $self = shift; return $self->{'.comment'} = $_[0] if defined $_[0]; if ($self->db && !$self->{'.comment'}) { $self->_fill; $self->_parse; } return $self->{'.comment'}; } ### Return list of all the tags in the object ### sub tags { my $self = shift; my $current = $self->right; my @tags; while (defined($current)) { push(@tags,$current); $current = $current->down; } return @tags; } ################# kill an object ################ # Removes the object from the database immediately. sub kill { my $self = shift; return unless my $db = $self->db; return 1 unless $db->count($self->class,$self->name); my $result = $db->raw_query("kill"); if (defined($result) and $result=~/write access/im) { # this keeps changing $Ace::Error = "Write access denied"; return; } # uncache cached values and clear the object out # as best we can delete @{$self}{qw[.PATHS .right .raw .down]}; 1; } # sub isTimestamp { # my $self = shift; # return 1 if $self->class eq 'UserSession'; # return; # } sub isComment { my $self = shift; return 1 if $self->class eq 'Comment'; return; } ################# add a new row ############# # Only changes local copy until you perform commit() # # returns true if this is a valid thing to do # sub add_row { my $self = shift; my($tag,@newvalue) = rearrange([['TAG','PATH'],'VALUE'],@_); # flatten array refs into array my @values = map { ref($_) && ref($_) eq 'ARRAY' ? @$_ : $_ } @newvalue; # make sure that this entry doesn't already exist unless ($tag =~ /\./) { my $model = $self->model; my @intermediate_tags = $model->path($tag); $tag = join '.',@intermediate_tags,$tag; } my $row = join(".",($tag,map { (my $x = $_) =~s/\./\\./g; $x } @values)); return if $self->at($row); # an identical row already exists in the object # If we get here then we need to turn @values into an array of Ace::Objects # for insertion. Also need to link them together into a row. my $previous; foreach (@values) { if (ref($_) && $_->isa('Ace::Object')) { $_ = $_->_clone; } else { $_ = $self->new('scalar',$_); } $previous->{'.right'} = $_ if defined $previous; $previous = $_; $_->{'.right'} = undef; # make sure it doesn't automatically expand! } # position at the indicated tag (creating it if necessary) my (@tags) = $self->_split_tags($tag); my $p = $self; foreach (@tags) { $p = $p->_insert($_); } if ($p->{'.right'}) { $p = $p->{'.right'}; while (1) { last unless $p->{'.down'}; $p = $p->{'.down'}; } $p->{'.down'} = $values[0]; } else { $p->{'.right'} = $values[0]; } push(@{$self->{'.update'}},join(' ',map { Ace->freeprotect($_) } (@tags,@values))); delete $self->{'.PATHS'}; # uncache cached values $self->_dirty(1); 1; } # Use this method to add an entire subobject to the right of the tag. # The tree may come from another database. sub add_tree { my $self = shift; my($tag,$value,@rest) = rearrange([['TAG','PATH'],['VALUE','TREE']],@_); croak "Value must be an Ace::Object" unless ref($value) && $value->isa('Ace::Object'); unless ($tag =~ /\./) { my $model = $self->model; my @intermediate_tags = $model->path($tag); $tag = join '.',@intermediate_tags,$tag; } # position at the indicated tag, creating it if necessary my (@tags) = $self->_split_tags($tag); my $p = $self; foreach (@tags) { $p = $p->_insert($_); } # Copy the subtree too if ($p->{'.right'}) { $p = $p->{'.right'}; while (1) { last unless $p->{'.down'}; $p = $p->{'.down'}; } $p->{'.down'} = $value->{'.right'}; } else { $p->{'.right'} = $value->{'.right'}; } push(@{$self->{'.update'}},map { join(' ',@tags,$_) } split("\n",$value->asAce)); delete $self->{'.PATHS'}; # uncache cached values $self->_dirty(1); 1; } ################# delete a portion of the tree ############# # Only changes local copy until you perform commit() # # returns true if this is a valid thing to do. sub delete { my $self = shift; my($tag,$oldvalue,@rest) = rearrange([['TAG','PATH'],['VALUE','OLDVALUE','OLD']],@_); # flatten array refs into array my @values; @values = map { ref($_) && ref($_) eq 'ARRAY' ? @$_ : $_ } ($oldvalue,@rest) if defined($oldvalue); unless ($tag =~ /\./) { my $model = $self->model; my @intermediate_tags = $model->path($tag); $tag = join '.',@intermediate_tags,$tag; } my $row = join(".",($tag,map { (my $x = $_) =~s/\./\\./g; $x } @values)); my $subtree = $self->at($row,undef,1); # returns the parent if (@values && defined($subtree->{'.right'}) && "$subtree->{'.right'}" eq $oldvalue) { $subtree->{'.right'} = $subtree->{'.right'}->down; } else { $subtree->{'.down'} = $subtree->{'.down'}->{'.down'} } push(@{$self->{'.update'}},join(' ','-D', map { Ace->freeprotect($_) } ($self->_split_tags($tag),@values))); delete $self->{'.PATHS'}; # uncache cached values $self->_dirty(0); $self->db->file_cache_delete($self); 1; } ################# delete a portion of the tree ############# # Only changes local copy until you perform commit() # # returns true if this is a valid thing to do # sub replace { my $self = shift; my($tag,$oldvalue,$newvalue,@rest) = rearrange([['TAG','PATH'], ['OLDVALUE','OLD'], ['NEWVALUE','NEW']],@_); $self->delete($tag,$oldvalue); $self->add($tag,$newvalue,@rest); delete $self->{'.PATHS'}; # uncache cached values 1; } # commit changes from local copy to database copy sub commit { my $self = shift; return unless my $db = $self->db; my ($retval,@cmd); my $name = $self->{'name'}; return unless defined $name; $name =~ s/([^a-zA-Z0-9_-])/\\$1/g; return 1 unless exists $self->{'.update'} && $self->{'.update'}; $Ace::Error = ''; my $result = ''; # bad design alert: the following breaks encapsulation if ($db->db->can('write')) { # new way for socket server my $cmd = join "\n","$self->{'class'} : $name",@{$self->{'.update'}}; warn $cmd if $self->debug; $result = $db->raw_query($cmd,0,'parse'); # sets Ace::Error for us } else { # old way for RPC server and local my $cmd = join('; ',"$self->{'class'} : $name", @{$self->{'.update'}}); warn $cmd if $self->debug; $result = $db->raw_query("parse = $cmd"); } if (defined($result) and $result=~/write( or admin)? access/im) { # this keeps changing $Ace::Error = "Write access denied"; } elsif (defined($result) and $result =~ /sorry|parse error/mi) { $Ace::Error = $result; } return if $Ace::Error; undef $self->{'.update'}; # this will force a fresh retrieval of the object # and synchronize our in-memory copy with the db delete $self->{'.right'}; delete $self->{'.PATHS'}; return 1; } # undo changes sub rollback { my $self = shift; undef $self->{'.update'}; # this will force object to be reloaded from database # next time it is needed. delete $self->{'.right'}; delete $self->{'.PATHS'}; 1; } sub debug { my $self = shift; Ace->debug(@_); } ### Get or set the date style (actually calls through to the database object) ### sub date_style { my $self = shift; return unless $self->db; return $self->db->date_style(@_); } sub _asHTML { my($self,$out,$position,$level,$morph_code) = @_; do { $$out .= "" unless $position; $$out .= "" x ($level-$position-1); my ($cell,$prune,$did_it_myself) = $morph_code->($self); $$out .= $did_it_myself ? $cell : "$cell"; if ($self->comment) { my ($cell,$p,$d) = $morph_code->($self->comment); $$out .= $d ? $cell : "$cell"; $$out .= "\n" . "" x $level unless $self->down && !defined($self->right); } $level = $self->right->_asHTML($out,$level,$level+1,$morph_code) if defined($self->right) && !$prune; $$out .= "\n" if defined($self = $self->down); $position = 0; } while defined $self; return --$level; } # This function is overly long because it is optimized to prevent parsing # parts of the tree that haven't previously been parsed. sub _asTable { my($self,$out,$position,$level) = @_; do { if ($self->{'.raw'}) { # we still have raw data, so we can optimize my ($a,$start,$end) = @{$self}{ qw(.col .start_row .end_row) }; my @to_append = map { join("\t",@{$_}[$a..$#{$_}]) } @{$self->{'.raw'}}[$start..$end]; my $new_row; foreach (@to_append) { # hack alert s/(\?.*?[^\\]\?.*?[^\\]\?)\S*/$self->_ace_format(Ace->split($1))/eg; if ($new_row++) { $$out .= "\n"; $$out .= "\t" x ($level-1) } $$out .= $_; } return $level-1; } $$out .= "\t" x ($level-$position-1); $$out .= $self->name . "\t"; if ($self->comment) { $$out .= $self->comment; $$out .= "\n" . "\t" x $level unless $self->down && !defined($self->right); } $level = $self->right->_asTable($out,$level,$level+1) if defined $self->right; $$out .= "\n" if defined($self = $self->down); $position = 0; } while defined $self; return --$level; } # This is the default code that will be called during construction of # the HTML table. It returns a two-member list consisting of the modified # entry and (optionally) a true value if we are to prune here. The returned string # will be placed inside a tag. There's nothing you can do about that. sub _default_makeHTML { my $self = shift; my ($string,$prune) = ("$self",0); return ($string,$prune) unless $self->isObject || $self->isTag; if ($self->isTag) { $string = "$self"; } elsif ($self->isComment) { $string = "$self"; } else { $string = qq{$self} ; } return ($string,$prune); } # Insert a new tag or value. # Local only. Will not affect the database. # Returns the inserted tag, or the preexisting # tag, if already there. sub _insert { my ($self,$tag) = @_; my $p = $self->{'.right'}; return $self->{'.right'} = $self->new('tag',$tag) unless $p; while ($p) { return $p if "$p" eq $tag; last unless $p->{'.down'}; $p = $p->{'.down'}; } # if we get here, then we didn't find it, so # insert at the bottom return $p->{'.down'} = $self->new('tag',$tag); } # This is unsatisfactory because it duplicates much of the code # of asTable. sub _asAce { my($self,$out,$level,$tags) = @_; # ugly optimization for speed if ($self->{'.raw'}){ my ($a,$start,$end) = @{$self}{qw(.col .start_row .end_row)}; my (@last); foreach (@{$self->{'.raw'}}[$start..$end]){ my $j=1; $$out .= join("\t",@$tags) . "\t" if ($level==0) && (@$tags); my (@to_modify) = @{$_}[$a..$#{$_}]; foreach (@to_modify) { my ($class,$name) =Ace->split($_); if (defined($name)) { $name = $self->_ace_format($class,$name); if (_isObject($class) || $name=~/[^\w.-]/) { $name=~s/"/\\"/g; #escape quotes with slashes $name = qq/\"$name\"/; } } else { $name = $last[$j] if $name eq ''; } $_ = $last[$j++] = $name; $$out .= "$_\t"; } $$out .= "\n"; $level = 0; } chop($$out); return; } $$out .= join("\t",@$tags) . "\t" if ($level==0) && (@$tags); $$out .= $self->escape . "\t"; 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\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\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\n); } $self = $self->down; } while defined $self; return --$level; } sub escapeXML { my ($self,$string) = @_; $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' : $1 eq '7' ? 'seven' : $1 eq '8' ? 'eight' : $1 eq '9' ? 'nine' : $1/ex; $tag; } AcePerl-1.92/Ace/Local.pm0000644000175000017500000002404410231520035014411 0ustar lsteinlsteinpackage Ace::Local; require 5.004; use strict; use IPC::Open2; use Symbol; use Fcntl qw/F_SETFL O_NONBLOCK/; use vars '$VERSION'; $VERSION = '1.05'; use Ace qw/rearrange STATUS_WAITING STATUS_PENDING STATUS_ERROR/; use constant DEFAULT_HOST=>'localhost'; use constant DEFAULT_PORT=>200005; 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); # note, this relies on the programs being included in the current PATH my $prompt = 'acedb> '; if ($host || $port) { $program ||= 'aceclient'; $prompt = "acedb\@$host> "; } else { $program ||= 'giface'; } if ($program =~ /aceclient/) { $host ||= DEFAULT_HOST; $port ||= DEFAULT_PORT; $args = "$host -port $port"; } else { $path ||= DEFAULT_DB; $path = _expand_twiddles($path); $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; } } 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 { my $self = shift; my $d = $self->{debug}; $self->{debug} = shift if @_; $d; } sub DESTROY { my $self = shift; return unless kill 0,$self->{'pid'}; if ($self->auto_save) { # save work for the user... $self->query('save'); $self->synch; } $self->query('quit'); # just for paranoid reasons. shouldn't be necessary close $self->{'write'} if $self->{'write'}; close $self->{'read'} if $self->{'read'}; waitpid($self->{pid},0) if $self->{'pid'}; } sub encore { my $self = shift; return $self->status == STATUS_PENDING; } sub auto_save { my $self = shift; $self->{'auto_save'} = $_[0] if defined $_[0]; return $self->{'auto_save'}; } sub status { return $_[0]->{'status'}; } sub error { my $self = shift; return $self->{'error'}; } sub query { my $self = shift; my $query = shift; warn "query($query)\n" if $self->debug; if ($self->debug) { my $msg = $query || ''; warn "\tquery($msg)"; } return undef if $self->{'status'} == STATUS_ERROR; do $self->read() until $self->{'status'} != STATUS_PENDING; my $wtr = $self->{'write'}; print $wtr "$query\n"; $self->{'status'} = STATUS_PENDING; } sub low_read { # hack to accomodate "uninitialized database" warning from tace my $self = shift; my $rdr = $self->{'read'}; return undef unless $self->{'status'} == STATUS_PENDING; my $rin = ''; my $data = ''; vec($rin,fileno($rdr),1)=1; unless (select($rin,undef,undef,1)) { $self->{'status'} = STATUS_WAITING; 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) { $self->{'status'} = STATUS_ERROR; return; } # 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'} = ''; return $result; } # return partial results for paragraph breaks if (($pos = rindex($self->{'buffer'}, "\n\n")) > 0) { $result = substr($self->{'buffer'}, 0, $pos + 2); $self->{'buffer'} = substr($self->{'buffer'}, $pos + 2); return $result; } $len += $bytes; } # never get here } # just throw away everything sub synch { my $self = shift; $self->read() while $self->status == STATUS_PENDING; } # expand ~foo syntax sub _expand_twiddles { my $path = shift; my ($to_expand,$homedir); return $path unless $path =~ m!^~([^/]*)!; if ($to_expand = $1) { $homedir = (getpwnam($to_expand))[7]; } else { $homedir = (getpwuid($<))[7]; } return $path unless $homedir; $path =~ s!^~[^/]*!$homedir!; return $path; } __END__ =head1 NAME Ace::Local - use giface, tace or gifaceclient to open a local connection to an Ace database =head1 SYNOPSIS use Ace::Local my $ace = Ace::Local->connect(-path=>'/usr/local/acedb/elegans'); $ace->query('find author Se*'); die "Query unsuccessful" unless $ace->status; $ace->query('show'); while ($ace->encore) { print $ace->read; } =head1 DESCRIPTION This class is provided for low-level access to local (non-networked) Ace databases via the I program. You will generally not need to access it directly. Use Ace.pm instead. For the sake of completeness, the method can also use the I program for its access. However the Ace::AceDB class is more efficient for this purpose. =head1 METHODS =head2 connect() $accessor = Ace::Local->connect(-path=>$path_to_database); Connect to the database at the indicated path using I and return a connection object (an "accessor"). I must be on the current search path. Multiple accessors may be open simultaneously. Arguments include: =over 4 =item B<-path> Path to the database (location of the "wspec/" directory). =item B<-program> Used to indicate the location of the desired I or I executable. You may also use I or I, but in that case the asGIF() functionality will nog work. Can be used to override the search path. =item B<-host> Used when invoking I. Indicates the host to connect to. =item B<-port> Used when invoking I. Indicates the port to connect to. =item B<-nosync> Ordinarily Ace::Local synchronizes with the tace/giface prompt, throwing out all warnings and copyright messages. If this is set, Ace::Local will not do so. In this case you must call the low_read() method until it returns undef in order to synchronize. =back =head2 query() $status = $accessor->query('query string'); Send the query string to the server and return a true value if successful. You must then call read() repeatedly in order to fetch the query result. =head2 read() Read the result from the last query sent to the server and return it as a string. ACE may return the result in pieces, breaking between whole objects. You may need to read repeatedly in order to fetch the entire result. Canonical example: $accessor->query("find Sequence D*"); die "Got an error ",$accessor->error() if $accessor->status == STATUS_ERROR; while ($accessor->status == STATUS_PENDING) { $result .= $accessor->read; } =head2 low_read() Read whatever data's available, or undef if none. This is only used by the ace.pl replacement for giface/tace. =head2 status() Return the status code from the last operation. Status codes are exported by default when you B Ace.pm. The status codes you may see are: STATUS_WAITING The server is waiting for a query. STATUS_PENDING A query has been sent and Ace is waiting for you to read() the result. STATUS_ERROR A communications or syntax error has occurred =head2 error() May return a more detailed error code supplied by Ace. Error checking is not fully implemented. =head2 encore() This method will return true after you have performed one or more read() operations, and indicates that there is more data to read. B is functionally equivalent to: $encore = $accessor->status == STATUS_PENDING; In fact, this is how it's implemented. =head2 auto_save() Sets or queries the I variable. If true, the "save" command will be issued automatically before the connection to the database is severed. The default is true. Examples: $accessor->auto_save(1); $flag = $accessor->auto_save; =head1 SEE ALSO L, L, L, L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg 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 AcePerl-1.92/Ace/Sequence/0000755000175000017500000000000011106333223014570 5ustar lsteinlsteinAcePerl-1.92/Ace/Sequence/Multi.pm0000644000175000017500000002026707263650700016242 0ustar lsteinlsteinpackage Ace::Sequence::Multi; use strict; use Carp; use strict; use Ace 1.50 qw(:DEFAULT rearrange); use Ace::Sequence; use vars '@ISA'; @ISA = 'Ace::Sequence'; # backward compatibility *db_id = \&db; 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 (@_) { $self->{'secondary'}->{$_}=$_; } } sub delete_secondary { my $self = shift; foreach (@_) { delete $self->{'secondary'}->{$_}; } } sub db { return $_[0]->SUPER::db() unless $_[1]; return $_[0]->{'secondary'}->{$_[1]} || $_[0]->SUPER::db(); } # return list of features quickly sub feature_list { my $self = shift; return $self->{'feature_list'} if $self->{'feature_list'}; my $raw; for my $db ($self->db,$self->secondary) { $raw .= $self->_query($db,'seqfeatures -version 2 -list'); $raw .= "\n"; # avoid nulls } return $self->{'feature_list'} = Ace::Sequence::FeatureList->new($raw); } # return a unified gff file sub gff { my $self = shift; my ($abs,$features) = rearrange([['ABS','ABSOLUTE'],'FEATURES'],@_); my $db = $self->db; my $gff = $self->SUPER::gff(-Abs=>$abs,-Features=>$features,-Db=>$db); return unless $gff; return $gff unless $self->secondary; my(%seen,@lines); foreach (grep !$seen{$_}++,split("\n",$gff)) { #ignore duplicates next if m!^//!; # ignore comments push @lines,/^\#/ ? $_ : join "\t",$_,$db; } my $opt = $self->_feature_filter($features); for my $db ($self->secondary) { my $supplement = $self->_gff($opt,$db); $self->transformGFF(\$supplement) unless $abs; my $string = $db->asString; foreach (grep !$seen{$_}++,split("\n",$supplement)) { #ignore duplicates next if m!^(//|\#)!; # ignore comments push(@lines, join "\t",$_,$string); # add database as an eighth field } } return join("\n",@lines,''); } # turn a GFF file and a filter into a list of Ace::Sequence::Feature objects sub _make_features { my $self = shift; my ($gff,$filter) = @_; my @dbs = ($self->db,$self->secondary); my %dbs = map { $_->asString => $_ } @dbs; my ($r,$r_offset,$r_strand) = $self->refseq; my $abs = $self->absolute; if ($abs) { $r_offset = 0; $r = $self->parent; $r_strand = '+1'; } my @features; foreach (split("\n",$gff)) { next if m[^(?:\#|//)]; next unless $filter->($_); next unless my ($dbname) = /\t(\S+)$/; next unless my $db = $dbs{$dbname}; next unless my $parent = $self->parent; push @features,Ace::Sequence::Feature->new($parent,$r,$r_offset,$r_strand,$abs,$_,$db); } return @features; } 1; __END__ =head1 NAME Ace::Sequence::Multi - Combine Feature Tables from Multiple Databases =head1 SYNOPSIS use Ace::Sequence::Multi; # open reference database $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; $subtype = $feature->subtype; $start = $feature->start; $end = $feature->end; $score = $feature->score; # Follow the target $target = $feature->info; # print the target's start and end positions print $target->start,'-',$target->end, "\n"; =head1 DESCRIPTION I transparently combines information stored about a sequence in a reference database with features tables from any number of annotation databases. The resulting object can be used just like an Ace::Sequence object, except that the features remember their database of origin and go back to that database for information. This class will only work properly if the reference database and all annotation databases share the same cosmid map. =head1 OBJECT CREATION You will use the new() method to create new Ace::Sequence::Multi objects. The arguments are identical to the those in the Ace::Sequence parent class, with the addition of an option B<-secondary> argument, which points to one or more secondary databases from which to fetch annotation information. =over 4 =item -source The sequence source. This must be an I 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 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 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 disjunct reference sequence, such as one on a different chromosome, will fail. =item -name As an alternative to using an I with the B<-source> argument, you may specify a source sequence using B<-name> and B<-db>. The I module will use the provided database accessor to fetch a Sequence object with the specified name. new() will return undef is no Sequence by this name is known. =item -db This argument is required if the source sequence is specified by name rather than by object reference. It must be a previously opened handle to the reference database. =item -secondary This argument points to one or more previously-opened annotation databases. You may use a scalar if there is only one annotation database. Otherwise, use an array reference. You may add and delete annotation databases after the object is created by using the add_secondary() and delete_secondary() methods. =back If new() is successful, it will create an I object and return it. Otherwise it will return undef and return a descriptive message in Ace->error(). Certain programming errors, such as a failure to provide required arguments, cause a fatal error. =head1 OBJECT METHODS Most methods are inherited from I. The following additional methods are supported: =over 4 =item secondary() @databases = $seq->secondary; Return a list of the secondary databases currently in use, or an empty list if none. =item add_secondary() $seq->add_secondary($db1,$db2,...) Add one or more secondary databases to the list of annotation databases. Duplicate databases will be silently ignored. =item delete_secondary() $seq->delete_secondary($db1,$db2,...) Delete one or more secondary databases from the list of annotation databases. Databases not already in use will be silently ignored. =back =head1 SEE ALSO L, L, L,L, L, L, L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg Copyright (c) 1999, 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 AcePerl-1.92/Ace/Sequence/Homol.pm0000644000175000017500000000634007351455707016232 0ustar lsteinlstein# Ace::Sequence::Homol is just like Ace::Object, but has start() and end() methods package Ace::Sequence::Homol; use vars '@ISA'; @ISA = 'Ace::Object'; # 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; # my $pack = ref($self); # return $pack->new($self->db,$self->class,$self->name,$self->start,$self->end); # } #sub asString { # my $n = $_[0]->name; # "$n/$_[0]->{'start'}-$_[0]->{'end'}"; #} 1; =head1 NAME Ace::Sequence::Homol - Temporary Sequence Homology Class =head1 SYNOPSIS # Get all similarity features from an Ace::Sequence @homol = $seq->features('Similarity'); # sort by score @sorted = sort { $a->score <=> $b->score } @homol; # the last one has the highest score $best = $sorted[$#sorted]; # fetch its associated Ace::Sequence::Homol $homol = $best->target; # print out the sequence name, DNA, start and end print $homol->name,' ',$homol->start,'-',$homol->end,"\n"; print $homol->asDNA; =head1 DESCRIPTION I is a subclass of L (B L) which is specialized for returning information about a DNA or protein homology. This is a temporary placeholder for a more sophisticated homology class which will include support for alignments. =head1 OBJECT CREATION You will not ordinarily create an I object directly. Instead, objects will be created in response to an info() or group() method call on a similarity feature in an I object. If you wish to create an I object directly, please consult the source code for the I method. =head1 OBJECT METHODS Most methods are inherited from I. The following methods are also supported: =over 4 =item start() $start = $homol->start; Returns the start of the area that is similar to the I from which his homology was derived. Coordinates are relative to the target homology. =item end() $end = $homol->end; Returns the end of the area that is similar to the I from which his homology was derived. Coordinates are relative to the target homology. =item asString() $label = $homol->asString; Returns a human-readable identifier describing the nature of the feature. The format is: $name/$start-$end for example: HUMGEN13/1-67 This method is also called automatically when the object is treated in a string context. =back =head1 SEE ALSO L, L, L,L, L, L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg Copyright (c) 1999, 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 AcePerl-1.92/Ace/Sequence/GappedAlignment.pm0000644000175000017500000001112607373104576020210 0ustar lsteinlsteinpackage Ace::Sequence::GappedAlignment; use strict; use Ace; use Ace::Sequence::Feature; use vars '$AUTOLOAD'; use overload '""' => 'asString', 'fallback' => 'TRUE'; ; use vars '$VERSION'; $VERSION = '1.20'; *sub_SeqFeature = \&merged_segments; # autoload delegates everything to the Sequence feature sub AUTOLOAD { my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; my $self = shift; $self->{base}->$func_name(@_); } sub new { my $class = shift; my $segments = shift; my @segments = sort {$a->start <=> $b->start} @$segments; # find the min and max for the alignment my ($offset,$len); 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; } sub asString { shift->{base}->info; } sub type { return 'similarity'; } sub relative { my $self = shift; my $d = $self->{relative}; $self->{relative} = shift if @_; $d; } sub segments { my $self = shift; return $self->{segments} ? @{$self->{segments}} : () unless $self->relative; # otherwise, we have to handle relative coordinates my $base = $self->{base}; my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{segments}}; return $self->strand < 0 ? reverse @e : @e; } sub merged_segments { 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; __END__ =head1 NAME Ace::Sequence::GappedAlignment - Gapped alignment object =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); # get the target position for the first aligned segment ($t_start,$t_end) = ($segs[0]->target->start,$segs[0]->target->end); =head1 DESCRIPTION Ace::Sequence::GappedAlignment is a subclass of Ace::Sequence::Feature. It inherits all the methods of Ace::Sequence::Feature, but adds the ability to retrieve the positions of the aligned segments. Each segment is an Ace::Sequence::Feature, from which you can retrieve the source and target coordinates. =head1 OBJECT CREATION You will not ordinarily create an I object directly. Instead, objects will be created in response to a alignments() call to an I object. =head1 OBJECT METHODS Most methods are inherited from I. The following methods are also supported: =over 4 =item segments() @segments = $gene->segments; Return a list of Ace::Sequence::Feature objects corresponding to similar segments. =item relative() $relative = $gene->relative; $gene->relative(1); This turns on and off relative coordinates. By default, the exons and intron features will be returned in the coordinate system used by the gene. If relative() is set to a true value, then coordinates will be expressed as relative to the start of the gene. The first exon will (usually) be 1. =head1 SEE ALSO L, L, L,L, L, L, L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg Copyright (c) 1999, 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 AcePerl-1.92/Ace/Sequence/FeatureList.pm0000644000175000017500000001054407120721517017371 0ustar lsteinlsteinpackage Ace::Sequence::FeatureList; use overload '""' => 'asString'; sub new { local $^W = 0; # to prevent untrackable uninitialized variable warning 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) = @_; my $count = 0; unless ($type) { return wantarray ? grep !/^_/,keys %$self : $self->{_TOTAL}; } unless ($subtype) { return keys %{$self->{$type}} if wantarray; foreach (keys %{$self->{$type}}) { $count += $self->{$type}{$_}; } return $count; } return $self->{$type}{$subtype}; } # human-readable summary table sub asString { my $self = shift; my ($type,$subtype); for my $type ( sort $self->types() ) { for my $subtype (sort $self->types($type) ) { print join("\t",$type,$subtype,$self->{$type}{$subtype}),"\n"; } } } 1; =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; # Scalar context, 1 argument. Count this type $gene_cnt = $list->types('Predicted_gene'); print "There are $gene_cnt genes here.\n"; # Array context, 1 argument. Get list of subtypes @subtypes = $list->types('Predicted_gene'); # Two arguments. Count type & subtype $genefinder_cnt = $list->types('Predicted_gene','genefinder'); =head1 DESCRIPTION I is a small class that provides statistical information about sequence features. From it you can obtain summary counts of the features and their types within a selected region. =head1 OBJECT CREATION You will not ordinarily create an I object directly. Instead, objects will be created by calling a I object's feature_list() method. If you wish to create an I object directly, please consult the source code for the I method. =head1 OBJECT METHODS There are only two methods in I. =over 4 =item type() This method has five distinct behaviors, depending on its context and the number of parameters. Usage should be intuitive Context Arguments Behavior ------- --------- -------- scalar -none- total count of features in list array -none- list feature types (e.g. "exon") scalar type count features of this type array type list subtypes of this type -any- type,subtype count features of this type & subtype For example, this code fragment will count the number of exons present on the list: $exon_count = $list->type('exon'); This code fragment will count the number of exons found by "genefinder": $predicted_exon_count = $list->type('exon','genefinder'); This code fragment will print out all subtypes of "exon" and their counts: for my $subtype ($list->type('exon')) { print $subtype,"\t",$list->type('exon',$subtype),"\n"; } =item asString() print $list->asString; This dumps the list out in tab-delimited format. The order of columns is type, subtype, count. =back =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg Copyright (c) 1999, 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 AcePerl-1.92/Ace/Sequence/Feature.pm0000644000175000017500000002567007351455707016556 0ustar lsteinlsteinpackage Ace::Sequence::Feature; use strict; use Ace qw(:DEFAULT rearrange); use Ace::Object; use Ace::Sequence::Homol; use Carp; use AutoLoader 'AUTOLOAD'; use vars '@ISA','%REV'; @ISA = 'Ace::Sequence'; # for convenience sake only %REV = ('+1' => '-1', '-1' => '+1'); # war is peace, &c. use overload '""' => 'asString', ; # parse a line from a sequence list sub new { my $pack = shift; my ($parent,$ref,$r_offset,$r_strand,$abs,$gff_line,$db) = @_; my ($sourceseq,$method,$type,$start,$end,$score,$strand,$frame,$group) = split "\t",$gff_line; if (defined($strand)) { $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, score => $score, frame => $frame, group => $group, db => $db, } },$pack; return $self; } sub smapped { 1; } # $_[0] is field name, $_[1] is self, $_[2] is optional replacement value sub _field { my $self = shift; my $field = shift; my $v = $self->{info}{$field}; $self->{info}{$field} = shift if @_; return if defined $v && $v eq '.'; return $v; } sub strand { return $_[0]->{fstrand} } sub seqname { my $self = shift; my $seq = $self->_field('seqname'); $self->db->fetch(Sequence=>$seq); } sub method { shift->_field('method',@_) } # ... I prefer "method" sub subtype { shift->_field('method',@_) } # ... or even "subtype" sub type { shift->_field('type',@_) } # ... I prefer "type" sub score { shift->_field('score',@_) } # float indicating some sort of score sub frame { shift->_field('frame',@_) } # one of 1, 2, 3 or undef sub info { # returns Ace::Object(s) with info about the feature my $self = shift; unless ($self->{group}) { my $info = $self->{info}{group} || 'Method "'.$self->method.'"'; $info =~ s/(\"[^\"]*);([^\"]*\")/$1$;$2/g; my @data = split(/\s*;\s*/,$info); foreach (@data) { s/$;/;/g } $self->{group} = [map {$self->toAce($_)} @data]; } return wantarray ? @{$self->{group}} : $self->{group}->[0]; } # bioperl compatibility sub primary_tag { shift->type(@_) } sub source_tag { shift->subtype(@_) } sub db { # database identifier (from Ace::Sequence::Multi) my $self = shift; my $db = $self->_field('db',@_); return $db || $self->SUPER::db; } sub group { $_[0]->info; } sub target { $_[0]->info; } sub asString { my $self = shift; my $name = $self->SUPER::asString; my $type = $self->type; return "$type:$name"; } # unique ID sub id { my $self = shift; my $source = $self->source->name; my $start = $self->start; my $end = $self->end; return "$source/$start,$end"; } # map info into a reasonable set of ace objects sub toAce { my $self = shift; my $thing = shift; my ($tag,@values) = $thing=~/(\"[^\"]+?\"|\S+)/g; foreach (@values) { # strip the damn quotes s/^\"(.*)\"$/$1/; # get rid of leading and trailing quotes } return $self->tag2ace($tag,@values); } # synthesize an artificial Ace object based on the tag sub tag2ace { my $self = shift; my ($tag,@data) = @_; # Special cases, hardcoded in Ace GFF code... my $db = $self->db;; my $class = $db->class; # for Notes we just return a text, no database associated return $class->new(Text=>$data[0]) if $tag eq 'Note'; # for homols, we create the indicated Protein or Sequence object # then generate a bogus Homology object (for future compatability??) if ($tag eq 'Target') { my ($objname,$start,$end) = @data; my ($classe,$name) = $objname =~ /^(\w+):(.+)/; return Ace::Sequence::Homol->new_homol($classe,$name,$db,$start,$end); } # General case: my $obj = $class->new($tag=>$data[0],$self->db); return $obj if defined $obj; # Last resort, return a Text return $class->new(Text=>$data[0]); } sub sub_SeqFeature { return wantarray ? () : 0; } 1; =head1 NAME Ace::Sequence::Feature - Examine Sequence Feature Tables =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; $score = $feature->score; # Follow the target $target = $feature->info; # print the target's start and end positions print $target->start,'-',$target->end, "\n"; =head1 DESCRIPTION I is a subclass of L specialized for returning information about particular features in a GFF format feature table. =head1 OBJECT CREATION You will not ordinarily create an I object directly. Instead, objects will be created in response to a feature() call to an I object. If you wish to create an I object directly, please consult the source code for the I method. =head1 OBJECT METHODS Most methods are inherited from I. The following methods are also supported: =over 4 =item seqname() $object = $feature->seqname; Return the ACeDB Sequence object that this feature is attached to. The return value is an I of the Sequence class. This corresponds to the first field of the GFF format and does not necessarily correspond to the I object from which the feature was obtained (use source_seq() for that). =item source() =item method() =item subtype() $source = $feature->source; These three methods are all synonyms for the same thing. They return the second field of the GFF format, called "source" in the documentation. This is usually the method or algorithm used to predict the feature, such as "GeneFinder" or "tRNA" scan. To avoid ambiguity and enhance readability, the method() and subtype() synonyms are also recognized. =item feature() =item type() $type = $feature->type; These two methods are also synonyms. They return the type of the feature, such as "exon", "similarity" or "Predicted_gene". In the GFF documentation this is called the "feature" field. For readability, you can also use type() to fetch the field. =item abs_start() $start = $feature->abs_start; This method returns the absolute start of the feature within the sequence segment indicated by seqname(). As in the I method, use start() to obtain the start of the feature relative to its source. =item abs_start() $start = $feature->abs_start; This method returns the start of the feature relative to the sequence segment indicated by seqname(). As in the I method, you will more usually use the inherited start() method to obtain the start of the feature relative to its source sequence (the I from which it was originally derived). =item abs_end() $start = $feature->abs_end; This method returns the end of the feature relative to the sequence segment indicated by seqname(). As in the I method, you will more usually use the inherited end() method to obtain the end of the feature relative to the I from which it was derived. =item score() $score = $feature->score; For features that are associated with a numeric score, such as similarities, this returns that value. For other features, this method returns undef. =item strand() $strand = $feature->strand; Returns the strandedness of this feature, either "+1" or "-1". For features that are not stranded, returns 0. =item reversed() $reversed = $feature->reversed; Returns true if the feature is reversed relative to its source sequence. =item frame() $frame = $feature->frame; For features that have a frame, such as a predicted coding sequence, returns the frame, either 0, 1 or 2. For other features, returns undef. =item group() =item info() =item target() $info = $feature->info; These methods (synonyms for one another) return an Ace::Object containing other information about the feature derived from the 8th field of the GFF format, the so-called "group" field. The type of the Ace::Object is dependent on the nature of the feature. The possibilities are shown in the table below: Feature Type Value of Group Field ------------ -------------------- note A Text object containing the note. similarity An Ace::Sequence::Homology object containing the target and its start/stop positions. intron An Ace::Object containing the gene from exon which the feature is derived. misc_feature other A Text object containing the group data. =item asString() $label = $feature->asString; Returns a human-readable identifier describing the nature of the feature. The format is: $type:$name/$start-$end for example: exon:ZK154.3/1-67 This method is also called automatically when the object is treated in a string context. =back =head1 SEE ALSO L, L, L,L, L, L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg Copyright (c) 1999, 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 __END__ # SCRAPS # the new() code done "right" # sub new { # my $pack = shift; # my ($ref,$r_offset,$r_strand,$gff_line) = @_; # my ($sourceseq,$method,$type,$start,$end,$score,$strand,$frame,$group) = split "\t"; # ($start,$end) = ($end,$start) if $strand < 0; # my $self = $pack->SUPER::new($source,$start,$end); # $self->{info} = { # seqname=> $sourceseq, # method => $method, # type => $type, # score => $score, # frame => $frame, # group => $group, # }; # $self->{fstrand} = $strand; # return $self; # } AcePerl-1.92/Ace/Sequence/Gene.pm0000644000175000017500000000754707244015741016033 0ustar lsteinlsteinpackage Ace::Sequence::Gene; use strict; use Ace; use Ace::Sequence::Feature; use vars '$AUTOLOAD'; use overload '""' => 'asString', ; # autoload delegates everything to the Ace::Sequence::Feature object # 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 { my $self = shift; my $d = $self->{relative}; $self->{relative} = shift if @_; $d; } sub introns { my $self = shift; return $self->{intron} ? @{$self->{intron}} : () unless $self->relative; # otherwise, we have to handle relative coordinates my $base = $self->{base}; my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{intron}}; return $self->strand < 0 ? reverse @e : @e; } sub exons { my $self = shift; return $self->{exon} ? @{$self->{exon}} : () unless $self->relative; # otherwise, we have to handle relative coordinates my $base = $self->{base}; my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{exon}}; return $self->strand < 0 ? reverse @e : @e; } 1; __END__ =head1 NAME Ace::Sequence::Gene - Simple "Gene" Object =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 # get the CDSs (NOT IMPLEMENTED YET!) @cds = $genes[0]->cds; =head1 DESCRIPTION Ace::Sequence::Gene is a subclass of Ace::Sequence::Feature. It inherits all the methods of Ace::Sequence::Feature, but adds the ability to retrieve the annotated introns and exons of the gene. =head1 OBJECT CREATION You will not ordinarily create an I object directly. Instead, objects will be created in response to a genes() call to an I object. =head1 OBJECT METHODS Most methods are inherited from I. The following methods are also supported: =over 4 =item exons() @exons = $gene->exons; Return a list of Ace::Sequence::Feature objects corresponding to annotated exons. =item introns() @introns = $gene->introns; Return a list of Ace::Sequence::Feature objects corresponding to annotated introns. =item cds() @cds = $gene->cds; Return a list of Ace::Sequence::Feature objects corresponding to coding sequence. THIS IS NOT YET IMPLEMENTED. =item relative() $relative = $gene->relative; $gene->relative(1); This turns on and off relative coordinates. By default, the exons and intron features will be returned in the coordinate system used by the gene. If relative() is set to a true value, then coordinates will be expressed as relative to the start of the gene. The first exon will (usually) be 1. =head1 SEE ALSO L, L, L,L, L, L, L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg Copyright (c) 1999, 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 AcePerl-1.92/Ace/Sequence/Transcript.pm0000644000175000017500000001064207302454505017274 0ustar lsteinlsteinpackage Ace::Sequence::Transcript; use strict; use Ace; use Ace::Sequence::Feature; use vars '$AUTOLOAD'; use overload '""' => 'asString', ; # for compatibility with the Ace::Graphics::Glyph::segments glyph, and # with Bioperl SeqFeatureI: *sub_SeqFeature = *merged_segments = *segments = \&exons; # autoload delegates everything to the Sequence feature sub AUTOLOAD { 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; } sub type { return 'Transcript'; } sub relative { my $self = shift; my $d = $self->{relative}; $self->{relative} = shift if @_; $d; } sub introns { my $self = shift; return $self->{intron} ? @{$self->{intron}} : () unless $self->relative; # otherwise, we have to handle relative coordinates my $base = $self->{base}; my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{intron}}; return $self->strand < 0 ? reverse @e : @e; } sub exons { my $self = shift; return $self->{exon} ? @{$self->{exon}} : () unless $self->relative; # otherwise, we have to handle relative coordinates my $base = $self->{base}; my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{exon}}; return $self->strand < 0 ? reverse @e : @e; } sub cds { my $self = shift; return $self->{cds} ? @{$self->{cds}} : () unless $self->relative; # otherwise, we have to handle relative coordinates my $base = $self->{base}; my @e = map {Ace::Sequence->new(-refseq=>$base,-seq=>$_)} @{$self->{cds}}; return $self->strand < 0 ? reverse @e : @e; } 1; __END__ =head1 NAME Ace::Sequence::Transcript - Simple "Gene" Object =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 # get the CDSs (NOT IMPLEMENTED YET!) @cds = $genes[0]->cds; =head1 DESCRIPTION Ace::Sequence::Gene is a subclass of Ace::Sequence::Feature. It inherits all the methods of Ace::Sequence::Feature, but adds the ability to retrieve the annotated introns and exons of the gene. =head1 OBJECT CREATION You will not ordinarily create an I object directly. Instead, objects will be created in response to a transcripts() call to an I object. =head1 OBJECT METHODS Most methods are inherited from I. The following methods are also supported: =over 4 =item exons() @exons = $gene->exons; Return a list of Ace::Sequence::Feature objects corresponding to annotated exons. =item introns() @introns = $gene->introns; Return a list of Ace::Sequence::Feature objects corresponding to annotated introns. =item cds() @cds = $gene->cds; Return a list of Ace::Sequence::Feature objects corresponding to coding sequence. THIS IS NOT YET IMPLEMENTED. =item relative() $relative = $gene->relative; $gene->relative(1); This turns on and off relative coordinates. By default, the exons and intron features will be returned in the coordinate system used by the gene. If relative() is set to a true value, then coordinates will be expressed as relative to the start of the gene. The first exon will (usually) be 1. =head1 SEE ALSO L, L, L,L, L, L, L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg Copyright (c) 1999, 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 AcePerl-1.92/Ace/Graphics/0000755000175000017500000000000011106333223014560 5ustar lsteinlsteinAcePerl-1.92/Ace/Graphics/GlyphFactory.pm0000644000175000017500000001513607351455707017562 0ustar lsteinlsteinpackage 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; } $options{bgcolor} ||= 'white'; $options{fgcolor} ||= 'black'; $options{fillcolor} ||= 'turquoise'; $options{height} ||= 10; $options{font} ||= gdSmallFont; $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; } sub width { my $self = shift; my $g = $self->{width}; $self->{width} = shift if @_; $g; } # font to draw with sub font { my $self = shift; $self->option('font',@_); } # set the height for glyphs we create sub height { my $self = shift; $self->option('height',@_); } sub options { my $self = shift; my $g = $self->{options}; $self->{options} = shift if @_; $g; } sub panel { my $self = shift; my $g = $self->{panel}; $self->{panel} = shift if @_; $g; } sub option { my $self = shift; my $option_name = shift; my $o = $self->{options} or return; my $d = $o->{$option_name}; $o->{$option_name} = shift if @_; $d; } # set the foreground and background colors # expressed as GD color indices sub _fgcolor { my $self = shift; my $c = $self->option('color',@_) || $self->option('fgcolor',@_) || $self->option('outlinecolor',@_); $self->translate($c); } sub fgcolor { my $self = shift; my $linewidth = $self->option('linewidth'); return $self->_fgcolor unless defined($linewidth) && $linewidth > 1; $self->panel->set_pen($linewidth,$self->_fgcolor); return gdBrushed; } sub fontcolor { my $self = shift; my $c = $self->option('fontcolor',@_); $self->translate($c); # return $self->_fgcolor; } sub bgcolor { my $self = shift; 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); } 1; __END__ =head1 NAME Ace::Graphics::GlyphFactory - Create Ace::Graphics::Glyphs =head1 SYNOPSIS use Ace::Graphics::GlyphFactory; my $factory = Ace::Graphics::GlyphFactory($glyph_name,@options); =head1 DESCRIPTION The Ace::Graphics::GlyphFactory class is used internally by Ace::Graphics::Track and Ace::Graphics::Glyph to hold the options pertaining to a set of related glyphs and creating them on demand. This class is not ordinarily useful to the end-developer. =head1 METHODS This section describes the class and object methods for Ace::Graphics::GlyphFactory. =head2 CONSTRUCTORS There is only one constructor, the new() method. It is ordinarily called by Ace::Graphics::Track, in the make_factory() subroutine. =over 4 =item $factory = Ace::Graphics::GlyphFactory->new($glyph_name,@options) The new() method creates a new factory object. The object will create glyphs of type $glyph_name, and using the options specified in @options. Generic options are described in L, and specific options are described in each of the Ace::Graphics::Glyph::* manual pages. =back =head2 OBJECT METHODS Once a track is created, the following methods can be invoked: =over 4 =item $glyph = $factory->glyph($feature) Given a sequence feature, creates an Ace::Graphics::Glyph object to display it. The various attributes of the glyph are set from the options provided at factory creation time. =item $option = $factory->option($option_name [,$new_option]) Given an option name, returns its value. If a second argument is provided, sets the option to the new value and returns its previous one. =item $index = $factory->fgcolor Returns the desired foreground color for the glyphs in the form of an GD::Image color index. This may be the one of the special colors gdBrushed and gdStyled. This is only useful while the enclosing Ace::Graphics::Panel object is rendering the object. In other contexts it returns undef. =item $scale = $factory->scale([$scale]) Get or set the scale, in pixels/bp, for the glyph. This is ordinarily set by the Ace::Graphics::Track object just prior to rendering, and called by each glyphs' map_pt() method when performing the rendering. =item $color = $factory->bgcolor([$color]) Get or set the background color for the glyphs. =item $color = $factory->fillcolor([$color]) Get or set the fill color for the glyphs. =item $font = $factory->font([$font]) Get or set the font to use for rendering the glyph. =item $color = $factory->fontcolor Get the color for the font (to set it, use fgcolor()). This is subtly different from fgcolor() itself, because it will never return a styled color, such as gdBrushed. =item $panel = $factory->panel([$panel]) Get or set the panel that contains the GD::Image object used by this factory. =item $index = $factory->translate($color) =item @rgb = $factory->rgb($index) These are convenience procedures that are passed through to the enclosing Panel object and have the same effect as the like-named methods in that class. See L. =back =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Fk.pm0000644000175000017500000000462107306663543015503 0ustar lsteinlsteinpackage Ace::Graphics::Fk; use strict; *stop = \&end; *primary_tag = \&name; *exons = \&segments; # 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}; if (my $s = $arg{-segments}) { my @segments; for my $seg (@$s) { if (ref($seg) eq 'ARRAY') { push @segments,$class->new(-start=>$seg->[0], -stop=>$seg->[1], -strand=>$self->{strand}); } else { push @segments,$seg; } } $self->{segments} = [ sort {$a->start <=> $b->start } @segments ]; } else { $self->{start} = $arg{-start}; $self->{end} = $arg{-end} || $arg{-stop}; } $self; } sub segments { my $self = shift; my $s = $self->{segments} or return; @$s; } sub strand { shift->{strand} } sub name { shift->{name} } sub start { my $self = shift; if (my @segments = $self->segments) { return $segments[0]->start; } 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 { my $self = shift; return $self->{info} || $self->name; } 1; __END__ =head1 NAME Ace::Graphics::Fk - A dummy feature object used for generating panel key tracks =head1 SYNOPSIS None. Used internally by Ace::Graphics::Panel. =head1 DESCRIPTION None. Used internally by Ace::Graphics::Panel. =head1 SEE ALSO L,L, L,L, L =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/0000755000175000017500000000000011106333223015643 5ustar lsteinlsteinAcePerl-1.92/Ace/Graphics/Glyph/ex.pm0000644000175000017500000000355007306663464016644 0ustar lsteinlsteinpackage 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'); my $xmid = ($x1+$x2)/2; my $ymid = ($y1+$y2)/2; $gd->line($xmid-$p,$ymid-$p,$xmid+$p,$ymid+$p,$fg); $gd->line($xmid-$p,$ymid+$p,$xmid+$p,$ymid-$p,$fg); } else { $gd->line($x1,$y1,$x2,$y2,$fg); $gd->line($x1,$y2,$x2,$y1,$fg); } $self->draw_label($gd,@_) if $self->option('label'); } 1; __END__ =head1 NAME Ace::Graphics::Glyph::ex - The "X" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This glyph draws an "X". =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, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Allen Day . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/toomany.pm0000644000175000017500000000314307244575773017722 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::toomany; # DAS-compatible package to use for drawing a box use strict; use vars '@ISA'; @ISA = 'Ace::Graphics::Glyph'; # draw the thing onto a canvas # this definitely gets overridden sub draw { my $self = shift; my $gd = shift; my ($left,$top) = @_; my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries($left,$top); $self->filled_oval($gd,$x1,$y1,$x2,$y2); # add a label if requested $self->draw_label($gd,@_) if $self->option('label'); } sub label { return "too many to display"; } 1; __END__ =head1 NAME Ace::Graphics::Glyph::toomany - The "too many to show" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This glyph is intended for features that are too dense to show properly. Mostly a placeholder, it currently shows a filled oval. If you choose a bump of 0, the ovals will overlap, to give a cloud effect. =head2 OPTIONS There are no glyph-specific options. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/line.pm0000644000175000017500000000307207251014743017143 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::line; # an arrow without the arrowheads use strict; use vars '@ISA'; @ISA = 'Ace::Graphics::Glyph'; sub bottom { my $self = shift; my $val = $self->SUPER::bottom(@_); $val += $self->font->height if $self->option('tick'); $val += $self->labelheight if $self->option('label'); $val; } sub draw { my $self = shift; my $gd = shift; my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_); my $fg = $self->fgcolor; my $a2 = $self->SUPER::height/2; my $center = $y1+$a2; $gd->line($x1,$center,$x2,$center,$fg); # add a label if requested $self->draw_label($gd,@_) if $self->option('label'); } 1; __END__ =head1 NAME Ace::Graphics::Glyph::line - The "line" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This glyph draws a line parallel to the sequence segment. =head2 OPTIONS This glyph takes only the standard options. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/crossbox.pm0000644000175000017500000000056607244575773020104 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::crossbox; use strict; use vars '@ISA'; @ISA = 'Ace::Graphics::Glyph'; sub draw { my $self = shift; $self->SUPER::draw(@_); my $gd = shift; # and draw a cross through the box my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_); my $fg = $self->fgcolor; $gd->line($x1,$y1,$x2,$y2,$fg); $gd->line($x1,$y2,$x2,$y1,$fg); } 1; AcePerl-1.92/Ace/Graphics/Glyph/group.pm0000644000175000017500000001003407244575730017356 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::group; # a group of glyphs that move in a coordinated fashion # currently they are always on the same vertical level (no bumping) 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]; my $self = bless { @_, top => 0, left => 0, right => 0, leftmost => $leftmost, rightmost => $rightmost, members => \@sorted, },$class; @sorted = $self->bump; $self->{height} = $sorted[-1]->bottom - $sorted[0]->top; return $self; } sub members { my $self = shift; my $m = $self->{members} or return; return @$m; } sub move { my $self = shift; $self->SUPER::move(@_); $_->move(@_) foreach $self->members; } sub left { shift->{leftmost}->left } sub right { shift->{rightmost}->right } sub height { my $self = shift; $self->{height}; } # this is replication of code in Track.pm; # should have done a formal container/contained relationship # in order to accomodate groups sub bump { my $self = shift; my @glyphs = $self->members; my %occupied; for my $g (sort { $a->left <=> $b->left} @glyphs) { my $pos = 0; for my $y (sort {$a <=> $b} keys %occupied) { my $previous = $occupied{$y}; last if $previous->right + 2 < $g->left; # no collision at this position $pos += $previous->height + 2; # collision, so bump } $occupied{$pos} = $g; # remember where we are $g->move(0,$pos); } return sort { $a->top <=> $b->top } @glyphs; } # override draw method - draw individual subparts sub draw { my $self = shift; my $gd = shift; my ($left,$top) = @_; # bail out if this isn't the right kind of feature my @parts = $self->members; # three pixels of black, three pixels of transparent my $black = 1; my ($x1,$y1,$x2,$y2) = $parts[0]->calculate_boundaries($left,$top); my $center1 = ($y2 + $y1)/2; $gd->setStyle($black,$black,gdTransparent,gdTransparent,); for (my $i=0;$i<@parts-1;$i++) { my ($x1,$y1,$x2,$y2) = $parts[$i]->calculate_boundaries($left,$top); my ($x3,$y3,$x4,$y4) = $parts[$i+1]->calculate_boundaries($left,$top); next unless ($x3 - $x1) >= 3; $gd->line($x2+1,($y1+$y2)/2,$x3-1,($y3+$y4)/2,gdStyled); } } 1; =head1 NAME Ace::Graphics::Glyph::group - The group glyph =head1 SYNOPSIS none =head1 DESCRIPTION This is an internal glyph type, used by Ace::Graphics::Track for moving sets of glyphs around as a group. This glyph is created automatically when processing a set of features passed to Ace::Graphics::Panel->new as an array ref. =head2 OPTIONS In addition to the common options, the following glyph-specific options are recognized: Option Description Default ------ ----------- ------- -connect Whether to connect members false of the group by a dashed line. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/span.pm0000644000175000017500000000175107300100553017145 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::span; # DAS-compatible package to use for drawing a "span" use strict; use vars '@ISA'; @ISA = 'Ace::Graphics::Glyph'; 1; __END__ =head1 NAME Ace::Graphics::Glyph::box - The "span" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This draws the same thing as box. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Allen Day . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/box.pm0000644000175000017500000000314407244575773017025 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::box; # DAS-compatible package to use for drawing a box use strict; use vars '@ISA'; @ISA = 'Ace::Graphics::Glyph'; 1; __END__ =head1 NAME Ace::Graphics::Glyph::box - The "box" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This is the most basic glyph. It draws a filled box and optionally a label. =head2 OPTIONS The following options are standard among all Glyphs. See individual glyph pages for more options. Option Description Default ------ ----------- ------- -fgcolor Foreground color black -outlinecolor black Synonym for -fgcolor -bgcolor Background color white -fillcolor Interior color of filled turquoise images -linewidth Width of lines drawn by 1 glyph -height Height of glyph 10 -font Glyph font gdSmallFont -label Whether to draw a label false =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/graded_segments.pm0000644000175000017500000000776607373104576021376 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::graded_segments; # package to use for drawing anything that is interrupted # (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; } elsif ($f->can('sub_SeqFeature')) { @segments = $f->sub_SeqFeature; } else { return $self->SUPER::draw(@_); } # figure out the colors my $max_score = $self->option('max_score'); unless ($max_score) { $max_score = 0; foreach (@segments) { my $s = eval { $_->score }; $max_score = $s if $s > $max_score; } } # allocate colors my $fill = $self->fillcolor; my %segcolors; my ($red,$green,$blue) = $self->factory->rgb($fill); foreach (sort {$a->start <=> $b->start} @segments) { my $s = eval { $_->score }; unless (defined $s) { $segcolors{$_} = $fill; next; } my($r,$g,$b) = map {(255 - (255-$_) * ($s/$max_score))} ($red,$green,$blue); my $idx = $self->factory->translate($r,$g,$b); $segcolors{$_} = $idx; } # get parameters my $gd = shift; my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_); my ($left,$top) = @_; my (@boxes,@skips); for (my $i=0; $i < @segments; $i++) { my $color = $segcolors{$segments[$i]}; my ($start,$stop) = ($left + $self->map_pt($segments[$i]->start), $left + $self->map_pt($segments[$i]->end)); # probably unnecessary, but we do it out of paranaoia ($start,$stop) = ($stop,$start) if $start > $stop; push @boxes,[$start,$stop,$color]; if (my $next_segment = $segments[$i+1]) { my ($next_start,$next_stop) = ($left + $self->map_pt($next_segment->start), $left + $self->map_pt($next_segment->end)); # probably unnecessary, but we do it out of paranaoia ($next_start,$next_stop) = ($next_stop,$next_start) if $next_start > $next_stop; push @skips,[$stop+1,$next_start-1]; } } my $fg = $self->fgcolor; my $center = ($y1 + $y2)/2; # each skip becomes a simple line for my $i (@skips) { next unless $i->[1] - $i->[0] >= 1; $gd->line($i->[0],$center,$i->[1],$center,$fg); } # each segment becomes a box for my $e (@boxes) { my @rect = ($e->[0],$y1,$e->[1],$y2); my $color = $e->[2]; $gd->filledRectangle(@rect,$color); } # draw label $self->draw_label($gd,@_) if $self->option('label'); } 1; __END__ =head1 NAME Ace::Graphics::Glyph::graded_segments - The "color-coded segments" glyph =head1 SYNOPSIS See L, L and L. =head1 DESCRIPTION This is identical to the segments glyph, except that the intensity of each segment is proportional to the score of the segment. The maximum score is taken from the configuration variable max_score. If not provided, the maximum-scoring segment will be used. =head2 OPTIONS In addition to the common options, this glyph recognizes the b<-max_score> argument. =head1 BUGS Although descended from the segments glyph, this glyph cannot show the orientation of the segment. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/dot.pm0000644000175000017500000000416107300100553016770 0ustar lsteinlsteinpackage 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); if ($self->option('point')){ my $p = $self->option('point'); $gd->arc($xmid,$ymid,$p*2,$p*2,0,360,$fg); } else { $gd->arc($xmid,$ymid,$width,$height,0,360,$fg); } if ($self->option('fillcolor')){ my $c = $self->color('fillcolor'); $gd->fill($xmid,$ymid,$c); } $self->draw_label($gd,@_) if $self->option('label'); } 1; __END__ =head1 NAME Ace::Graphics::Glyph::dot - The "ellipse" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This glyph draws an ellipse the width of the scaled feature passed, and height a possibly configured height (See Ace::Graphics::Glyph). =head2 OPTIONS In addition to the common options, the following glyph-specific options are recognized: Option Description Default ------ ----------- ------- -point Whether to draw an ellipse feature width the scaled width of the feature or with radius point. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Allen Day . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/primers.pm0000644000175000017500000000545207244575730017713 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::primers; # 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) { $gd->line($x1,$center,$x2,$center,$fg); return; } # otherwise draw two pairs of arrows # --> <-- $gd->line($x1,$center,$x1 + HEIGHT,$center,$fg); $gd->line($x1 + HEIGHT,$center,$x1 + HEIGHT - $a2,$center-$a2,$fg); $gd->line($x1 + HEIGHT,$center,$x1 + HEIGHT - $a2,$center+$a2,$fg); $gd->line($x2,$center,$x2 - HEIGHT,$center,$fg); $gd->line($x2 - HEIGHT,$center,$x2 - HEIGHT + $a2,$center+$a2,$fg); $gd->line($x2 - HEIGHT,$center,$x2 - HEIGHT + $a2,$center-$a2,$fg); # connect the dots if requested if ($self->option('connect')) { my $c = $self->color('connect_color'); $gd->line($x1 + HEIGHT + 2,$center,$x2 - HEIGHT - 2,$center,$c); } # add a label if requested $self->draw_label($gd,@_) if $self->option('label'); } 1; __END__ =head1 NAME Ace::Graphics::Glyph::primers - The "STS primers" glyph =head1 SYNOPSIS See L and L. =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 two arrowheads by a line. -connect_color The color to use for the fgcolor connecting line. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/segments.pm0000644000175000017500000001277107351455707020061 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::segments; # package to use for drawing anything that is interrupted # (has the segment() method) 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; } elsif ($f->can('segments')) { @segments = $f->segments; } elsif ($f->can('sub_SeqFeature')) { @segments = $f->sub_SeqFeature; } else { return $self->SUPER::draw(@_); } # get parameters my $gd = shift; my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_); my ($left,$top) = @_; my $gray = $self->color(GRAY); my (@boxes,@skips); my $stranded = $self->option('stranded'); for (my $i=0; $i < @segments; $i++) { my ($start,$stop) = ($left + $self->map_pt($segments[$i]->start), $left + $self->map_pt($segments[$i]->end)); my $strand = 0; my $target; if ($stranded && $segments[$i]->can('target') && ($target = $segments[$i]->target) && $target->can('start')) { $strand = $target->start < $target->end ? 1 : -1; } # probably unnecessary, but we do it out of paranaoia ($start,$stop) = ($stop,$start) if $start > $stop; push @boxes,[$start,$stop,$strand]; if (my $next_segment = $segments[$i+1]) { my ($next_start,$next_stop) = ($left + $self->map_pt($next_segment->start), $left + $self->map_pt($next_segment->end)); # probably unnecessary, but we do it out of paranaoia ($next_start,$next_stop) = ($next_stop,$next_start) if $next_start > $next_stop; # fudge boxes that are within two pixels of each other if ($next_start - $stop < 2) { $boxes[-1][1] = $next_start; } push @skips,[$stop+1,$next_start-1]; } } my $fg = $self->fgcolor; my $fill = $self->fillcolor; my $center = ($y1 + $y2)/2; # each segment becomes a box for my $e (@boxes) { my @rect = ($e->[0],$y1,$e->[1],$y2); if ($e->[2] == 0 || !$stranded) { $self->filled_box($gd,@rect); } else { # $self->filled_arrow($gd,1,@rect); $self->oriented_box($gd,$e->[2],@rect); } } # each skip becomes a simple line for my $i (@skips) { next unless $i->[1] - $i->[0] >= 1; $gd->line($i->[0],$center,$i->[1],$center,$gray); } # draw label $self->draw_label($gd,@_) if $self->option('label'); } sub oriented_box { my $self = shift; my $gd = shift; my $orientation = shift; my ($x1,$y1,$x2,$y2) = @_; $self->filled_box($gd,@_); return unless $x2 - $x1 >= 4; $BRUSHES{$orientation} ||= $self->make_brush($orientation); my $top = int(1.5 + $y1 + ($y2 - $y1 - ($BRUSHES{$orientation}->getBounds)[1])/2); $gd->setBrush($BRUSHES{$orientation}); $gd->setStyle(0,0,0,1); $gd->line($x1+2,$top,$x2-2,$top,gdStyledBrushed); } sub make_brush { my $self = shift; my $orientation = shift; my $brush = GD::Image->new(3,3); my $bgcolor = $brush->colorAllocate(255,255,255); #white $brush->transparent($bgcolor); my $fgcolor = $brush->colorAllocate($self->factory->panel->rgb($self->fgcolor)); if ($orientation > 0) { $brush->setPixel(0,0,$fgcolor); $brush->setPixel(1,1,$fgcolor); $brush->setPixel(0,2,$fgcolor); } else { $brush->setPixel(1,0,$fgcolor); $brush->setPixel(0,1,$fgcolor); $brush->setPixel(1,2,$fgcolor); } $brush; } sub description { my $self = shift; $self->feature->info; } 1; __END__ =head1 NAME Ace::Graphics::Glyph::segments - The "discontinuous segments" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This glyph draws a sequence feature that consists of multiple discontinuous segments, such as the exons on a transcript or a gapped alignment. The representation is a series of filled rectangles connected by line segments. The features passed to it must either respond to the Bio::SequenceFeatureI-style subSeqFeatures() method, or the AcePerl/Das-style segments() or merged_segments() methods. =head2 OPTIONS In addition to the common options, this glyph recognizes the b<-stranded> argument. If b<-stranded> is true and the feature is an alignment (has the target() method) then the glyph will draw little arrows in the segment boxes to indicate the direction of the alignment. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/transcript.pm0000644000175000017500000001633407302454505020413 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::transcript; # package to use for drawing transcripts 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) = @_; my $implied_intron_color = $self->option('implied_intron_color') || IMPLIED_INTRON_COLOR; my $gray = $self->factory->translate($implied_intron_color); my $fg = $self->fgcolor; my $fill = $self->fillcolor; my $fontcolor = $self->fontcolor; my $curated_exon = $self->option('curatedexon') ? $self->color('curatedexon') : $fill; my $curated_intron = $self->option('curatedintron') ? $self->color('curatedintron') : $fg; my @exons = sort {$a->start<=>$b->start} $self->feature->segments; my @introns = $self->feature->introns if $self->feature->can('introns'); # fill in missing introns my (%istart,@intron_boxes,@implied_introns,@exon_boxes); foreach (@introns) { my ($start,$stop) = ($_->start,$_->end); ($start,$stop) = ($stop,$start) if $start > $stop; $istart{$start}++; my $color = $_->source_tag eq 'curated' ? $curated_intron : $fg; push @intron_boxes,[$left+$self->map_pt($start),$left+$self->map_pt($stop),$color]; } for (my $i=0; $i < @exons; $i++) { my ($start,$stop) = ($exons[$i]->start,$exons[$i]->end); ($start,$stop) = ($stop,$start) if $start > $stop; my $color = $exons[$i]->source_tag eq 'curated' ? $curated_exon : $fill; push @exon_boxes,[$left+$self->map_pt($start),my $stop_pos = $left + $self->map_pt($stop),$color]; next unless my $next_exon = $exons[$i+1]; my $next_start = $next_exon->start < $next_exon->end ? $next_exon->start : $next_exon->end; my $next_start_pos = $left + $self->map_pt($next_start); # fudge boxes that are within two pixels of each other if ($next_start_pos - $stop_pos < 2) { $exon_boxes[-1][1] = $next_start_pos; } elsif ($next_exon && !$istart{$stop+1}) { push @implied_introns,[$stop_pos,$next_start_pos,$gray]; } } my $center = ($y1 + $y2)/2; my $quarter = $y1 + ($y2-$y1)/4; # each intron becomes an angly thing for my $i (@intron_boxes,@implied_introns) { if ($i->[1] - $i->[0] > 3) { # room for the inverted "V" my $middle = $i->[0] + ($i->[1] - $i->[0])/2; $gd->line($i->[0],$center,$middle,$y1,$i->[2]); $gd->line($middle,$y1,$i->[1],$center,$i->[2]); } elsif ($i->[1]-$i->[0] > 1) { # no room, just connect $gd->line($i->[0],$quarter,$i->[1],$quarter,$i->[2]); } } # each exon becomes a box for my $e (@exon_boxes) { my @rect = ($e->[0],$y1,$e->[1],$y2); $self->filled_box($gd,@rect,$e->[2]); } my $draw_arrow = $self->option('draw_arrow'); $draw_arrow = 1 unless defined $draw_arrow; if ($draw_arrow && @exon_boxes) { # draw little arrows to indicate direction of transcription # plus strand is to the right my $a2 = ARROW/2; if ($self->feature->strand > 0) { my $s = $exon_boxes[-1][1]; $gd->line($s,$center,$s + ARROW,$center,$fg); $gd->line($s+ARROW,$center,$s+$a2,$center-$a2,$fg); $gd->line($s+ARROW,$center,$s+$a2,$center+$a2,$fg); } else { my $s = $exon_boxes[0][0]; $gd->line($s,$center,$s - ARROW,$center,$fg); $gd->line($s - ARROW,$center,$s-$a2,$center-$a2,$fg); $gd->line($s - ARROW,$center,$s-$a2,$center+$a2,$fg); } } # draw label if ($self->option('label')) { $self->draw_label($gd,@_); # draw description if (my $d = $self->description) { $gd->string($self->font,$x1,$y2,$d,$fontcolor); } } } sub description { my $self = shift; my $t = $self->feature->info; return unless ref $t; my $id = $t->Brief_identification; my $comment = $t->Locus; $comment .= $comment ? " ($id)" : $id if $id; $comment; } 1; __END__ =head1 NAME Ace::Graphics::Glyph::transcript - The "gene" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This glyph draws a series of filled rectangles connected by up-angled connectors or "hats". The rectangles indicate exons; the hats are introns. The direction of transcription is indicated by a small arrow at the end of the glyph, rightward for the + strand. The feature must respond to the exons() and optionally introns() methods, or it will default to the generic display. Implied introns (not returned by the introns() method) are drawn in a contrasting color to explicit introns. =head2 OPTIONS In addition to the common options, the following glyph-specific option is recognized: Option Description Default ------ ----------- ------- -implied_intron_color The color to use for gaps gray not returned by the introns() method. -draw_arrow Whether to draw arrowhead true indicating direction of transcription. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/anchored_arrow.pm0000644000175000017500000001262107306663464021224 0ustar lsteinlsteinpackage 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); 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; my $scale = $self->scale; my $fg = $self->fgcolor; # 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); } } } 1; __END__ =head1 NAME Ace::Graphics::Glyph::anchored_arrow - The "anchored_arrow" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This glyph draws an arrowhead which is anchored at one or both ends (has a vertical base) or has one or more arrowheads. The arrowheads indicate that the feature does not end at the edge of the picture, but continues. For example: |-----------------------------| both ends in picture <----------------------| left end off picture |----------------------------> right end off picture <------------------------------------> both ends off picture =head2 OPTIONS In addition to the standard options, this glyph recognizes the following: Option Description Default -tick draw a scale 0 -rel_coords use relative coordinates false for scale The argument for b<-tick> is an integer between 0 and 2 and has the same interpretation as the b<-tick> option in Ace::Graphics::Glyph::arrow. If b<-rel_coords> is set to a true value, then the scale drawn on the glyph will be in relative (1-based) coordinates relative to the beginning of the glyph. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/triangle.pm0000644000175000017500000000544607300100553020016 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::triangle; # DAS-compatible package to use for drawing a triangle use strict; use vars '@ISA'; @ISA = 'Ace::Graphics::Glyph'; sub draw { my $self = shift; my $gd = shift; my $fg = $self->fgcolor; my $orient = $self->option('orient') || 'S'; # find the center and vertices my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_); my $fg = $self->fgcolor; my $xmid = ($x1+$x2)/2; my $ymid = ($y1+$y2)/2; my ($vx1,$vy1,$vx2,$vy2,$vx3,$vy3) = undef; #effectively the width of the base my $p = abs($x2 - $x1); my $q = $p/2; if ($self->option('point')){ $p = $self->option('point'); $p = $p > $self->option('height') ? $self->option('height') : $p; $q = $p/2; $x1 = $xmid - $q; $x2 = $xmid + $q; $y1 = $ymid - $q; $y2 = $ymid + $q; } if ($orient eq 'N'){$vx1=$xmid-$q;$vy1=$y1;$vx2=$xmid+$q;$vy2=$y1;$vx3=$xmid;$vy3=$y2;} elsif($orient eq 'S'){$vx1=$xmid-$q;$vy1=$y2;$vx2=$xmid+$q;$vy2=$y2;$vx3=$xmid;$vy3=$y1;} elsif($orient eq 'E'){$vx1=$x2;$vy1=$y1;$vx2=$x2;$vy2=$y2;$vx3=$x2-$p;$vy3=$ymid;} elsif($orient eq 'W'){$vx1=$x1;$vy1=$y1;$vx2=$x1;$vy2=$y2;$vx3=$x1+$p;$vy3=$ymid;} # now draw the triangle $gd->line($vx1,$vy1,$vx2,$vy2,$fg); $gd->line($vx2,$vy2,$vx3,$vy3,$fg); $gd->line($vx3,$vy3,$vx1,$vy1,$fg); if ($self->option('fillcolor')){ my $c = $self->color('fillcolor'); $gd->fill($xmid,$ymid,$c); } $self->draw_label($gd,@_) if $self->option('label'); } 1; __END__ =head1 NAME Ace::Graphics::Glyph::ex - The "triangle" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This glyph draws an isoceles triangle. It is possible to draw the triangle with the base on the N, S, E, or W side. =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 L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Allen Day . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph/arrow.pm0000644000175000017500000001400307351455707017354 0ustar lsteinlsteinpackage Ace::Graphics::Glyph::arrow; # package to use for drawing an arrow use strict; use vars '@ISA'; @ISA = 'Ace::Graphics::Glyph'; sub bottom { my $self = shift; my $val = $self->SUPER::bottom(@_); $val += $self->font->height if $self->option('tick'); $val += $self->labelheight if $self->option('label'); $val; } # override draw method sub draw { my $self = shift; my $parallel = $self->option('parallel'); $parallel = 1 unless defined $parallel; $self->draw_parallel(@_) if $parallel; $self->draw_perpendicular(@_) unless $parallel; } sub draw_perpendicular { my $self = shift; my $gd = shift; my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_); my $ne = $self->option('northeast'); my $sw = $self->option('southwest'); $ne = $sw = 1 unless defined($ne) || defined($sw); # draw a perpendicular arrow at position indicated by $x1 my $fg = $self->fgcolor; my $a2 = $self->SUPER::height/4; my @positions = $x1 == $x2 ? ($x1) : ($x1,$x2); for my $x (@positions) { if ($ne) { $gd->line($x,$y1,$x,$y2,$fg); $gd->line($x-$a2,$y1+$a2,$x,$y1,$fg); $gd->line($x+$a2,$y1+$a2,$x,$y1,$fg); } if ($sw) { $gd->line($x,$y1,$x,$y2,$fg); $gd->line($x-$a2,$y2-$a2,$x,$y2,$fg); $gd->line($x+$a2,$y2-$a2,$x,$y2,$fg); } } # add a label if requested if ($self->option('label')) { $self->draw_label($gd,@_); # this draws the label aligned to the left } } sub draw_parallel { my $self = shift; my $gd = shift; my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_); my $fg = $self->fgcolor; my $a2 = $self->SUPER::height/2; my $center = $y1+$a2; my $ne = $self->option('northeast'); my $sw = $self->option('southwest'); # turn on both if neither specified $ne = $sw = 1 unless defined($ne) || defined($sw); # turn on ticks if ($self->option('tick')) { my $left = shift; my $scale = $self->scale; # 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; } while (1) { my $pixels = $interval * $scale; last if $pixels >= $mindist; $interval *= 10; } my $first_tick = $interval * int(0.5 + $self->start/$interval); for (my $i = $first_tick; $i < $self->end; $i += $interval) { my $tickpos = $left + $self->map_pt($i); $gd->line($tickpos,$gtop,$tickpos,$gbottom,$gcolor) if defined $gcolor; $gd->line($tickpos,$center-$a2,$tickpos,$center+$a2,$fg); } if ($self->option('tick') >= 2) { 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 $gd->line($x2,$center,$x2-$a2,$center+$a2,$fg); $gd->line($x2,$center,$x2-$a2,$center-$a2,$fg); } # add a label if requested $self->draw_label($gd,@_) if $self->option('label'); } 1; __END__ =head1 NAME Ace::Graphics::Glyph::arrow - The "arrow" glyph =head1 SYNOPSIS See L and L. =head1 DESCRIPTION This glyph draws arrows. Depending on options, the arrows can be labeled, be oriented vertically or horizontally, or can contain major and minor ticks suitable for use as a scale. =head2 OPTIONS In addition to the common options, the following glyph-specific options are recognized: Option Description Default ------ ----------- ------- -tick Whether to draw major 0 and minor ticks. 0 = no ticks 1 = major ticks 2 = minor ticks -parallel Whether to draw the arrow true parallel to the sequence or perpendicular to it. -northeast Whether to draw the true north or east arrowhead (depending on orientation) -southwest Whether to draw the true south or west arrowhead (depending on orientation) Set -parallel to false to display a point-like feature such as a polymorphism, or to indicate an important location. If the feature start == end, then the glyph will draw a single arrow at the designated location: ^ | Otherwise, there will be two arrows at the start and end: ^ ^ | | =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Glyph.pm0000644000175000017500000003552607351455707016237 0ustar lsteinlsteinpackage Ace::Graphics::Glyph; use strict; use GD; # 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 # any of these can be overridden safely sub factory { shift->{-factory} } sub feature { shift->{-feature} } sub fgcolor { shift->factory->fgcolor } sub bgcolor { shift->factory->bgcolor } sub fontcolor { shift->factory->fontcolor } sub fillcolor { shift->factory->fillcolor } sub scale { shift->factory->scale } sub width { shift->factory->width } sub font { shift->factory->font } sub option { shift->factory->option(shift) } 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}; } sub calculate_height { my $self = shift; my $val = $self->factory->height; $val += $self->labelheight if $self->option('label'); $val; } # change our offset sub move { my $self = shift; my ($dx,$dy) = @_; $self->{left} += $dx; $self->{top} += $dy; } # positions, in pixel coordinates sub top { shift->{top} } sub bottom { my $s = shift; $s->top + $s->height } sub left { my $self = shift; $self->{cache_left} = $self->calculate_left unless exists $self->{cache_left}; return $self->{left} + $self->{cache_left}; } sub right { my $self = shift; $self->{cache_right} = $self->calculate_right unless exists $self->{cache_right}; return $self->{left} + $self->{cache_right}; } sub calculate_left { my $self = shift; my $val = $self->{left} + $self->map_pt($self->{start} - 1); $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; my $val = $self->{left} + $self->scale * $point; my $right = $self->{left} + $self->width; $val = -1 if $val < 0; $val = $self->width if $right && $val > $right; return int $val; } sub labelheight { my $self = shift; return $self->{labelheight} ||= $self->font->height; } sub label { my $f = (my $self = shift)->feature; if (ref (my $code = $self->option('label')) eq 'CODE') { return $code->($f); } my $info = eval {$f->info}; return $info if $info; return $f->seqname if $f->can('seqname'); return $f->primary_tag; } # return array containing the left,top,right,bottom sub box { my $self = shift; return ($self->left,$self->top,$self->right,$self->bottom); } # these are the sequence boundaries, exclusive of labels and doodads sub calculate_boundaries { my $self = shift; my ($left,$top) = @_; my $x1 = $left + $self->map_pt($self->{start} - 1); $x1 = 0 if $x1 < 0; my $x2 = $left + $self->map_pt($self->{end} - 1); $x2 = 0 if $x2 < 0; my $y1 = $top + $self->{top}; $y1 += $self->labelheight if $self->option('label'); my $y2 = $y1 + $self->factory->height; $x2 = $x1 if $x2-$x1 < 1; $y2 = $y1 if $y2-$y1 < 1; return ($x1,$y1,$x2,$y2); } sub filled_box { my $self = shift; my $gd = shift; my ($x1,$y1,$x2,$y2,$color) = @_; my $fc = defined($color) ? $color : $self->fillcolor; my $linewidth = $self->option('linewidth') || 1; $gd->filledRectangle($x1,$y1,$x2,$y2,$fc); $gd->rectangle($x1,$y1,$x2,$y2,$self->fgcolor); # and fill it # $self->fill($gd,$x1,$y1,$x2,$y2); # if the left end is off the end, then cover over # the leftmost line my ($width) = $gd->getBounds; $gd->line($x1,$y1,$x1,$y2,$fc) if $x1 < 0; $gd->line($x2,$y1,$x2,$y2,$fc) if $x2 > $width; } sub filled_oval { my $self = shift; my $gd = shift; my ($x1,$y1,$x2,$y2) = @_; my $cx = ($x1+$x2)/2; my $cy = ($y1+$y2)/2; my $linewidth = $self->option('linewidth') || 1; if ($linewidth > 1) { my $pen = $self->make_pen($linewidth); # draw a box $gd->setBrush($pen); $gd->arc($cx,$cy,$x2-$x1,$y2-$y1,0,360,gdBrushed); } else { $gd->arc($cx,$cy,$x2-$x1,$y2-$y1,0,360,$self->fgcolor); } # and fill it $gd->fill($cx,$cy,$self->fillcolor); } # directional arrow sub filled_arrow { my $self = shift; my $gd = shift; my $orientation = shift; my ($x1,$y1,$x2,$y2) = @_; my ($width) = $gd->getBounds; my $indent = ($y2-$y1); if ($x2 - $x1 < $indent) { $indent = ($x2-$x1)/2; } return $self->filled_box($gd,@_) if ($orientation == 0) or ($x1 < 0 && $orientation < 0) or ($x2 > $width && $orientation > 0) or ($x2 - $x1 < $indent); my $h = ($y2-$y1)/4; # half height of terminal bar my $c = ($y2+$y1)/2; # vertical center my $fg = $self->fgcolor; my $fc = $self->fillcolor; if ($orientation > 0) { $gd->line($x1,$y1,$x2-$indent,$y1,$fg); $gd->line($x2-$indent,$y1,$x2,$c,$fg); $gd->line($x2,$c,$x2-$indent,$y2,$fg); $gd->line($x2-$indent,$y2,$x1,$y2,$fg); $gd->line($x1,$y2,$x1,$y1,$fg); $gd->line($x2,$c-$h,$x2,$c+$h+1,$fg); $gd->fillToBorder($x1+1,$c,$fg,$fc); } else { $gd->line($x1,$c,$x1+$indent+1,$y1,$fg); $gd->line($x1+$indent+1,$y1,$x2,$y1,$fg); $gd->line($x2,$y1,$x2,$y2,$fg); $gd->line($x2,$y2,$x1+$indent+1,$y2,$fg); $gd->line($x1+$indent+1,$y2,$x1,$c,$fg); $gd->line($x1,$c-$h,$x1,$c+$h+1,$fg); $gd->fillToBorder($x2-1,$c,$fg,$fc); } } sub fill { my $self = shift; my $gd = shift; my ($x1,$y1,$x2,$y2) = @_; if ( ($x2-$x1) >= 2 && ($y2-$y1) >= 2 ) { $gd->fill($x1+1,$y1+1,$self->fillcolor); } } # draw the thing onto a canvas # this definitely gets overridden sub draw { my $self = shift; my $gd = shift; my ($left,$top) = @_; my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries($left,$top); # for nice thin lines $x2 = $x1 if $x2-$x1 < 1; if ($self->option('strand_arrow')) { my $orientation = $self->feature->strand; $self->filled_arrow($gd,$orientation,$x1,$y1,$x2,$y2); } else { $self->filled_box($gd,$x1,$y1,$x2,$y2); } # 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; $gd->string($self->font,$left + $self->left,$top + $self->top,$label,$self->fontcolor); } 1; =head1 NAME Ace::Graphics::Glyph - Base class for Ace::Graphics::Glyph objects =head1 SYNOPSIS See L. =head1 DESCRIPTION Ace::Graphics::Glyph is the base class for all glyph objects. Each glyph is a wrapper around an Ace::Sequence::Feature object, knows how to render itself on an Ace::Graphics::Panel, and has a variety of configuration variables. End developers will not ordinarily work directly with Ace::Graphics::Glyph, but may want to subclass it for customized displays. =head1 METHODS This section describes the class and object methods for Ace::Graphics::Glyph. =head2 CONSTRUCTORS Ace::Graphics::Glyph objects are constructed automatically by an Ace::Graphics::GlyphFactory, and are not usually created by end-developer code. =over 4 =item $glyph = Ace::Graphics::Glyph->new(-feature=>$feature,-factory=>$factory) Given a sequence feature, creates an Ace::Graphics::Glyph object to display it. The -feature argument points to the Ace::Sequence::Feature object to display. -factory indicates an Ace::Graphics::GlyphFactory object from which the glyph will fetch all its run-time configuration information. A standard set of options are recognized. See L. =back =head2 OBJECT METHODS Once a glyph is created, it responds to a large number of methods. In this section, these methods are grouped into related categories. Retrieving glyph context: =over 4 =item $factory = $glyph->factory Get the Ace::Graphics::GlyphFactory associated with this object. This cannot be changed once it is set. =item $feature = $glyph->feature Get the sequence feature associated with this object. This cannot be changed once it is set. =back Retrieving glyph options: =over 4 =item $fgcolor = $glyph->fgcolor =item $bgcolor = $glyph->bgcolor =item $fontcolor = $glyph->fontcolor =item $fillcolor = $glyph->fillcolor These methods return the configured foreground, background, font and fill colors for the glyph in the form of a GD::Image color index. =item $width = $glyph->width Return the maximum width allowed for the glyph. Most glyphs will be smaller than this. =item $font = $glyph->font Return the font for the glyph. =item $option = $glyph->option($option) Return the value of the indicated option. =item $index = $glyph->color($color) Given a symbolic or #RRGGBB-form color name, returns its GD index. =back Retrieving information about the sequence: =over 4 =item $start = $glyph->start =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 =item $left = $glyph->left =item $bottom = $glyph->bottom =item $right = $glyph->right These methods return the top, left, bottom and right of the glyph in pixel coordinates. =item $height = $glyph->height Returns the height of the glyph. This may be somewhat larger or smaller than the height suggested by the GlyphFactory, depending on the type of the glyph. =item $scale = $glyph->scale Get the scale for the glyph in pixels/bp. =item $height = $glyph->labelheight Return the height of the label, if any. =item $label = $glyph->label Return a human-readable label for the glyph. =back These methods are called by Ace::Graphics::Track during the layout process: =over 4 =item $glyph->move($dx,$dy) Move the glyph in pixel coordinates by the indicated delta-x and delta-y values. =item ($x1,$y1,$x2,$y2) = $glyph->box Return the current position of the glyph. =back These methods are intended to be overridden in subclasses: =over 4 =item $glyph->calculate_height Calculate the height of the glyph. =item $glyph->calculate_left Calculate the left side of the glyph. =item $glyph->calculate_right Calculate the right side of the glyph. =item $glyph->draw($gd,$left,$top) Optionally offset the glyph by the indicated amount and draw it onto the GD::Image object. =item $glyph->draw_label($gd,$left,$top) Draw the label for the glyph onto the provided GD::Image object, optionally offsetting by the amounts indicated in $left and $right. =back These methods are useful utility routines: =over 4 =item $pixels = $glyph->map_pt($bases); Map the indicated base position, given in base pair units, into pixels, using the current scale and glyph position. =item $glyph->filled_box($gd,$x1,$y1,$x2,$y2) Draw a filled rectangle with the appropriate foreground and fill colors, and pen width onto the GD::Image object given by $gd, using the provided rectangle coordinates. =item $glyph->filled_oval($gd,$x1,$y1,$x2,$y2) As above, but draws an oval inscribed on the rectangle. =back =head2 OPTIONS The following options are standard among all Glyphs. See individual glyph pages for more options. Option Description Default ------ ----------- ------- -fgcolor Foreground color black -outlinecolor black Synonym for -fgcolor -bgcolor Background color white -fillcolor Interior color of filled turquoise images -linewidth Width of lines drawn by 1 glyph -height Height of glyph 10 -font Glyph font gdSmallFont -label Whether to draw a label false You may pass an anonymous subroutine to -label, in which case the subroutine will be invoked with the feature as its single argument. The subroutine must return a string to render as the label. =head1 SUBCLASSING Ace::Graphics::Glyph By convention, subclasses are all lower-case. Begin each subclass with a preamble like this one: package Ace::Graphics::Glyph::crossbox; use strict; use vars '@ISA'; @ISA = 'Ace::Graphics::Glyph'; Then override the methods you need to. Typically, just the draw() method will need to be overridden. However, if you need additional room in the glyph, you may override calculate_height(), calculate_left() and calculate_right(). Do not directly override height(), left() and right(), as their purpose is to cache the values returned by their calculating cousins in order to avoid time-consuming recalculation. A simple draw() method looks like this: sub draw { my $self = shift; $self->SUPER::draw(@_); my $gd = shift; # and draw a cross through the box my ($x1,$y1,$x2,$y2) = $self->calculate_boundaries(@_); my $fg = $self->fgcolor; $gd->line($x1,$y1,$x2,$y2,$fg); $gd->line($x1,$y2,$x2,$y1,$fg); } This subclass draws a simple box with two lines criss-crossed through it. We first call our inherited draw() method to generate the filled box and label. We then call calculate_boundaries() to return the coordinates of the glyph, disregarding any extra space taken by labels. We call fgcolor() to return the desired foreground color, and then call $gd->line() twice to generate the criss-cross. For more complex draw() methods, see Ace::Graphics::Glyph::transcript and Ace::Graphics::Glyph::segments. =head1 BUGS Please report them. =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Track.pm0000644000175000017500000002772007351455707016215 0ustar lsteinlsteinpackage Ace::Graphics::Track; # This embodies the logic for drawing a single track of features. # Features are of uniform style and are controlled by descendents of # the Ace::Graphics::Glyph class (eek!). use Ace::Graphics::GlyphFactory; use Ace::Graphics::Fk; use GD; # maybe use Carp 'croak'; use vars '$AUTOLOAD'; use strict; sub AUTOLOAD { my $self = shift; my($pack,$func_name) = $AUTOLOAD=~/(.+)::([^:]+)$/; $self->factory->$func_name(@_); } sub DESTROY { } # 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 # -1 => bump upward # 0 => no bump sub bump { my $self = shift; $self->factory->option('bump',@_); } # add a feature (or array ref of features) to the list sub add_feature { my $self = shift; my $feature = shift; if (ref($feature) eq 'ARRAY') { my $name = ++$self->{group_name}; $self->{group_ids}{$name} = $feature; } else { push @{$self->{features}},$feature; } } # link a set of features together so that they bump as a group sub add_group { my $self = shift; my $features = shift; ref($features) eq 'ARRAY' or croak("Usage: Ace::Graphics::Track->add_group(\$arrayref)"); $self->add_feature($features); } # delegate lineheight to the glyph sub lineheight { shift->{factory}->height(@_); } # the scale is horizontal, measured in pixels/bp sub scale { my $self = shift; my $g = $self->{scale}; $self->{scale} = shift if @_; $g; } sub width { 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); } # return the glyph class sub factory { my $self = shift; my $g = $self->{factory}; $self->{factory} = shift if @_; $g; } # return boxes for each of the glyphs # will be an array of four-element [$feature,l,t,r,b] arrays sub boxes { my $self = shift; my ($left,$top) = @_; $top += 0; $left += 0; my @result; my $glyphs = $self->layout; for my $g (@$glyphs) { my ($l,$t,$r,$b) = $g->box; push @result,[$g->feature,$left+$l,$top+$t,$left+$r,$top+$b]; } return wantarray ? @result : \@result; } # synthesize a key glyph sub keyglyph { my $self = shift; my $scale = 1/$self->scale; # base pairs/pixel # two segments, at pixels 0->50, 60->80 my $offset = $self->offset; my $feature = Ace::Graphics::Fk->new(-segments=>[ [ 0*$scale +$offset,50*$scale+$offset], [60*$scale+$offset, 80*$scale+$offset] ], -name => $self->option('key'), -strand => '+1'); my $factory = $self->factory->clone; $factory->scale($self->scale); $factory->width($self->width); $factory->option(label=>1); # turn on labels return $factory->glyph($feature); } # draw glyphs onto a GD object at the indicated position sub draw { my $self = shift; my ($gd,$left,$top) = @_; $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 sub layout { my $self = shift; my $force = shift || 0; return $self->{glyphs} if $self->{glyphs} && !$force; my $f = $self->{features}; my $factory = $self->factory; $factory->scale($self->scale); # set the horizontal scale $factory->width($self->width); # create singleton glyphs my @singletons = map { $factory->glyph($_) } @$f; # create linked groups of glyphs my @groups; if (my $groups = $self->{group_ids}) { my $groupfactory = Ace::Graphics::GlyphFactory->new('group'); for my $g (values %$groups) { my @g = map { $factory->glyph($_) } @$g; push @groups,$groupfactory->glyph(\@g); } } return $self->{glyphs} = [] unless @singletons || @groups; # run the bumper on the groups $self->_bump([@singletons,@groups]) if $self->bump; # merge the singletons and groups and sort them horizontally my @glyphs = sort {$a->left <=> $b->left } @singletons,map {$_->members} @groups; # If -1 bumping was allowed, then normalize so that the top glyph is at zero my ($topmost) = sort {$a->top <=> $b->top} @glyphs; my $offset = 0 - $topmost->top; $_->move(0,$offset) foreach @glyphs; $self->{groups} = \@groups; return $self->{glyphs} = \@glyphs; } # bumper - glyphs already sorted left to right sub _bump { my $self = shift; my $glyphs = shift; my $bump_direction = $self->bump; # +1 means bump down, -1 means bump up my @occupied; my $rightmost = -2; for my $g (sort { $a->left <=> $b->left} @$glyphs) { my $pos = 0; while (1) { # look for collisions last if $g->left > $rightmost + 2; my $bottom = $pos + $g->height; my $collision = 0; for my $old (@occupied) { last if $old->right + 2 < $g->left; next if $old->bottom < $pos; next if $old->top > $bottom; $collision = $old; last; } last unless $collision; if ($bump_direction > 0) { $pos += $collision->height + 2; # collision, so bump } else { $pos -= $g->height + 2; } } $g->move(0,$pos); @occupied = sort { $b->right <=> $a->right } ($g,@occupied); $rightmost = $g->right if $g->right > $rightmost; } } # return list of glyphs -- only after they are laid out sub glyphs { shift->{glyphs} } # height is determined by the layout, and cannot be externally controlled sub height { my $self = shift; return $self->{cache_height} if defined $self->{cache_height}; $self->layout; my $glyphs = $self->{glyphs} or croak "Can't lay out"; return 0 unless @$glyphs; my ($topmost) = sort { $a->top <=> $b->top } @$glyphs; my ($bottommost) = sort { $b->bottom <=> $a->bottom } @$glyphs; return $self->{cache_height} = $bottommost->bottom - $topmost->top; } sub make_factory { my ($class,$type,@options) = @_; Ace::Graphics::GlyphFactory->new($type,@options); } 1; __END__ =head1 NAME Ace::Graphics::Track - PNG graphics of Ace::Sequence::Feature objects =head1 SYNOPSIS use Ace::Sequence; use Ace::Graphics::Panel; my $db = Ace->connect(-host=>'brie2.cshl.org',-port=>2005) or die; my $cosmid = Ace::Sequence->new(-seq=>'Y16B4A', -db=>$db,-start=>-15000,-end=>15000) or die; my @transcripts = $cosmid->transcripts; my $panel = Ace::Graphics::Panel->new( -segment => $cosmid, -width => 800 ); my $track = $panel->add_track('transcript' -fillcolor => 'wheat', -fgcolor => 'black', -bump => +1, -height => 10, -label => 1); foreach (@transcripts) { $track->add_feature($_); } my $boxes = $panel->boxes; print $panel->png; =head1 DESCRIPTION The Ace::Graphics::Track class is used by Ace::Graphics::Panel to lay out a set of sequence features using a uniform glyph type. You will ordinarily work with panels rather than directly with tracks. =head1 METHODS This section describes the class and object methods for Ace::Graphics::Panel. =head2 CONSTRUCTORS There is only one constructor, the new() method. It is ordinarily called by Ace::Graphics::Panel, and not in end-developer code. =over 4 =item $track = Ace::Graphics::Track->new($glyph_name,$features,@options) The new() method creates a new track object from the provided glyph name and list of features. The arguments are similar to those in Ace::Graphics::Panel->new(). If successful new() will return a new Ace::Graphics::Track. Otherwise, it will return undef. If the specified glyph name is not a valid one, new() will throw an exception. =back =head2 OBJECT METHODS Once a track is created, the following methods can be invoked. =over 4 =item $track->add_feature($feature) This adds a new feature to the track. The feature can either be a single object that implements the Bio::SeqFeatureI interface (such as an Ace::Sequence::Feature or Das::Segment::Feature), or can be an anonymous array containing a set of related features. In the latter case, the track will attempt to keep the features in the same horizontal band and will not allow any other features to overlap. =item $track->add_group($group) This behaves the same as add_feature(), but requires that its argument be an array reference containing a list of grouped features. =item $track->draw($gd,$left,$top) Render the track on a previously-created GD::Image object. The $left and $top arguments indicate the position at which to start rendering. =item $boxes = $track->boxes($left,$top) =item @boxes = $track->boxes($left,$top) Return an array of array references indicating glyph coordinates for each of the render features. $left and $top indicate the offset for the track on the image plane. In a scalar context, this method returns an array reference of glyph coordinates. In a list context, it returns the list itself. See Ace::Graphics::Panel->boxes() for the format of the result. =back =head2 ACCESSORS The following accessor methods provide access to various attributes of the track object. Called with no arguments, they each return the current value of the attribute. Called with a single argument, they set the attribute and return its previous value. Note that in most cases you must change attributes before the track's layout() method is called. Accessor Name Description ------------- ----------- scale() Get/set the track scale, measured in pixels/bp lineheight() Get/set the height of each glyph, pixels width() Get/set the width of the track bump() Get/set the bump direction =head2 INTERNAL METHODS The following methods are used internally, but may be useful for those implementing new glyph types. =over 4 =item $glyphs = $track->layout Layout the features, and return an anonymous array of Ace::Graphics::Glyph objects that have been created and correctly positioned. Because layout is an expensive operation, calling this method several times will return the previously-cached result, ignoring any changes to track attributes. =item $height = $track->height Invokes layout() and returns the height of the track. =item $glyphs = $track->glyphs Returns the glyph cache. Returns undef before layout() and a reference to an array of glyphs after layout(). =item $factory = $track->make_factory(@options) Given a set of options (argument/value pairs), returns a Ace::Graphics::GlyphFactory for use in creating the glyphs with the desired settings. =back =head1 BUGS Please report them. =head1 SEE ALSO L,L,L, L,L =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Graphics/Panel.pm0000644000175000017500000006654607351455707016221 0ustar lsteinlsteinpackage Ace::Graphics::Panel; # This embodies the logic for drawing multiple tracks. use Ace::Graphics::Track; use GD; use Carp 'croak'; use strict; use constant KEYLABELFONT => gdSmallFont; use constant KEYSPACING => 10; # extra space between key columns use constant KEYPADTOP => 5; # extra padding before the key starts use constant KEYCOLOR => 'cornsilk'; *push_track = \&add_track; # package global 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; my $d = $self->{width}; $self->{width} = shift if @_; $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; } sub pad_bottom { my $self = shift; my $d = $self->{pad_bottom}; $self->{pad_bottom} = shift if @_; $d || 0; } sub pad_left { my $self = shift; my $d = $self->{pad_left}; $self->{pad_left} = shift if @_; $d || 0; } sub pad_right { my $self = shift; my $d = $self->{pad_right}; $self->{pad_right} = shift if @_; $d || 0; } sub add_track { my $self = shift; # due to indecision, we accept features # and/or glyph types in the first two arguments my ($features,$glyph_name) = ([],'generic'); while ( $_[0] !~ /^-/) { my $arg = shift; $features = $arg and next if ref($arg); $glyph_name = $arg and next unless ref($arg); } $self->_add_track($glyph_name,$features,+1,@_); } sub unshift_track { my $self = shift; # due to indecision, we accept features # and/or glyph types in the first two arguments my ($features,$glyph_name) = ([],'generic'); while ( (my $arg = shift) !~ /^-/) { $features = $arg and next if ref($arg); $glyph_name = $arg and next unless ref($arg); } $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; } sub height { my $self = shift; my $spacing = $self->spacing; my $key_height = $self->format_key; my $height = 0; $height += $_->height + $spacing foreach @{$self->{tracks}}; $height + $key_height + $self->pad_top + $self->pad_bottom; } sub gd { my $self = shift; return $self->{gd} if $self->{gd}; my $width = $self->width; my $height = $self->height; my $gd = GD::Image->new($width,$height); my %translation_table; for my $name ('white','black',keys %COLORS) { my $idx = $gd->colorAllocate(@{$COLORS{$name}}); $translation_table{$name} = $idx; } $self->{translations} = \%translation_table; $self->{gd} = $gd; my $offset = 0; my $pl = $self->pad_left; my $pt = $self->pad_top; for my $track (@{$self->{tracks}}) { $track->draw($gd,$pl,$offset+$pt); $offset += $track->height + $self->spacing; } $self->draw_key($gd,$pl,$offset); return $self->{gd} = $gd; } sub draw_key { my $self = shift; my ($gd,$left,$top) = @_; my $key_glyphs = $self->{key_glyphs} or return; my $color = $self->translate($self->{keycolor}); $gd->filledRectangle($left,$top,$self->width,$self->height,$color); $gd->string(KEYLABELFONT,$left,KEYPADTOP+$top,"KEY:",1); $top += KEYLABELFONT->height + KEYPADTOP; $_->draw($gd,$left,$top) foreach @$key_glyphs; } # Format the key section, and return its height sub format_key { my $self = shift; return $self->{key_height} if defined $self->{key_height}; my ($height,$width) = (0,0); my %tracks; my @glyphs; # determine how many glyphs become part of the key # and their max size for my $track (@{$self->{tracks}}) { next unless $track->option('key'); my $glyph = $track->keyglyph; $tracks{$track} = $glyph; my ($h,$w) = ($glyph->height, $glyph->right-$glyph->left); $height = $h if $h > $height; $width = $w if $w > $width; push @glyphs,$glyph; } $width += $self->{keyspacing}; # no key glyphs, no key return $self->{key_height} = 0 unless @glyphs; # now height and width hold the largest glyph, and $glyph_count # contains the number of glyphs. We will format them into a # box that is roughly 3 height/4 width (golden mean) my $rows = 0; my $cols = 0; while (++$rows) { $cols = @glyphs / $rows; $cols = int ($cols+1) if $cols =~ /\./; # round upward for fractions my $total_width = $cols * $width; my $total_height = $rows * $width; last if $total_width <= $self->width; } # move glyphs into row-major format my $spacing = $self->spacing; my $i = 0; for (my $c = 0; $c < $cols; $c++) { for (my $r = 0; $r < $rows; $r++) { my $x = $c * ($width + $spacing); my $y = $r * ($height + $spacing); next unless defined $glyphs[$i]; $glyphs[$i]->move($x,$y); $i++; } } $self->{key_glyphs} = \@glyphs; # remember our key glyphs # remember our key height return $self->{key_height} = ($height+$spacing) * $rows + KEYLABELFONT->height +KEYPADTOP; } # reverse of translate(); given index, return rgb triplet sub rgb { my $self = shift; my $idx = shift; my $gd = $self->{gd} or return; return $gd->rgb($idx); } sub translate { my $self = shift; if (@_ == 3) { # rgb triplet my $gd = $self->gd or return 1; return $gd->colorClosest(@_); } # otherwise... my $color = shift; if ($color =~ /^\#([0-9A-F]{2})([0-9A-F]{2})([0-9A-F]{2})$/i) { my $gd = $self->gd or return 1; my ($r,$g,$b) = (hex($1),hex($2),hex($3)); return $gd->colorClosest($r,$g,$b); } else { my $table = $self->{translations} or return $self->fgcolor; return $table->{$color} || 1; } } sub set_pen { my $self = shift; my ($linewidth,$color) = @_; return $self->{pens}{$linewidth} if $self->{pens}{$linewidth}; my $pen = $self->{pens}{$linewidth} = GD::Image->new($linewidth,$linewidth); my @rgb = $self->rgb($color); my $bg = $pen->colorAllocate(255,255,255); my $fg = $pen->colorAllocate(@rgb); $pen->fill(0,0,$fg); $self->{gd}->setBrush($pen); } sub png { my $gd = shift->gd; $gd->png; } sub boxes { my $self = shift; my @boxes; my $offset = 0; my $pl = $self->pad_left; my $pt = $self->pad_top; for my $track (@{$self->{tracks}}) { my $boxes = $track->boxes($pl,$offset+$pt); push @boxes,@$boxes; $offset += $track->height + $self->spacing; } return wantarray ? @boxes : \@boxes; } sub read_colors { my $class = shift; while () { chomp; last if /^__END__/; my ($name,$r,$g,$b) = split /\s+/; $COLORS{$name} = [hex $r,hex $g,hex $b]; } } sub color_names { my $class = shift; $class->read_colors unless %COLORS; return wantarray ? keys %COLORS : [keys %COLORS]; } 1; __DATA__ white FF FF FF black 00 00 00 aliceblue F0 F8 FF antiquewhite FA EB D7 aqua 00 FF FF aquamarine 7F FF D4 azure F0 FF FF beige F5 F5 DC bisque FF E4 C4 blanchedalmond FF EB CD blue 00 00 FF blueviolet 8A 2B E2 brown A5 2A 2A burlywood DE B8 87 cadetblue 5F 9E A0 chartreuse 7F FF 00 chocolate D2 69 1E coral FF 7F 50 cornflowerblue 64 95 ED cornsilk FF F8 DC crimson DC 14 3C cyan 00 FF FF darkblue 00 00 8B darkcyan 00 8B 8B darkgoldenrod B8 86 0B darkgray A9 A9 A9 darkgreen 00 64 00 darkkhaki BD B7 6B darkmagenta 8B 00 8B darkolivegreen 55 6B 2F darkorange FF 8C 00 darkorchid 99 32 CC darkred 8B 00 00 darksalmon E9 96 7A darkseagreen 8F BC 8F darkslateblue 48 3D 8B darkslategray 2F 4F 4F darkturquoise 00 CE D1 darkviolet 94 00 D3 deeppink FF 14 100 deepskyblue 00 BF FF dimgray 69 69 69 dodgerblue 1E 90 FF firebrick B2 22 22 floralwhite FF FA F0 forestgreen 22 8B 22 fuchsia FF 00 FF gainsboro DC DC DC ghostwhite F8 F8 FF gold FF D7 00 goldenrod DA A5 20 gray 80 80 80 green 00 80 00 greenyellow AD FF 2F honeydew F0 FF F0 hotpink FF 69 B4 indianred CD 5C 5C indigo 4B 00 82 ivory FF FF F0 khaki F0 E6 8C lavender E6 E6 FA lavenderblush FF F0 F5 lawngreen 7C FC 00 lemonchiffon FF FA CD lightblue AD D8 E6 lightcoral F0 80 80 lightcyan E0 FF FF lightgoldenrodyellow FA FA D2 lightgreen 90 EE 90 lightgrey D3 D3 D3 lightpink FF B6 C1 lightsalmon FF A0 7A lightseagreen 20 B2 AA lightskyblue 87 CE FA lightslategray 77 88 99 lightsteelblue B0 C4 DE lightyellow FF FF E0 lime 00 FF 00 limegreen 32 CD 32 linen FA F0 E6 magenta FF 00 FF maroon 80 00 00 mediumaquamarine 66 CD AA mediumblue 00 00 CD mediumorchid BA 55 D3 mediumpurple 100 70 DB mediumseagreen 3C B3 71 mediumslateblue 7B 68 EE mediumspringgreen 00 FA 9A mediumturquoise 48 D1 CC mediumvioletred C7 15 85 midnightblue 19 19 70 mintcream F5 FF FA mistyrose FF E4 E1 moccasin FF E4 B5 navajowhite FF DE AD navy 00 00 80 oldlace FD F5 E6 olive 80 80 00 olivedrab 6B 8E 23 orange FF A5 00 orangered FF 45 00 orchid DA 70 D6 palegoldenrod EE E8 AA palegreen 98 FB 98 paleturquoise AF EE EE palevioletred DB 70 100 papayawhip FF EF D5 peachpuff FF DA B9 peru CD 85 3F pink FF C0 CB plum DD A0 DD powderblue B0 E0 E6 purple 80 00 80 red FF 00 00 rosybrown BC 8F 8F royalblue 41 69 E1 saddlebrown 8B 45 13 salmon FA 80 72 sandybrown F4 A4 60 seagreen 2E 8B 57 seashell FF F5 EE sienna A0 52 2D silver C0 C0 C0 skyblue 87 CE EB slateblue 6A 5A CD slategray 70 80 90 snow FF FA FA springgreen 00 FF 7F steelblue 46 82 B4 tan D2 B4 8C teal 00 80 80 thistle D8 BF D8 tomato FF 63 47 turquoise 40 E0 D0 violet EE 82 EE wheat F5 DE B3 whitesmoke F5 F5 F5 yellow FF FF 00 yellowgreen 9A CD 32 __END__ =head1 NAME Ace::Graphics::Panel - PNG graphics of Ace::Sequence::Feature objects =head1 SYNOPSIS use Ace::Sequence; use Ace::Graphics::Panel; my $db = Ace->connect(-host=>'brie2.cshl.org',-port=>2005) or die; my $cosmid = Ace::Sequence->new(-seq=>'Y16B4A', -db=>$db,-start=>-15000,-end=>15000) or die; my @transcripts = $cosmid->transcripts; my $panel = Ace::Graphics::Panel->new( -segment => $cosmid, -width => 800 ); $panel->add_track(arrow => $cosmid, -bump => 0, -tick=>2); $panel->add_track(transcript => \@transcripts, -fillcolor => 'wheat', -fgcolor => 'black', -key => 'Curated Genes', -bump => +1, -height => 10, -label => 1); 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. =head1 METHODS This section describes the class and object methods for Ace::Graphics::Panel. =head2 CONSTRUCTORS There is only one constructor, the new() method. =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 of image and contents, in pixels -pad_bottom Additional whitespace between top 0 of image and bottom, in pixels -pad_left Additional whitespace between left 0 of image and contents, in pixels -pad_right Additional whitespace between right 0 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 =head2 OBJECT METHODS =over 4 =item $track = $panel->add_track($glyph,$features,@options) The add_track() method adds a new track to the image. Tracks are horizontal bands which span the entire width of the panel. Each track contains a number of graphical elements called "glyphs", each corresponding to a sequence feature. There are different glyph types, but each track can only contain a single type of glyph. Options passed to the track control the color and size of the glyphs, whether they are allowed to overlap, and other formatting attributes. The height of a track is determined from its contents and cannot be directly influenced. The first two arguments are the glyph name and an array reference containing the list of features to display. The order of the arguments is irrelevant, allowing either of these idioms: $panel->add_track(arrow => \@features); $panel->add_track(\@features => 'arrow'); The glyph name indicates how each feature is to be rendered. A variety of glyphs are available, and the number is growing. Currently, the following glyphs are available: Name Description ---- ----------- box A filled rectangle, nondirectional. ellipse A filled ellipse, nondirectional. arrow An arrow; can be unidirectional or bidirectional. It is also capable of displaying a scale with major and minor tickmarks, and can be oriented horizontally or vertically. segments A set of filled rectangles connected by solid lines. Used for interrupted features, such as gapped alignments. transcript Similar to segments, but the connecting line is a "hat" shape, and the direction of transcription is indicated by a small arrow. transcript2 Similar to transcript, but the arrow that indicates the direction of transcription is the last exon itself. primers Two inward pointing arrows connected by a line. Used for STSs. toomany A "cloud", to indicate too many features to show individually. This is a placeholder that will be replaced by something more clever, such as a histogram or density plot. group A group of related features connected by a dashed line. This is used internally by the Track class and should not be called explicitly. If the glyph name is omitted from add_track(), the "box" glyph will be used by default. The @options array is a list of name/value pairs that control the attributes of the track. The options are in turn passed to the glyphs. Each glyph has its own specialized subset of options, but some are shared by all glyphs: Option Description Default ------ ----------- ------- -glyph Glyph to use none -fgcolor Foreground color black -outlinecolor black Synonym for -fgcolor -bgcolor Background color white -fillcolor Interior color of filled turquoise images -linewidth Width of lines drawn by 1 glyph -height Height of glyph 10 -font Glyph font gdSmallFont -label Whether to draw a label false -bump Bump direction 0 -connect_groups false Connect groups by a dashed line (see below) -key Show this track in the undef key Colors can be expressed in either of two ways: as symbolic names such as "cyan" and as HTML-style #RRGGBB triples. The symbolic names are the 140 colors defined in the Netscape/Internet Explorer color cube, and can be retrieved using the Ace::Graphics::Panel->color_names() method. The background color is used for the background color of the track itself. The foreground color controls the color of lines and strings. The interior color is used for filled objects such as boxes. The -label argument controls whether or not the ID of the feature should be printed next to the feature. It is accepted by most, but not all of the glyphs. The -bump argument controls what happens when glyphs collide. By default, they will simply overlap (value 0). A -bump value of +1 will cause overlapping glyphs to bump downwards until there is room for them. A -bump value of -1 will cause overlapping glyphs to bump upwards. The -key argument declares that the track is to be shown in a key appended to the bottom of the image. The key contains a picture of a glyph and a label describing what the glyph means. The label is specified in the argument to -key. If present, the -glyph argument overrides the glyph given in the first or second argument. add_track() returns an Ace::Graphics::Track object. You can use this object to add additional features or to control the appearance of the track with greater detail, or just ignore it. Tracks are added in order from the top of the image to the bottom. To add tracks to the top of the image, use unshift_track(). Typical usage is: $panel->add_track( thistle => \@genes, -fillcolor => 'green', -fgcolor => 'black', -bump => +1, -height => 10, -label => 1); =item $track = unshift_track($glyph,$features,@options) unshift_track() works like add_track(), except that the new track is added to the top of the image rather than the bottom. B It is not uncommon to add a group of features which are logically connected, such as the 5' and 3' ends of EST reads. To group features into sets that remain on the same horizontal position and bump together, pass the sets as an anonymous array. To connect the groups by a dashed line, pass the -connect_groups argument with a true value. For example: $panel->add_track(segments => [[$abc_5,$abc_3], [$xxx_5,$xxx_3], [$yyy_5,$yyy_3]], -connect_groups => 1); =item $gd = $panel->gd The gd() method lays out the image and returns a GD::Image object containing it. You may then call the GD::Image object's png() or jpeg() methods to get the image data. =item $png = $panel->png The png() method returns the image as a PNG-format drawing, without the intermediate step of returning a GD::Image object. =item $boxes = $panel->boxes =item @boxes = $panel->boxes The boxes() method returns the coordinates of each glyph, useful for constructing an image map. In a scalar context, boxes() returns an array ref. In an list context, the method returns the array directly. Each member of the list is an anonymous array of the following format: [ $feature, $x1, $y1, $x2, $y2 ] The first element is the feature object; either an Ace::Sequence::Feature, a Das::Segment::Feature, or another Bioperl Bio::SeqFeatureI object. The coordinates are the topleft and bottomright corners of the glyph, including any space allocated for labels. =back =head2 ACCESSORS The following accessor methods provide access to various attributes of the panel object. Called with no arguments, they each return the current value of the attribute. Called with a single argument, they set the attribute and return its previous value. 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. =over 4 =item @names = Ace::Graphics::Panel->color_names Return the symbolic names of the colors recognized by the panel object. In a scalar context, returns an array reference. =item @rgb = $panel->rgb($index) Given a GD color index (between 0 and 140), returns the RGB triplet corresponding to this index. This method is only useful within a glyph's draw() routine, after the panel has allocated a GD::Image and is populating it. =item $index = $panel->translate($color) Given a color, returns the GD::Image index. The color may be symbolic, such as "turquoise", or a #RRGGBB triple, as in #F0E0A8. This method is only useful within a glyph's draw() routine, after the panel has allocated a GD::Image and is populating it. =item $panel->set_pen($width,$color) Changes the width and color of the GD drawing pen to the values indicated. This is called automatically by the GlyphFactory fgcolor() method. =back =head1 BUGS Please report them. =head1 SEE ALSO L,L, L,L, L =head1 AUTHOR Lincoln Stein . Copyright (c) 2001 Cold Spring Harbor Laboratory 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 AcePerl-1.92/Ace/Sequence.pm0000644000175000017500000011270410153343524015141 0ustar lsteinlsteinpackage Ace::Sequence; use strict; use Carp; use strict; use Ace 1.50 qw(:DEFAULT rearrange); use Ace::Sequence::FeatureList; use Ace::Sequence::Feature; use AutoLoader 'AUTOLOAD'; use vars '$VERSION'; my %CACHE; $VERSION = '1.51'; use constant CACHE => 1; use overload '""' => 'asString', cmp => 'cmp', ; # synonym: stop = end *stop = \&end; *abs = \&absolute; *source_seq = \&source; *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'], ],@_); # Object must have a parent sequence and/or a reference # sequence. In some cases, the parent sequence will be the # 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; # wheww! return $self; } # 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}; $self->{automerge} = shift if @_; $d; } # return reference sequence sub refseq { my $self = shift; my $prev = $self->{refseq}; if (@_) { my $refseq = shift; my $arrayref; BLOCK: { last BLOCK unless defined ($refseq); if (ref($refseq) && ref($refseq) eq 'ARRAY') { $arrayref = $refseq; last BLOCK; } if (ref($refseq) && ($refseq->can('smapped'))) { croak "Reference sequence has no common ancestor with sequence" unless $self->parent eq $refseq->parent; my ($a,$b,$c) = @{$refseq->{refseq}}; # $b += $refseq->offset; $b += $refseq->offset; $arrayref = [$refseq,$b,$refseq->strand]; last BLOCK; } # 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; return wantarray ? @{$prev} : $prev->[0]; } # return strand sub strand { return $_[0]->{strand} } # return reference strand sub r_strand { my $self = shift; return "+1" if $self->absolute; if (my ($ref,$r_offset,$r_strand) = $self->refseq) { return $r_strand; } else { return $self->{strand} } } sub offset { $_[0]->{offset} } sub p_offset { $_[0]->{p_offset} } sub smapped { 1; } sub type { 'Sequence' } sub subtype { } sub debug { my $self = shift; my $d = $self->{_debug}; $self->{_debug} = shift if @_; $d; } # return the database this sequence is associated with sub db { return Ace->name2db($_[0]->{db} ||= $_[0]->source->db); } sub start { my ($self,$abs) = @_; $abs = $self->absolute unless defined $abs; return $self->{p_offset} + $self->{offset} + 1 if $abs; if ($self->refseq) { my ($ref,$r_offset,$r_strand) = $self->refseq; return $r_strand < 0 ? 1 + $r_offset - ($self->{p_offset} + $self->{offset}) : 1 + $self->{p_offset} + $self->{offset} - $r_offset; } 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; } # human readable string (for debugging) sub asString { my $self = shift; if ($self->absolute) { return join '',$self->parent,'/',$self->start,',',$self->end; } elsif (my $ref = $self->refseq){ my $label = $ref->isa('Ace::Sequence::Feature') ? $ref->info : "$ref"; return join '',$label,'/',$self->start,',',$self->end; } else { join '',$self->source,'/',$self->start,',',$self->end; } } sub cmp { my ($self,$arg,$reversed) = @_; if (ref($arg) and $arg->isa('Ace::Sequence')) { my $cmp = $self->parent cmp $arg->parent || $self->start <=> $arg->start; return $reversed ? -$cmp : $cmp; } my $name = $self->asString; return $reversed ? $arg cmp $name : $name cmp $arg; } # Return the DNA sub dna { my $self = shift; return $self->{dna} if $self->{dna}; my $raw = $self->_query('seqdna'); $raw=~s/^>.*\n//m; $raw=~s/^\/\/.*//mg; $raw=~s/\n//g; $raw =~ s/\0+\Z//; # blasted nulls! my $effective_strand = $self->end >= $self->start ? '+1' : '-1'; _complement(\$raw) if $self->r_strand ne $effective_strand; return $self->{dna} = $raw; } # return a gff file sub gff { my $self = shift; my ($abs,$features) = rearrange([['ABS','ABSOLUTE'],'FEATURES'],@_); $abs = $self->absolute unless defined $abs; # can provide list of feature names, such as 'similarity', or 'all' to get 'em all # !THIS IS BROKEN; IT SHOULD LOOK LIKE FEATURE()! my $opt = $self->_feature_filter($features); my $gff = $self->_gff($opt); warn $gff if $self->debug; $self->transformGFF(\$gff) unless $abs; return $gff; } # return a GFF object using the optional GFF.pm module sub GFF { my $self = shift; my ($filter,$converter) = @_; # anonymous subs croak "GFF module not installed" unless require GFF; require GFF::Filehandle; my @lines = grep !/^\/\//,split "\n",$self->gff(@_); local *IN; local ($^W) = 0; # prevent complaint by GFF module tie *IN,'GFF::Filehandle',\@lines; my $gff = GFF::GeneFeatureSet->new; $gff->read(\*IN,$filter,$converter) if $gff; return $gff; } # Get the features table. Can filter by type/subtype this way: # features('similarity:EST','annotation:assembly_tag') sub features { my $self = shift; my ($filter,$opt) = $self->_make_filter(@_); # get raw gff file my $gff = $self->gff(-features=>$opt); # turn it into a list of features my @features = $self->_make_features($gff,$filter); if ($self->automerge) { # automatic merging # fetch out constructed transcripts and clones my %types = map {lc($_)=>1} (@$opt,@_); if ($types{'transcript'}) { push @features,$self->_make_transcripts(\@features); @features = grep {$_->type !~ /^(intron|exon)$/ } @features; } push @features,$self->_make_clones(\@features) if $types{'clone'}; if ($types{'similarity'}) { my @f = $self->_make_alignments(\@features); @features = grep {$_->type ne 'similarity'} @features; push @features,@f; } } return wantarray ? @features : \@features; } # A little bit more complex - assemble a list of "transcripts" # consisting of Ace::Sequence::Transcript objects. These objects # contain a list of exons and introns. sub transcripts { my $self = shift; my $curated = shift; my $ef = $curated ? "exon:curated" : "exon"; my $if = $curated ? "intron:curated" : "intron"; my $sf = $curated ? "Sequence:curated" : "Sequence"; my @features = $self->features($ef,$if,$sf); return unless @features; return $self->_make_transcripts(\@features); } sub _make_transcripts { my $self = shift; my $features = shift; require Ace::Sequence::Transcript; my %transcripts; for my $feature (@$features) { my $transcript = $feature->info; next unless $transcript; if ($feature->type =~ /^(exon|intron|cds)$/) { my $type = $1; push @{$transcripts{$transcript}{$type}},$feature; } elsif ($feature->type eq 'Sequence') { $transcripts{$transcript}{base} ||= $feature; } } # get rid of transcripts without exons foreach (keys %transcripts) { delete $transcripts{$_} unless exists $transcripts{$_}{exon} } # map the rest onto Ace::Sequence::Transcript objects return map {Ace::Sequence::Transcript->new($transcripts{$_})} keys %transcripts; } # Reassemble clones from clone left and right ends sub clones { my $self = shift; my @clones = $self->features('Clone_left_end','Clone_right_end','Sequence'); my %clones; return unless @clones; return $self->_make_clones(\@clones); } sub _make_clones { my $self = shift; my $features = shift; my (%clones,@canonical_clones); my $start_label = $self->strand < 0 ? 'end' : 'start'; my $end_label = $self->strand < 0 ? 'start' : 'end'; for my $feature (@$features) { $clones{$feature->info}{$start_label} = $feature->start if $feature->type eq 'Clone_left_end'; $clones{$feature->info}{$end_label} = $feature->start if $feature->type eq 'Clone_right_end'; if ($feature->type eq 'Sequence') { my $info = $feature->info; next if $info =~ /LINK|CHROMOSOME|\.\w+$/; if ($info->Genomic_canonical(0)) { push (@canonical_clones,$info->Clone) if $info->Clone; } } } foreach (@canonical_clones) { $clones{$_} ||= {}; } my @features; my ($r,$r_offset,$r_strand) = $self->refseq; my $parent = $self->parent; my $abs = $self->absolute; if ($abs) { $r_offset = 0; $r = $parent; $r_strand = '+1'; } # BAD HACK ALERT. WE DON'T KNOW WHERE THE LEFT END OF THE CLONE IS SO WE USE # THE MAGIC NUMBER -99_999_999 to mean "off left end" and # +99_999_999 to mean "off right end" for my $clone (keys %clones) { my $start = $clones{$clone}{start} || -99_999_999; my $end = $clones{$clone}{end} || +99_999_999; my $phony_gff = join "\t",($parent,'Clone','structural',$start,$end,'.','.','.',qq(Clone "$clone")); push @features,Ace::Sequence::Feature->new($parent,$r,$r_offset,$r_strand,$abs,$phony_gff); } return @features; } # Assemble a list of "GappedAlignment" objects. These objects # contain a list of aligned segments. sub alignments { my $self = shift; my @subtypes = @_; my @types = map { "similarity:\^$_\$" } @subtypes; push @types,'similarity' unless @types; return $self->features(@types); } sub segments { my $self = shift; return; } sub _make_alignments { my $self = shift; my $features = shift; require Ace::Sequence::GappedAlignment; my %homol; for my $feature (@$features) { next unless $feature->type eq 'similarity'; my $target = $feature->info; my $subtype = $feature->subtype; push @{$homol{$target,$subtype}},$feature; } # map onto Ace::Sequence::GappedAlignment objects return map {Ace::Sequence::GappedAlignment->new($homol{$_})} keys %homol; } # return list of features quickly sub feature_list { my $self = shift; return $self->{'feature_list'} if $self->{'feature_list'}; return unless my $raw = $self->_query('seqfeatures -version 2 -list'); return $self->{'feature_list'} = Ace::Sequence::FeatureList->new($raw); } # transform a GFF file into the coordinate system of the sequence sub transformGFF { my $self = shift; my $gff = shift; my $parent = $self->parent; my $strand = $self->{strand}; my $source = $self->source; my ($ref_source,$ref_offset,$ref_strand) = $self->refseq; $ref_source ||= $source; $ref_strand ||= $strand; if ($ref_strand > 0) { my $o = defined($ref_offset) ? $ref_offset : ($self->p_offset + $self->offset); # find anything that looks like a numeric field and subtract offset from it $$gff =~ s/(?p_offset - $self->offset); $$gff =~ s/(?source_seq->name; } # for compatibility with Ace::Sequence::Feature sub info { return shift->source_seq; } ###################### 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"; } sub _get_parent { my $obj = shift; # ** DANGER DANGER WILL ROBINSON! ** # This is an experiment in caching parents to speed lookups. Probably eats memory voraciously. return $CACHE{$obj} if CACHE && exists $CACHE{$obj}; my $p = $obj->get(S_Parent=>2)|| $obj->get(Source=>1); return unless $p; return CACHE ? $CACHE{$obj} = $p->fetch : $p->fetch; } 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+(.+)/; $parent ||= ''; $parent =~ s/^Sequence://; # remove this in next version of Acedb return ($parent,$pstart,$pstop); } # create subroutine that filters GFF files for certain feature types sub _make_filter { my $self = shift; my $automerge = $self->automerge; # parse out the filter my %filter; foreach (@_) { my ($type,$filter) = split(':',$_,2); if ($automerge && lc($type) eq 'transcript') { @filter{'exon','intron','Sequence','cds'} = ([undef],[undef],[undef],[undef]); } elsif ($automerge && lc($type) eq 'clone') { @filter{'Clone_left_end','Clone_right_end','Sequence'} = ([undef],[undef],[undef]); } else { push @{$filter{$type}},$filter; } } # create pattern-match sub my $sub; my $promiscuous; # indicates that there is a subtype without a type if (%filter) { my $s = "sub { my \@d = split(\"\\t\",\$_[0]);\n"; for my $type (keys %filter) { my $expr; my $subtypes = $filter{$type}; if ($type ne '') { for my $st (@$subtypes) { $expr .= defined $st ? "return 1 if \$d[2]=~/$type/i && \$d[1]=~/$st/i;\n" : "return 1 if \$d[2]=~/$type/i;\n" } } else { # no type, only subtypes $promiscuous++; for my $st (@$subtypes) { next unless defined $st; $expr .= "return 1 if \$d[1]=~/$st/i;\n"; } } $s .= $expr; } $s .= "return;\n }"; $sub = eval $s; croak $@ if $@; } else { $sub = sub { 1; } } return ($sub,$promiscuous ? [] : [keys %filter]); } # turn a GFF file and a filter into a list of Ace::Sequence::Feature objects sub _make_features { my $self = shift; my ($gff,$filter) = @_; my ($r,$r_offset,$r_strand) = $self->refseq; my $parent = $self->parent; my $abs = $self->absolute; if ($abs) { $r_offset = 0; $r = $parent; $r_strand = '+1'; } my @features = map {Ace::Sequence::Feature->new($parent,$r,$r_offset,$r_strand,$abs,$_)} grep !m@^(?:\#|//)@ && $filter->($_),split("\n",$gff); } # low level GFF call, no changing absolute to relative coordinates sub _gff { my $self = shift; my ($opt,$db) = @_; my $data = $self->_query("seqfeatures -version 2 $opt",$db); $data =~ s/\0+\Z//; return $data; #blasted nulls! } # shortcut for running a gif query sub _query { my $self = shift; my $command = shift; my $db = shift || $self->db; my $parent = $self->parent; my $start = $self->start(1); my $end = $self->end(1); ($start,$end) = ($end,$start) if $start > $end; #flippity floppity my $coord = "-coords $start $end"; # BAD BAD HACK ALERT - CHECKS THE QUERY THAT IS PASSED DOWN # ALSO MAKES THINGS INCOMPATIBLE WITH PRIOR 4.9 servers. # my $opt = $command =~ /seqfeatures/ ? '-nodna' : ''; my $opt = '-noclip'; my $query = "gif seqget $parent $opt $coord ; $command"; warn $query if $self->debug; return $db->raw_query("gif seqget $parent $opt $coord ; $command"); } # utility function -- reverse complement sub _complement { my $dna = shift; $$dna =~ tr/GATCgatc/CTAGctag/; $$dna = scalar reverse $$dna; } sub _feature_filter { my $self = shift; my $features = shift; return '' unless $features; my $opt = ''; $opt = '+feature ' . join('|',@$features) if ref($features) eq 'ARRAY' && @$features; $opt = "+feature $features" unless ref $features; $opt; } 1; =head1 NAME Ace::Sequence - Examine ACeDB Sequence Objects =head1 SYNOPSIS # open database connection and get an Ace::Object sequence use Ace::Sequence; $db = Ace->connect(-host => 'stein.cshl.org',-port => 200005); $obj = $db->fetch(Predicted_gene => 'ZK154.3'); # Wrap it in an Ace::Sequence object $seq = Ace::Sequence->new($obj); # Find all the exons @exons = $seq->features('exon'); # 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; =head1 DESCRIPTION I, and its allied classes L and L, provide a convenient interface to the ACeDB Sequence classes and the GFF sequence feature file format. Using this class, you can define a region of the genome by using a landmark (sequenced clone, link, superlink, predicted gene), an offset from that landmark, and a distance. Offsets and distances can be positive or negative. This will return an I object. Once a region is defined, you may retrieve its DNA sequence, or query the database for any features that may be contained within this region. Features can be returned as objects (using the I class), as GFF text-only dumps, or in the form of the GFF class defined by the Sanger Centre's GFF.pm module. This class builds on top of L and L. 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 you will need an active I 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 sequence objects, from other I and I 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 that points to Sequence or sequence-like object (the meaning of "sequence-like" is explained in more detail below.) The new() method will return an I object extending from the beginning of the object through to its natural end. In the named-parameter form of new(), the following arguments are recognized: =over 4 =item -source The sequence source. This must be an I 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 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 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 disjunct reference sequence, such as one on a different chromosome, will fail. =item -name As an alternative to using an I with the B<-source> argument, you may specify a source sequence using B<-name> and B<-db>. The I module will use the provided database accessor to fetch a Sequence object with the specified name. new() will return undef is no Sequence by this name is known. =item -db This argument is required if the source sequence is specified by name rather than by object reference. =back If new() is successful, it will create an I object and return it. Otherwise it will return undef and return a descriptive message in Ace->error(). Certain programming errors, such as a failure to provide required arguments, cause a fatal error. =head2 Reference Sequences and the Coordinate System When retrieving information from an I, the coordinate system is based on the sequence segment selected at object creation time. That is, the "+1" strand is the natural direction of the I 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 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 object. The other common exception occurs in Ace 4.8, where there is support for "sequence-like" objects that contain the C ("Sequence Map") tag. The C 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-containing object is passed to the I new() method, the module will again choose the smallest ACeDB Sequence object that contains both end-points of the desired region. If an I object is used to create a new I object, then the original object's source is inherited. =head1 Object Methods Once an I object is created, you can query it using the following methods: =head2 asString() $name = $seq->asString; Returns a human-readable identifier for the sequence in the form I, where "Source" is the name of the source sequence, and "start" and "end" are the endpoints of the sequence relative to the source (using 1-based indexing). This method is called automatically when the I is used in a string context. =head2 source_seq() $source = $seq->source_seq; Return the source of the I. =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 in some cases, and an I in others. Use get_parent() to traverse upwards through a uniform series of I objects upwards. =head2 refseq([$seq]) $refseq = $seq->refseq; Returns the reference sequence, if one is defined. $seq->refseq($new_ref); Set the reference sequence. The reference sequence must share the same ancestor with $seq. =head2 start() $start = $seq->start; Start of this sequence, relative to the source sequence, using 1-based indexing. =head2 end() $end = $seq->end; End of this sequence, relative to the source sequence, using 1-based indexing. =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() $name = $seq->name; Return the name of the source sequence as a string. =head2 get_parent() $parent = $seq->parent; Return the immediate ancestor of this I (i.e., the sequence that contains this one). The return value is a new I or undef, if no parent sequence exists. =head2 get_children() @children = $seq->get_children(); Returns all subsequences that exist as independent objects in the ACeDB database. What exactly is returned is dependent on the data model. In older ACeDB databases, the only subsequences are those under the catchall Subsequence tag. In newer ACeDB databases, the objects returned correspond to objects to the right of the S_Child subtag using a tag[2] syntax, and may include Predicted_genes, Sequences, Links, or other objects. The return value is a list of I objects. =head2 features() @features = $seq->features; @features = $seq->features('exon','intron','Predicted_gene'); @features = $seq->features('exon:GeneFinder','Predicted_gene:hand.*'); features() returns an array of I objects. If called without arguments, features() returns all features that cross the sequence region. You may also provide a filter list to select a set of features by type and subtype. The format of the filter list is: type:subtype Where I is the class of the feature (the "feature" field of the GFF format), and I is a description of how the feature was derived (the "source" field of the GFF format). Either of these fields can be absent, and either can be a regular expression. More advanced filtering is not supported, but is provided by the Sanger Centre's GFF module. The order of the features in the returned list is not specified. To obtain features sorted by position, use this idiom: @features = sort { $a->start <=> $b->start } $seq->features; =head2 feature_list() my $list = $seq->feature_list(); This method returns a summary list of the features that cross the sequence in the form of a L object. From the L object you can obtain the list of feature names and the number of each type. The feature list is obtained from the ACeDB server with a single short transaction, and therefore has much less overhead than features(). See L for more details. =head2 transcripts() This returns a list of Ace::Sequence::Transcript objects, which are specializations of Ace::Sequence::Feature. See L for details. =head2 clones() This returns a list of Ace::Sequence::Feature objects containing reconstructed clones. This is a nasty hack, because ACEDB currently records clone ends, but not the clones themselves, meaning that we will not always know both ends of the clone. In this case the missing end has a synthetic position of -99,999,999 or +99,999,999. Sorry. =head2 gff() $gff = $seq->gff(); $gff = $seq->gff(-abs => 1, -features => ['exon','intron:GeneFinder']); This method returns a GFF file as a scalar. The following arguments are optional: =over 4 =item -abs Ordinarily the feature entries in the GFF file will be returned in coordinates relative to the start of the I object. Position 1 will be the start of the sequence object, and the "+" strand will be the sequence object's natural orientation. However if a true value is provided to B<-abs>, the coordinate system used will be relative to the start of the source sequence, i.e. the native ACeDB Sequence object (usually a cosmid sequence or a link). If a reference sequence was provided when the I was created, it will be used by default to set the coordinate system. Relative coordinates can be reenabled by providing a false value to B<-abs>. Ordinarily the coordinate system manipulations automatically "do what you want" and you will not need to adjust them. See also the abs() method described below. =item -features The B<-features> argument filters the features according to a list of types and subtypes. The format is identical to the one described for the features() method. A single filter may be provided as a scalar string. Multiple filters may be passed as an array reference. =back See also the GFF() method described next. =head2 GFF() $gff_object = $seq->gff; $gff_object = $seq->gff(-abs => 1, -features => ['exon','intron:GeneFinder']); The GFF() method takes the same arguments as gff() described above, but it returns a I object from the GFF.pm module. If the GFF module is not installed, this method will generate a fatal error. =head2 absolute() $abs = $seq->absolute; $abs = $seq->absolute(1); This method controls whether the coordinates of features are returned in absolute or relative coordinates. "Absolute" coordinates are relative to the underlying source or reference sequence. "Relative" coordinates are relative to the I object. By default, coordinates are relative unless new() was provided with a reference sequence. This default can be examined and changed using absolute(). =head2 automerge() $merge = $seq->automerge; $seq->automerge(0); This method controls whether groups of features will automatically be merged together by the features() call. If true (the default), then the left and right end of clones will be merged into "clone" features, introns, exons and CDS entries will be merged into Ace::Sequence::Transcript objects, and similarity entries will be merged into Ace::Sequence::GappedAlignment objects. =head2 db() $db = $seq->db; Returns the L database accessor associated with this sequence. =head1 SEE ALSO L, L, L, L, L =head1 AUTHOR Lincoln Stein with extensive help from Jean Thierry-Mieg Many thanks to David Block for finding and fixing the nasty off-by-one errors. Copyright (c) 1999, 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 __END__ AcePerl-1.92/Ace/SocketServer.pm0000644000175000017500000001306410231520035015776 0ustar lsteinlsteinpackage Ace::SocketServer; require 5.004; use strict; use Carp 'croak','cluck'; use Ace qw(rearrange STATUS_WAITING STATUS_PENDING STATUS_ERROR); use IO::Socket; use Digest::MD5 'md5_hex'; use vars '$VERSION'; $VERSION = '1.01'; use constant DEFAULT_USER => 'anonymous'; # anonymous user use constant DEFAULT_PASS => 'guest'; # anonymous password use constant DEFAULT_TIMEOUT => 120; # two minute timeout on queries # header information use constant HEADER => 'L5a30'; use constant HEADER_LEN => 5*4+30; use constant ACESERV_MSGREQ => "ACESERV_MSGREQ"; use constant ACESERV_MSGDATA => "ACESERV_MSGDATA"; use constant WORDORDER_MAGIC => 0x12345678; # Server only, it may just be sending or a reply or it may be sending an # instruction, such as "operation refused". use constant ACESERV_MSGOK => "ACESERV_MSGOK"; use constant ACESERV_MSGENCORE => "ACESERV_MSGENCORE"; use constant ACESERV_MSGFAIL => "ACESERV_MSGFAIL"; use constant ACESERV_MSGKILL => "ACESERV_MSGKILL"; use constant ACESERV_CLIENT_HELLO => "bonjour"; 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 { my $self = shift; return if $self->{last_msg} eq ACESERV_MSGKILL; $self->_send_msg('quit'); # Is _recv_msg() bringing things down in flames? Maybe! my ($msg,$body) = $self->_recv_msg('strip'); warn "Did not get expected ACESERV_MSGKILL message, got $msg instead" if defined($msg) and $msg ne ACESERV_MSGKILL; } sub encore { return shift->{encoring} } sub status { shift->{status} } sub error { $Ace::Error; } sub query { my $self = shift; my ($request,$parse) = @_; warn "query($request)" if Ace->debug; unless ($self->_send_msg($request,$parse)) { $self->{status} = STATUS_ERROR; return _error("Write to socket server failed: $!"); } $self->{status} = STATUS_PENDING; $self->{encoring} = 0; return 1; } sub read { my $self = shift; return _error("No pending query") unless $self->status == STATUS_PENDING; $self->_do_encore || return if $self->encore; # call select() here to time out if ($self->{timeout}) { my $rdr = ''; vec($rdr,fileno($self->{socket}),1) = 1; my $result = select($rdr,undef,undef,$self->{timeout}); return _error("Query timed out") unless $result; } my ($msg,$body) = $self->_recv_msg; return unless defined $msg; $msg =~ s/\0.+$//; # socketserver bug workaround: get rid of junk in message if ($msg eq ACESERV_MSGOK or $msg eq ACESERV_MSGFAIL) { $self->{status} = STATUS_WAITING; $self->{encoring} = 0; } elsif ($msg eq ACESERV_MSGENCORE) { $self->{status} = STATUS_PENDING; # not strictly necessary, but helpful to document $self->{encoring} = 1; } else { $self->{status} = STATUS_ERROR; return _error($body); } return $body; } sub write { my $self = shift; my $data = shift; unless ($self->_send_msg($data,1)) { $self->{status} = STATUS_ERROR; return _error("Write to socket server failed: $!"); } $self->{status} = STATUS_PENDING; $self->{encoring} = 0; return 1; } sub _error { $Ace::Error = shift; return; } # return socket (read only) sub socket { $_[0]->{socket} } # ----------------------------- low level ------------------------------- sub _do_encore { my $self = shift; unless ($self->_send_msg('encore')) { $self->{status} = STATUS_ERROR; return _error("Write to socket server failed: $!"); } $self->{status} = STATUS_PENDING; return 1; } sub _handshake { my $self = shift; my ($user,$pass) = @_; $self->_send_msg(ACESERV_CLIENT_HELLO); my ($msg,$nonce) = $self->_recv_msg('strip'); return unless $msg eq ACESERV_MSGOK; # hash username and password my $authdigest = md5_hex(md5_hex($user . $pass).$nonce); $self->_send_msg("$user $authdigest"); my $body; ($msg,$body) = $self->_recv_msg('strip'); return _error("server: $body") unless $body eq ACESERV_SERVER_HELLO; return 1; } sub _send_msg { 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__ AcePerl-1.92/GFF/0000755000175000017500000000000011106333223012732 5ustar lsteinlsteinAcePerl-1.92/GFF/Filehandle.pm0000644000175000017500000000051407120721623015331 0ustar lsteinlstein# 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; AcePerl-1.92/RPC/0000755000175000017500000000000011106333223012754 5ustar lsteinlsteinAcePerl-1.92/RPC/RPC.h0000644000175000017500000000051507121254525013563 0ustar lsteinlstein#ifndef ACEPERL_H #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 AcePerl-1.92/RPC/RPC.pm0000644000175000017500000000144107121462325013746 0ustar lsteinlsteinpackage Ace::RPC; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD); use Carp 'croak'; require Exporter; require DynaLoader; @ISA = qw(Exporter DynaLoader); # Items to export into callers namespace by default. @EXPORT = qw(); # Optional exports @EXPORT_OK = qw( ACE_INVALID ACE_OUTOFCONTEXT ACE_SYNTAXERROR ACE_UNRECOGNIZED ACE_PARSE ); $VERSION = '1.00'; sub AUTOLOAD { my $constname; ($constname = $AUTOLOAD) =~ s/.*:://; my $val = constant($constname, 0); if ($! != 0) { if ($! =~ /Invalid/) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { croak "Your vendor has not defined constant $constname"; } } eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } bootstrap Ace::RPC $VERSION; 1; __END__ AcePerl-1.92/RPC/RPC.xs0000644000175000017500000001227407121466237014000 0ustar lsteinlstein#ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef __cplusplus } #endif #include "aceclient.h" #include "RPC.h" #define CHUNKSIZE 10 static int not_here(s) char *s; { croak("%s not implemented on this architecture", s); return -1; } static double constant(name, arg) char *name; int arg; { errno = 0; switch (*name) { case 'A': if (strEQ(name, "ACE_INVALID")) #ifdef ACE_INVALID return ACE_INVALID; #else goto not_there; #endif if (strEQ(name, "ACE_OUTOFCONTEXT")) #ifdef ACE_OUTOFCONTEXT return ACE_OUTOFCONTEXT; #else goto not_there; #endif if (strEQ(name, "ACE_SYNTAXERROR")) #ifdef ACE_SYNTAXERROR return ACE_SYNTAXERROR; #else goto not_there; #endif if (strEQ(name, "ACE_UNRECOGNIZED")) #ifdef ACE_UNRECOGNIZED return ACE_UNRECOGNIZED; #else goto not_there; #endif if (strEQ(name, "ACE_PARSE")) #ifdef ACE_PARSE return ACE_PARSE; #else goto not_there; #endif break; case 'B': break; case 'C': break; case 'D': if (strEQ(name, "DEFAULT_PORT")) #ifdef DEFAULT_PORT return DEFAULT_PORT; #else goto not_there; #endif if (strEQ(name, "DROP_ENCORE")) #ifdef DROP_ENCORE return DROP_ENCORE; #else goto not_there; #endif break; case 'E': break; case 'F': break; case 'G': break; case 'H': if (strEQ(name, "HAVE_ENCORE")) #ifdef HAVE_ENCORE return HAVE_ENCORE; #else goto not_there; #endif break; case 'I': break; case 'J': break; case 'K': break; case 'L': break; case 'M': break; case 'N': break; case 'O': break; case 'P': break; case 'Q': break; case 'R': break; case 'S': if (strEQ(name, "STATUS_WAITING")) #ifdef STATUS_WAITING return STATUS_WAITING; #else goto not_there; #endif if (strEQ(name, "STATUS_PENDING")) #ifdef STATUS_PENDING return STATUS_PENDING; #else goto not_there; #endif if (strEQ(name, "STATUS_ERROR")) #ifdef STATUS_ERROR return STATUS_ERROR; #else goto not_there; #endif break; case 'T': break; case 'U': break; case 'V': break; case 'W': if (strEQ(name, "WANT_ENCORE")) #ifdef WANT_ENCORE return WANT_ENCORE; #else goto not_there; #endif break; case 'X': break; case 'Y': break; case 'Z': break; case '_': if (strEQ(name, "_ACECLIENT_")) #ifdef _ACECLIENT_ return _ACECLIENT_; #else goto not_there; #endif break; } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } MODULE = Ace::RPC PACKAGE = Ace::RPC double constant(name,arg) char * name int arg AceDB* connect(CLASS, host, rpc_port, timeOut=120, ...) char* CLASS char* host unsigned long rpc_port int timeOut PREINIT: ace_handle* ace; CODE: RETVAL = (AceDB*) safemalloc(sizeof(AceDB)); if (RETVAL == NULL) XSRETURN_UNDEF; RETVAL->encoring = FALSE; RETVAL->status = STATUS_WAITING; RETVAL->answer = NULL; RETVAL->errcode = 0; ace = openServer(host,rpc_port,timeOut); if (ace == NULL) { safefree(RETVAL); XSRETURN_UNDEF; } else { RETVAL->database = ace; } OUTPUT: RETVAL void DESTROY(self) AceDB* self CODE: if (self->answer != NULL) free((void*) self->answer); if (self->database != NULL) closeServer(self->database); safefree((char*)self); ace_handle* handle(self) AceDB* self CODE: RETVAL = self->database; OUTPUT: RETVAL int encore(self) AceDB* self CODE: RETVAL = self->encoring; OUTPUT: RETVAL int error(self) AceDB* self CODE: RETVAL = self->errcode; OUTPUT: RETVAL int status(self) AceDB* self CODE: RETVAL = self->status; 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; } AcePerl-1.92/RPC/Makefile.PL0000644000175000017500000000160407565000076014742 0ustar lsteinlsteinuse ExtUtils::MakeMaker; use Config; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. $headers = "../acelib/wh"; WriteMakefile( 'NAME' => 'Ace::RPC', 'VERSION_FROM' => 'RPC.pm', # finds $VERSION 'DEFINE' => '', 'MYEXTLIB' => '../acelib/libaceperl.a', 'LIBS' => ['-lc'], 'OBJECT' => '$(O_FILES)', 'XSPROTOARG' => '-noprototypes', 'XS' => { 'RPC.xs' => 'RPC.c' }, 'INC' => "-I$headers", ); sub MY::postamble { my $definition = guess_definition(); warn "Using $definition definitions to build ace library.\n"; " \$(MYEXTLIB): ../acelib/Makefile cd ../acelib && \$(MAKE) ACEDB_MACHINE=$definition all "; } sub guess_definition { return $ENV{ACEDB_MACHINE} if $ENV{ACEDB_MACHINE}; return uc $Config{osname}; } AcePerl-1.92/docs/0000755000175000017500000000000011106333223013260 5ustar lsteinlsteinAcePerl-1.92/docs/ACE_SERVER_TRAPS.HOWTO.html0000644000175000017500000001533706745650273017531 0ustar lsteinlstein Troubleshooting a new ACE Database NOTE: These notes were put together by Sarah Yurman, a programmer at Spatial Focus, while setting up her first ACEDB server. She has contributed these notes in the hope that they will help other programmers to avoid the traps that she stumbled into. Another important document to consult is wrpc/SERVER.INSTALLATION, part of the ACeDB source distribution.

Troubleshooting a new ACE Database

Introduction
May 25, 1999

This is a list of things great and small that we have discovered while implementing a new ACE database at Spatial Focus. We are working with ACE in Linux, at the time of this writing we are using Redhat 5.2.

Caveat Emptor

This document is a work in progress. It is being written while we are solving problems. Its primary purpose is to maintain a record for internal use at Spatial Focus. Although we don't deliberately make mistakes, anything in this document could be wrong. Mistakes will be corrected as they are found. We are not responsible for any harm resulting from information we record here.

Merci!

Many thanks to Lincoln Stein and all the folks at the Human Genome Project.

Contents

Environment Description

Installation

ACEDB
  • ACEDB and environment variables
  • Permissions

Gifaceserver
  • inetd.conf
  • server.log

Models

Editors

White Space

To Do

Environment Description

These notes refer to the following environment:

  • ACEDB: 4.7g, loaded from the Linux binary (bin.linux_libc6.4_7g.tar.Z)
  • Perl 5.005_03
  • CGI.pm 2.51
  • AcePerl 1.54
  • Gifaceserver loaded from gifaceserver.LINUX
  • Apache 1.3
    (This is just for local use, so upgrading hasn't been a priority)
  • Netscape 4.51
  • Linux (Redhat 5.2)
  • bash shell

Installation:
ACEDB

ACEDB and environment variables

Problem

If nothing works, chances are the environment variables haven't been set. The acedb and textdb scripts built by INSTALL wouldn't work due to the differences in shells. acedb sets environment variables called $ACEDB and $DBDIR, and appends your path, then starts the xace graphical interface to ACEDB. textdb sets the environment variables and starts the tace text interface.

Solution

I altered my .bash_profile with the following lines:

ACEDB=[pathname to database]
DBDIR=[pathname to database]/database/
PATH=$PATH:[pathname to ace software directory]/bin
export ACEDB
export DBDIR
(PATH was already exported)

Testing the Solution

Use the echo command to make sure the environment variables are in place. We put our "contacts" database under /home/httpd because that directory is accessible to the web server. This is a requirement of AceBrowser, which we want to use as the primary interface.

A test of the $ACEDB environment variable looks like this:
echo $ACEDB (return)

It returns this:
/home/httpd/database/contacts/

Consequences of the Solution

The NOTES file distributed with this version of ACEDB advises you to move the acedb and textace scripts to /usr/local/bin, and using them to start the program. With your environment variables in place, you can simply use xace or tace instead.

Permissions

Take your permissions seriously. Richard Durbin's Installation Guide is out of date, but gives good advice in this department.

Gifaceserver
Warning: this isn't yet working completely

Problem

Most documentation dealing with this software simply tells you to get it going. The software comes with no documentation whatsoever. No README at all. There is a manual that comes in /acedocs called aceserver.html. Its installation instructions don't work on version 4.7g.

Solution

The best installation information is in the README file for AcePerl-1.54. A few more hints are listed here.

The AcePerl README file implies creating a user called acedb. This creates permissions problems that we haven't solved yet. We are using individual user names instead.

One thing that no documentation mentions is that we had to move gifaceserver.LINUX to /usr/local/bin/gifaceserver. Obvious, but still makes you wonder while you do it.

Inetd.conf

Our individual inetd.conf files were completely commented out, and the daemon stopped because of our dispersed locations. Append the required line to the file, and enter:

Killall -HUP inetd

server.log

The server really wants a server.log file, writable by the user to whom the gifaceserver is assigned in the inetd.conf file. We created one by opening the gifaceserver on a fake port number (12345):

/usr/local/bin/gifaceserver /home/httpd/database/contacts 12345 1200:1200:10

Models

Documentation

The best documentation for models is in /acedocs/exploring/*. The table of contents is in /acedocs/exploring/toc_models.html. Unfortunately, like all the ACEDB documentation, it uses absolute pathnames. We have converted these pathnames to relative ones, and will make the document available for download on the Spatial Focus private web page. Although the document is marked "draft" and dated 1994, it is thorough and simple. Doesn't appear to be significantly out of date.

The moviedb database is the best simple example of a database.

Editors

ACEDB is picky about its ascii. vi works great. Can't vouch for emacs ;-). Don't use anything nasty like a word processor.

White Space

It really likes alignment, and it likes tabs. Combining tabs and spaces kills otherwise perfectly good models every five seconds.

To Do

Solve the mysteries of the failure of AceBrowser. Every other means of access works now.

AcePerl-1.92/docs/README0000644000175000017500000000032306745650411014154 0ustar lsteinlsteinThe HOWTO documents are notes on installing and using the ACeDB database. The various .html documents are HTMLized versions of the AcePerl man pages that have been run through pod2html. Lincoln Stein July 1999AcePerl-1.92/docs/ACEDB.HOWTO0000644000175000017500000003203407657745603014733 0ustar lsteinlstein ACEDB HOWTO ACeDB is poorly documented and very intimidating to the new user. Despite this, it is not hard to install the database and get it running. OBTAINING THE SOFTWARE ACeDB is available in both binary and source code form. I strongly recommend that you install the server from source code. The source distributions tend to be more up to date than the binary distributions, and subtle differences between shared libraries can cause ACeDB binaries linked on one platform to behave differently on another. ACeDB distributions are available at: ftp://ftp.wormbase.org/pub/wormbase/software/ ftp://ncbi.nlm.nih.gov/repository/acedb/ I recommend that you use the ftp.wormbase.org URL, as this contains the latest stable snapshot of ACeDB that I use for testing and debugging the current release of AcePerl. COMPILING THE SOFTWARE Unpack the software into its own directory: 1) mkdir acedb 2) gunzip -c acedb-latest.tar.gz | tar xvf - Compile the software. The makefile requires that an environment variable named ACEDB_MACHINE be defined. This environment variable is in turn used to select the makefile to be used to compile. To figure out what to set this environment variable to, type "make". You will receive an error message listing the alternatives. Choose one for your system, and run "make again". 3) cd acedb 4) make (error message listing possibilities) 5) setenv ACEDB_MACHINE LINUX_4 (for example) 6) make This will create a subdirectory named bin.LINUX_4 (or whatever your operating system is), containing the executables along with a number of other files. INSTALLING THE SOFTWARE ACeDB runs as an Internet server. As such, it should not be run as root, but as an unprivileged user. My strategy has been to create a new user and group, both named "acedb". The server runs as "acedb", and all database developers belong to the "acedb" group, giving them write access to the database files. After creating the acedb user, create a "bin" directory and copy the executables into it: 1) cd ~acedb 2) mkdir bin 3) cd ~/acedb (where the source code was compiled) 4) cd bin.LINUX_4 (or whatever) 5) cp xace tace giface saceserver sgifaceserver makeUserPasswd ~acedb/bin/ Now put ~acedb/bin on your path so that the Ace::Local module can find the giface and tace programs. This usually involves editing .cshrc or .bashrc to change the PATH variable. (See your system administrator if you don't know how to do this). CREATING DATABASES Each ACeDB database lives in a separate subdirectory, which I conventionally place under ~acedb/. You will often be installing a compressed database archive, such as the C. elegans database (see the NCBI FTP site). In this case, simply unpack the database into the ~acedb/ directory. Programs like xace, tace, and the servers will refer to the database by its path. Within the database directory should be the subdirectories databases/, wspec/, wdoc/, wgf/, wquery/, and possibly others. If not, make sure that you unpacked the database package correctly. Now examine and edit the file ~acedb/wspec/passwd.wrm. This contains the names of user accounts that are allowed to write to the database. Make this file readable by everyone, but only writable by you (and other trusted users). If you will be running an ACeDB server, you should examine the file ~acedb/wspec/server.wrm. This contains read and write policies for the server. You can restrict who can read and write to the database, although currently you are limited to restricting read and write privileges to local users versus non-local users. Creating a new database from scratch is somewhat more difficult, because you have to create an appropriate models (schema) file. Please see NEW_DB.HOWTO for help. Now confirm that the database is correctly installed by running the xace program. xace ~acedb/elegans (or whatever) You should be able browse the data, view graphics, and so on. INSTALLING AN ACE SERVER ACEDB comes with two servers called "saceserver" and "sgifaceserver". The difference between the two is that sgifaceserver has the ability to serve graphical pictures. Aceserver is text-only. In general, you will want to use sgifaceserver unless you know you will never need to serve pictures. If you download a binary distribution of ACEDB, the two executables may have the name of the operating system appended to them. Never fear. Just rename the files to "saceserver" and "sgifaceserver." A full description of installing s(gif)aceserver is given in the ACEDB web pages at: http://www.acedb.org/Development/wdoc/Socket_Server/SOCKET_aceserver.html However, it is a rather technical description. Here's a brief summary of what you need to do: 1) Set up server password permissions: a. Choose an administrative username and password. For example "admin" and "acepass" b. Generate a "hash" of the username and password using the makeUserPasswd program (this comes with the acedb binaries): % makeUserPasswd admin // Please enter passwd: ****** // Please re-enter passwd: ****** // The following line is a valid entry for wspec/serverpasswd.wrm admin e5cc20aa1a8f3e7e5b29728bbd1355d8 c. Find the file named serverpasswd.wrm located in the wspec/ subdirectory of the acedb database directory. Add these two lines to the end of the file: admin: admin admin e5cc20aa1a8f3e7e5b29728bbd1355d8 The first line tells the server that the "admin" user has administrative access, and can start and stop the server. The second line says that "admin" has the password encoded in the numbers. d. If you want to create additional users with read-only or read/write, permissions, you can do so by generating more user names and password hashes with makeUserPasswd, and entering them into the serverpasswd.wrm file as described before. Here is an example that grants "fred" and "ethel" read/write access, and grants "ricky" read-only access: admin: admin write: fred ethel read: ricky admin e5cc20aa1a8f3e7e5b29728bbd1355d8 fred 08b622ddf7eb7c8e44cdb3bd6362f966 ricky 64c12094434c3c4a1a24cdd21ad06485 ethel f95557500f46122aacd59ce920aae6e8 2) Try to start the server under your own account, using saceclient. Assuming that you have installed the acedb databases using your own user permissions, you can try to run the web server as yourself. Open up two command windows on your system. In one type this command: % ~acedb/bin/sgifaceserver ~acedb/elegans 5000 This is telling the server to run on port 5000 and to read data from the database directory located at ~acedb/elegans. If all is well, you will see messages like this: // Database directory: /usr/local/acedb/elegans // Shared files: /usr/local/acedb // #### Server started at 2003-05-12_11:54:13 // #### host=brie3.cshl.org listening port=5000 // #### Database dir=/usr/local/acedb/elegans/ // #### Working dir=/usr/local/acedb/elegans/ // #### clientTimeout=600 serverTimeout=600 maxbytes=102400 autoSaveInterval=600 The messages will stop, indicating that the server is waiting for incoming connections. In the other window, launch saceclient with this command: % ~acedb/bin/saceclient localhost -port 5000 It will prompt you for a userid (type "admin") and a password (type the password). If all goes well, you will get this prompt: acedb@localhost> and the server will accept queries. For example, try the command "Find Model". 3) Try to communicate with the server using aceperl. When you installed AcePerl, it should have installed a small interface script named ace.pl. Confirm that it can talk to the server: % ace.pl -host localhost -port 5000 By default, you will get an "anonymous" read only connection, and you will see the prompt: aceperl> indicating that the database is ready to accept queries. 4) Shut down the server. When you are ready, shut down the server like this: % ace.pl -host localhost -port 5000 -user admin -pass acepass aceperl> shutdown now 5) Try running the server as the "acedb" user. If you are going to be running the acedb server a lot, it is better to run it under the "acedb" account than under your personal login. The reason for this is that bugs in the acedb server code may inadvertently expose your personal files to snooping or deletion if the server is running under your personal ID. To run the server as acedb, you must make its database files writable by the acedb user. To do this, become the root user, and run the following commands: # chown -R acedb ~acedb/elegans/database # chgrp -R acedb ~acedb/elegans/database # chmod -R +rw ~acedb/elegans/database Replace the path ~acedb/elegans with the path to the database that you want to be accessible. What this is doing is to make the "database" subdirectory owned by the acedb user and writable by it. Still running as root, become the acedb user: # su acedb Now confirm that you can still launch the server: % ~acedb/bin/sgifaceserver ~acedb/elegans 5000 and talk to it: % ace.pl -host localhost -port 5000 Congratulations. You're almost done. The last step is to arrange for the acedb socket server to start up automatically when needed. GETTING THE SERVER TO START AUTOMATICALLY There are two recipes for this, depending on whether your system uses standard "inetd" "super daemon" to start up services on an as-needed basis, or uses the new enhanced version called "xinetd." The way to tell is to look in your /etc directory. If you see a file named inetd.conf, then you are using the traditional inetd daemon. If you see instead a directory named xinetd.d/ then you are using xinetd. 1) Configuring for inetd: a) Find the file /etc/services, and add the following line to the end of the file: elegans 5000/tcp This is defining a new service named "elegans" which runs on port 5000. You can change this symbolic name to anything you like. If you have multiple acedb databases running, give each one a distinctive name and port number. Avoid using any port numbers that are already mentioned in the file. b) Find the file /etc/inetd.conf, and add the following line: elegans stream tcp wait acedb /usr/local/acedb/bin/sgifaceserver sgifaceserver /usr/local/acedb/elegans This is all one line, but has been word-wrapped to fit. The first field refers to the service named "elegans" that you defined in /etc/services and is necessary for inetd to associate the service with the proper port number. Modify as you see fit. c) Tell inetd to reread its configuration files. Use "ps" to find the ID of the inetd daemon like this: # ps -elf | grep inetd 140 S root 121 1 0 68 0 - 475 do_sel May11 ? 00:00:00 /usr/sbin/inetd and use "kill -HUP" to tell the server to reread inetd.conf (this must be done as root): # kill -HUP 140 You should now be able to communicate with the server using saceclient or ace.pl. If it's not working, look in the following log files for helpful error messages: /var/log/messages ~acedb/elegans/database/log.wrm ~acedb/elegans/database/serverlog.wrm 2) Configuring for xinetd: a) Find the file /etc/services, and add the following line to the end of the file: elegans 5000/tcp This is defining a new service named "elegans" which runs on port 5000. You can change this symbolic name to anything you like. If you have multiple acedb databases running, give each one a distinctive name and port number. Avoid using any port numbers that are already mentioned in the file. b) Find the directory /etc/xinetd.d. Create a file named after the service chosen in (a) containing these contents: # file: elegans # default: on # description: C. elegans acedb database service elegans { disable = no protocol = tcp socket_type = stream flags = REUSE wait = yes user = acedb group = acedb log_on_success += USERID DURATION log_on_failure += USERID HOST server = /usr/local/acedb/bin/saceserver server_args = /usr/local/acedb/elegans } Change the line "service elegans" to be the symbolic name chosen in (a). c) Tell xinetd to restart. Use "ps" to find the ID of the xinetd daemon like this: # ps -elf | grep xinetd 140 S root 457 1 0 69 0 - 557 do_sel Mar09 ? 00:00:21 xinetd and use "kill -HUP" to tell the server to reread inetd.conf (this must be done as root): # kill -HUP 140 You should now be able to communicate with the server using saceclient or ace.pl. If it's not working, look in the following log files for helpful error messages: /var/log/messages ~acedb/elegans/database/log.wrm ~acedb/elegans/database/serverlog.wrm Lincoln Stein May 2003 AcePerl-1.92/docs/GFF_Spec.html0000644000175000017500000006443006711417747015555 0ustar lsteinlstein The Sanger Centre : Gene-Finding Format - introduction and specification
Data release policy and Guidelines and conditions on use of data
[The Sanger Centre]
| Info | HGP | Projects | Database Searches | Software | Teams | Search |
Home page Home up to Software & Databases Software & Databases up to GFF GFF

GFF (Gene Finding Features) Specifications Document

Introduction

Essentially all current approaches to gene finding in higher organisms use a variety of recognition methods that give scores to likely signals (starts, splice sites, stops etc.) or to extended regions (exons, introns etc.), and then combine these to give complete gene structures. Normally the combination step is done in the same program as the feature detection, often using dynamic programming methods. We would like to enable these processes to be decoupled, by proposing a format called GFF (Gene-Finding Format) for the transfer of feature information. It would then be possible to take features from an outside source and add them in to an existing program, or in the extreme to write a dynamic programming system which only took external features.

In particular, establishing GFF would allow people to develop features and have them tested without having to maintain a complete gene-finding system. Equally, it would help those developing and applying integrated gene-finding programs to test new feature detectors developed by others, or even by themselves.

We want the GFF format to be easy to parse and process by a variety of programs in different languages. e.g. it would be useful if Unix tools like grep, sort and simple perl and awk scripts could easily extract information out of the file. For these reasons, for the primary format, we propose a record-based structure, where each feature is described on a single line, and line order is not relevant.

We do not intend GFF format to be used for complete data management of the analysis and annotation of genomic sequence. Systems such as Acedb, Genotator etc. that have much richer data representation semantics have been designed for that purpose. The disadvantages in using their formats for data exchange (or other richer formats such as ASN.1) are (1) they require more complexity in parsing/processing, (2) there is little hope on achieving consensus on how to capture all information. GFF is intentionally aiming for a low common denominator.

Here are some example records: 

SEQ1	EMBL	atg	103	105	.	+	0
SEQ1	EMBL	exon	103	172	.	+	0
SEQ1	EMBL	splice5	172	173	.	+	.
SEQ1	netgene	splice5	172	173	0.94	+	.
SEQ1	genie	sp5-20	163	182	2.3	+	.
SEQ1	genie	sp5-10	168	177	2.1	+	.
SEQ2	grail	ATG	17	19	2.1	-	0

Back to Table of Contents

Version 2 GFF Update

ALERT 98/12/16: Following discussions with Lincoln Stein and others, we propose the Version 2 format of GFF, as specifically described in this document. The Version 2 specification has not yet been frozen and is presented as a "work-in-progress" at this time, open to user feedback on the proposed changes (plus other suggestions for improvement). The main change from Version 1 to Version 2 is the requirement for a tag-value type structure (essentially .ace format) for any additional material on the line, following the mandatory fields. We also now allow '.' as a score, for features for which there is no score. Dumping in version 2 format is implemented in ACEDB. Changes in the remainder of this document are described and marked as (Version 2 changes).

Back to Table of Contents

Definition

 Fields are: <seqname> <source> <feature> <start> <end> <score> <strand> <frame> [group]>[comments]

<seqname>
The name of the sequence. Having an explicit sequence name allows a feature file to be prepared for a data set of multiple sequences. Normally the seqname will be the identifier of the sequence in an accompanying fasta format file. An alternative is that 'seqname' is the identifier for a sequence in a public database, such as an EMBL/Genbank/DDBJ accession number. Which is the case, and which file or database to use, should be explained in accompanying information.

<source>
The source of this feature. This field will normally be used to indicate the program making the prediction, or if it comes from public database annotation, or is experimentally verified, etc.

<feature>
The feature type name. We hope to suggest a standard set of features, to facilitate import/export, comparison etc.. Of course, people are free to define new ones as needed. For example, Genie splice detectors account for a region of DNA, and multiple detectors may be available for the same site, as shown above.

(Version 2 change: Standard Table of Features - we would like to enforce a standard nomenclature for common GFF features. This does not forbid the use of other features, rather, just that if the feature is obviously described in the standard list, that the standard label should be used. For this standard table we propose to fall back on the international public standards for genomic database feature annotation, specifically, the DDBJ/EMBL/GenBank feature table).

<start>, <end>
Integers. <start> must be less than or equal to <end>. Sequence numbering starts at 1, so these numbers should be between 1 and the length of the relevant sequence, inclusive. (Version 2 change: version 2 condones values of <start> and <end> that extend outside the reference sequence. This is often more natural when dumping from acedb, rather than clipping. It means that some software using the files may need to clip for itself.)

<score>
A floating point value. When there is no score (i.e. for a sensor that just records the possible presence of a signal, as for the EMBL features above) you should use '.'. (Version 2 change: in version 1 of GFF you had to write 0 in such circumstances.)

<strand>
One of '+', '-' or '.'. '.' should be used when strand is not relevant, e.g. for dinucleotide repeats.

<frame>
One of '0', '1', '2' or '.'. '0' indicates that the specified region is in frame, i.e. that its first base corresponds to the first base of a codon. '1' indicates that there is one extra base, i.e. that the second base of the region corresponds to the first base of a codon, and '2' means that the third base of the region is the first base of a codon. If the strand is '-', then the first base of the region is value of <end>, because the corresponding coding region will run from <end> to <start> on the reverse strand. As with <strand>, if the frame is not relevant then set <frame> to '.'. It has been pointed out that "phase" might be a better descriptor than "frame" for this field.

[group]
An optional string-valued field that can be used as a name to group together a set of records. Typical uses might be to group the introns and exons in one gene prediction (or experimentally verified gene structure), or to group multiple regions of match to another sequence, such as an EST or a protein. See below for examples.
Version 2 change: In version 2, the optional [group] field on the line must have an tag value structure following the syntax used within objects in a .ace file, flattened onto one line by semicolon separators. Tags must be standard identifiers ([A-Za-z][A-Za-z0-9_]*). Free text values must be quoted with double quotes. Note: all non-printing characters in such free text value strings (e.g. newlines, tabs, control characters, etc) must be explicitly represented by their C (UNIX) style backslash-escaped representation (e.g. newlines as '\n', tabs as '\t'). As in ACEDB, multiple values can follow a specific tag. The aim is to establish consistent use of particular tags, corresponding to an underlying implied ACEDB model if you want to think that way (but acedb is not required). Examples of these would be: 
seq1     BLASTX  similarity   101  235 87.1 + 0	Target "HBA_HUMAN" 11 55 ; E_value 0.0003
dJ102G20 GD_mRNA coding_exon 7105 7201   .  - 2 Sequence "dJ102G20.C1.1"
All strings (i.e. values of the <seqname>, <source> or <feature> fields) should be under 256 characters long, and should not include whitespace. The whole line should be under 32k long. A character limit is not very desirable, but helps write parsers in some languages. The slightly silly 32k limit is to allow plenty of space for comments/extra data. Version 2 change: field and line size limitations are removed; however, fields (except the optional [group] field above) must still not include whitespace.

All of the above described fields should be separated by TAB characters ('\t'). Version 2 note: previous Version 2 permission to use arbitrary whitespace as field delimiters is now revoked! (99/02/26)

Back to Table of Contents

Comments

Comments are allowed, starting with "#" as in Perl, awk etc. Everything following # until the end of the line is ignored. Effectively this can be used in two ways. Either it must be at the beginning of the line (after any whitespace), to make the whole line a comment, or the comment could come after all the required fields on the line.

We also permit extra information to be given on the line following the group field without a '#' character (Version 2 change: this extra information must be delimited by the '#' comment delimiter OR by another tab field delimiter character, following any and all [group] field tag-value pairs).

This allows extra method-specific information to be transferred with the line. However, we discourage overuse of this feature: better to find a way to do it with more true feature lines, and perhaps groups. (Version 2 change: we gave in and defined a structured way of passing additional information, as described above under [group]. But the sentiment of this paragraph still applies - don't overuse the tag-value syntax. The use of tag-value pairs (with whitespace) renders problematic the parsing of Version 1 style comments (following the group field, without a '#' character), so in Version 2, such [group] trailing comments must start with the "#", as noted above.

## comment lines for meta information

There is a set of standardised (i.e. parsable) ## line types that can be used optionally at the top of a gff file. The philosophy is a little like the special set of %% lines at the top of postscript files, used for example to give the BoundingBox for EPS files.

Current proposed ## lines are: 

 ##gff-version 1
GFF version - in case it is a real success and we want to change it. The current version is 2. (Version 2 change!) 
 ##source-version {source} {version text}
So that people can record what version of a program or package was used to make the data in this file. I suggest the version is text without whitespace. That allows things like 1.3, 4a etc. 
 ##date {date}
The date the file was made, or perhaps that the prediction programs were run. We suggest to use astronomical format: 1997-11-08 for 8th November 1997, first because these sort properly, and second to avoid any US/European bias. 
 
 ##DNA {seqname}
 ##acggctcggattggcgctggatgatagatcagacgac
 ##...
 ##end-DNA
To give a DNA sequence. Several people have pointed out that it may be convenient to include the sequence in the file. It should not become mandatory to do so. Often the seqname will be a well-known identifier, and the sequence can easily be retrieved from a database, or an accompanying file. 
 ##sequence-region {seqname} {start} {end}
To indicate that this file only contains entries for the specified subregion of a sequence.
Please feel free to propose new ## lines. The ## line proposal came out of some discussions including Anders Krogh, David Haussler, people at the Newton Institute on 1997-10-29 and some email from Suzanna Lewis. Of course, naive programs can ignore all of these...

File Naming

We propose that the format is called "GFF", with conventional file name ending ".gff".

Back to Table of Contents

Semantics

We have intentionally avoided overspecifying the semantics of the format. For example, we have not restricted the items expressible in GFF to a specified set of feature types (splice sites, exons etc.) with defined semantics. Therefore, in order for the information in a gff file to be useful to somebody else, the person producing the features must describe the meaning of the features.

In the example given above the feature "splice5" indicates that there is a candidate 5' splice site between positions 172 and 173. The "sp5-20" feature is a prediction based on a window of 20 bp for the same splice site. To use either of these, you must know the position within the feature of the predicted splice site. This only needs to be given once, possibly in comments at the head of the file, or in a separate document.

Another example is the scoring scheme; we ourselves would like the score to be a log-odds likelihood score in bits to a defined null model, but that is not required, because different methods take different approaches. Avoiding a prespecified feature set also leaves open the possibility for GFF to be used for new feature types, such as CpG islands, hypersensitive sites, promoter/enhancer elements, etc.

Back to Table of Contents

Ways to use GFF

Here are a few suggestions on how the GFF format might be used.
  1. Simple sharing of sensors. In this case, researcher A has a sensor, such as a 3' splice site sensor, and researcher B wants to test that sensor. They agree on a set of sequences, researcher A runs the sensor on these sequences and sends the resulting GFF file to researher B, who then evaluates the result.

  2. Representing experimental results. GFF feature records can also be created for experimentally confirmed exons and other features. In these cases there will presumably be no score. Such "confirmed" GFF files will be useful for evaluating predictions, using the same software as you would to compare predictions.

  3. Integrated gene parsing. Several GFF files from different researchers can be combined to provide the features used by an integrated genefinder. As mentioned above, this has the advantage that different combinations of sensors and dynamic programming methods for assembling sensor scores into consistent gene parses can be easily explored.

  4. Reporting final predictions. GFF format can also be used to communicate finished gene predictions. One simply reports final predicted exons and other predicted gene features, either with their original scores. or with some sort of posterior scores, rather than, or in addition to, reporting all candidate gene features with their scores. To show that a set of the components belong to a single prediction, a "group" field can be added to all the accepted sites. This is useful for comparing the outputs of several integrated genefinders among themselves, and to "confirmed" GFF files. A particular advantage of having the same format for both raw sensor feature score files and final gene parse files is that one can easily explore the possibility of combining the final gene parses from several different genefinders, using another round of dynamic programming, into a single integrated predicted parse.

  5. Visualisation. GFF will also provide a simple standard format for standardising input to visualisation programs, showing predicted and experimentally determined features, gene structures etc.

Back to Table of Contents

Complex Examples

Similarities to Other Sequences

A major source of information about a sequence comes from similarities to other sequences. For example, BLAST hits to protein sequences help identify potential coding regions. We can represent these as a set of "homology gene features", grouping hits to the same target as follows: 
seq1	BLASTX	similarity	101	136	87.1	+	0	HBA_HUMAN
seq1	BLASTX	similarity	107	133	72.4	+	0	HBB_HUMAN
seq1	BLASTX	similarity	290	343	67.1	+	0	HBA_HUMAN
If further information is needed about where in the target protein each match occurs, it can be given after the protein name, e.g. as the start coordinate in the target.

Version 2 change: In version 2 this has been formalised using the tag Target which expects to be followed by the name of the target, followed (optionally) by start and end point in the target as integers, as in 

seq1 BLASTX similarity 101 235 87.1 + 0    Target "HBA_HUMAN" 11 55 ; E_value 0.0003
We need to finalise on a tag model for gapped alignments...

Back to Table of Contents

Cumulative Score Arrays

One issue that comes up with a record-based format such as the GFF format is how to cope with large numbers of overlapping segments. For example, in a long sequence, if one tries to include a separate record giving the score of every candidate exon, where a candidate exon is defined as a segment of the sequence that begins and ends at candidate splice sites and consists of an open reading frame in between, then one can have an infeasibly large number of records. The problem is that there can be a huge number of highly overlapping exon candidates.

Let us assume that the score of an exon can be decomposed into three parts: the score of the 5' splice site, the score of the 3' splice site, and the sum of the scores of all the codons in between. In such a case it can be much more efficient to use the GFF format to report separate scores for the splice site sensors and for the individual codons in all three (or six, including reverse strand) frames, and let the program that interprets this file assemble the exon scores. The exon scores can be calculated efficiently by first creating three arrays, each of which contains in its [i]th position a value A[i] that is the partial sum of the codon scores in a particular frame for the entire sequence from position 1 up to position i. Then for any positions i < j, the sum of the scores of all codons from i to j can be obtained as A[j] - A[i]. Using these arrays, along with the candidate splice site scores, a very large number of scores for overlapping exons are implicitly defined in a data structure that takes only linear space with respect to the number of positions in the sequence, and such that the score for each exon can be retrieved in constant time.

When the GFF format is used to transmit scores that can be summed for efficient retrieval as in the case of the codon scores above, we ask that the provider of the scores indicate that these scores are summable in this manner, and provide a recipe for calculating the scores that are to be derived from these summable scores, such as the exon scores described above. We place no limit on the complexity of this recipe, nor do we provide a standard protocol for such assembly, other than providing examples. It behooves the sensor score provider to keep the recipe simple enough that others can easily implement it.

Back to Table of Contents

Mailing list

There is a mailing list to which you can send comments, enquiries, complaints etc. about GFF. If you want to be added to the mailing list, please send mail to Majordomo@sanger.ac.uk with the following command in the body of your email message:

subscribe gff-list

Back to Table of Contents

Edit History

971028 rd: I changed the comment initiator to '#' from '//' because a single symbol is easier for simple parsers.

971028 rd: We also now allow extra text after <group> without a comment character, because this immediately proved useful.

971028 rd: I considered switching from start-end notation to start-length notation, on the suggestion of Anders Krogh. This seems nicer in many cases, but is a debatable point. I then switched back!

971028 rd: I added the section about name space.

971108 rd: added ## line proposals - moved them into main text 971113.

971113 rd: added extra "source" field as discussed at Newton Institute meeting 971029. There are two main reasons. First, to help prevent name space clashes -- each program would have their own source designation. Second, to help reuse feature names, so one could have "exon" for exon predictions from each prediction program.

971113 rd: added section on mailing list.

980909 ihh: fixed some small things and put this page on the Sanger GFF site.

981216 rd: introduced version 2 changes.

990226 rbsk: incorporated amendments to the version 2 specification as follows:

  • Non-printing characters (e.g. newlines, tabs) in Version 2 double quoted "free text values" must be explicitly represented by their C (UNIX) style backslash escaped character (i.e. '\t' for tabs, '\n' for newlines, etc.)
  • Removed field (256) and line (32K) character size limitations for Version 2.
  • Removed arbitrary whitespace field delimiter permission from specification. TAB ('\t') field delimiters now enforced again, as in Version 1.
990317 rbsk:
  • End of line comments following Version 2 [group] field tag-value structures must be tab '\t' or hash '#' delimited.

Back to Table of Contents

Authors

GFF Protocol Specification initially proposed by: Richard Durbin and David Haussler

with amendments proposed by: Lincoln Stein, Anders Krogh and others.

The GFF specification now maintained at the Sanger Centre by Richard Bruskiewich

Back to Table of Contents

last modified : 25-Mar-1999, 01:59 PM Richard Bruskiewich (rbsk@sanger.ac.uk)
AcePerl-1.92/docs/ACE_SERVER_TRAPS.HOWTO0000644000175000017500000001443206745650273016561 0ustar lsteinlstein NOTE: These notes were put together by Sarah Yurman, a programmer at Spatial Focus, while setting up her first ACEDB server. She has contributed these notes in the hope that they will help other programmers to avoid the traps that she stumbled into. Another important document to consult is [1]wrpc/SERVER.INSTALLATION, part of the ACeDB source distribution. Troubleshooting a new ACE Database _________________________________________________________________ Introduction May 25, 1999 This is a list of things great and small that we have discovered while implementing a new ACE database at [2]Spatial Focus. We are working with ACE in Linux, at the time of this writing we are using Redhat 5.2. Caveat Emptor This document is a work in progress. It is being written while we are solving problems. Its primary purpose is to maintain a record for internal use at Spatial Focus. Although we don't deliberately make mistakes, anything in this document could be wrong. Mistakes will be corrected as they are found. We are not responsible for any harm resulting from information we record here. Merci! Many thanks to [3]Lincoln Stein and all the folks at the Human Genome Project. Contents Environment Description Installation ACEDB * ACEDB and environment variables * Permissions Gifaceserver * inetd.conf * server.log Models Editors White Space To Do _________________________________________________________________ Environment Description These notes refer to the following environment: * ACEDB: 4.7g, loaded from the Linux binary (bin.linux_libc6.4_7g.tar.Z) * Perl 5.005_03 * CGI.pm 2.51 * AcePerl 1.54 * Gifaceserver loaded from gifaceserver.LINUX * Apache 1.3 (This is just for local use, so upgrading hasn't been a priority) * Netscape 4.51 * Linux (Redhat 5.2) * bash shell Installation: ACEDB ACEDB and environment variables Problem If nothing works, chances are the environment variables haven't been set. The acedb and textdb scripts built by INSTALL wouldn't work due to the differences in shells. acedb sets environment variables called $ACEDB and $DBDIR, and appends your path, then starts the xace graphical interface to ACEDB. textdb sets the environment variables and starts the tace text interface. Solution I altered my .bash_profile with the following lines: ACEDB=[pathname to database] DBDIR=[pathname to database]/database/ PATH=$PATH:[pathname to ace software directory]/bin export ACEDB export DBDIR (PATH was already exported) Testing the Solution Use the echo command to make sure the environment variables are in place. We put our "contacts" database under /home/httpd because that directory is accessible to the web server. This is a requirement of AceBrowser, which we want to use as the primary interface. A test of the $ACEDB environment variable looks like this: echo $ACEDB (return) It returns this: /home/httpd/database/contacts/ Consequences of the Solution The NOTES file distributed with this version of ACEDB advises you to move the acedb and textace scripts to /usr/local/bin, and using them to start the program. With your environment variables in place, you can simply use xace or tace instead. Permissions Take your permissions seriously. Richard Durbin's Installation Guide is out of date, but gives good advice in this department. Gifaceserver Warning: this isn't yet working completely Problem Most documentation dealing with this software simply tells you to get it going. The software comes with no documentation whatsoever. No README at all. There is a manual that comes in /acedocs called aceserver.html. Its installation instructions don't work on version 4.7g. Solution The best installation information is in the README file for AcePerl-1.54. A few more hints are listed here. The AcePerl README file implies creating a user called acedb. This creates permissions problems that we haven't solved yet. We are using individual user names instead. One thing that no documentation mentions is that we had to move gifaceserver.LINUX to /usr/local/bin/gifaceserver. Obvious, but still makes you wonder while you do it. Inetd.conf Our individual inetd.conf files were completely commented out, and the daemon stopped because of our dispersed locations. Append the required line to the file, and enter: Killall -HUP inetd server.log The server really wants a server.log file, writable by the user to whom the gifaceserver is assigned in the inetd.conf file. We created one by opening the gifaceserver on a fake port number (12345): /usr/local/bin/gifaceserver /home/httpd/database/contacts 12345 1200:1200:10 Models Documentation The best documentation for models is in /acedocs/exploring/*. The table of contents is in /acedocs/exploring/toc_models.html. Unfortunately, like all the ACEDB documentation, it uses absolute pathnames. We have converted these pathnames to relative ones, and will make the document available for download on the Spatial Focus private web page. Although the document is marked "draft" and dated 1994, it is thorough and simple. Doesn't appear to be significantly out of date. The moviedb database is the best simple example of a database. Editors ACEDB is picky about its ascii. vi works great. Can't vouch for emacs ;-). Don't use anything nasty like a word processor. White Space It really likes alignment, and it likes tabs. Combining tabs and spaces kills otherwise perfectly good models every five seconds. To Do Solve the mysteries of the failure of AceBrowser. Every other means of access works now. References 1. file://localhost/home/lstein/projects/Ace-perl/docs/SERVER_INSTALLATION.HOWTO 2. http://www.spatialfocus.com/ 3. http://stein.cshl.org/ AcePerl-1.92/docs/NEW_DB.HOWTO0000644000175000017500000000656707657745717015155 0ustar lsteinlsteinHOW TO START A NEW DATABASE ACeDB stores its data in a fast-access binary form. Data is ordinarily loaded and dumped from a human-readable flat-file format known as .ace. To start a new database, you must: 1) create a database directory containing the following subdirectories: wspec/ schema and other files database/ binary files wgf/ DNA analysis files [optional] whelp/ help files [optional] wscript/ helper scripts [optional] It's perfectly all right to ignore the optional directories. They are only relevant for the original C. elegans database. 2) start acedb and allow it to initialize the binary files. 3) load one or more .ace files. Before you begin, you must have a models.wrm file and one or more .ace files containing the flat-file representation of the data. For an example, see the moviedb example database, which is located at usr/local/apache/htdocs/AcePerl/archive/moviedb.tar.Z. The recipe for creating a new database from scratch using the interactive xace tool is this: 1) create a directory with the database's name 2) within that directory create a directory named "wspec" (where the schema lives) and another named "database" 3) populate the wspec subdirectory with the schema files, which you can copy from another database, such as the C. elegans database 4) run xace, giving it the database's directory as its command-line argument 5) xace will prompt you to reinitialize the database, say "OK" 6) using the edit menu, select "read .ace" file. Say "yes" when prompted for write access 7) choose "Open ace file" from the dialog box, and locate the file you wish to load 8) select "Read all" 9) when done, close the window and select "Save..." from the main xace window Read other .ace files in the same way. Rather than launching xace, you can do it all with tace. Lines surrounded by represent user input: % // Database directory: /usr/local/acedb/my_db The file /usr/local/acedb/my_db/database/ACEDB.wrm does not exist, indicating that the database is empty. Should I re-initialise the system? (y or n) // 13 objects read with 0 errors // 0 objects read with 0 errors // Indexing (this may take several minutes) // Indexed 742 tags in 452 objects totalling 383 nodes // 13 objects read with 0 errors // 0 objects read with 0 errors // Indexing // Reindexed 742 tags in 0 classes containing 0 objects totalling 0 nodes **** Program tace, compiled on: Jul 6 1999 10:58:24 **** **** Using ACEDB Version 4_7i, compiled on: Jul 6 1999 10:58:14 **** Code by: Jean Thierry-Mieg (CNRS, France) mieg@crbm.cnrs-mop.fr Richard Durbin (Sanger Centre, UK) rd@sanger.ac.uk Simon Kelley (Sanger Centre, UK) srk@sanger.ac.uk You may redistribute this program and database subject to the conditions in the accompanying copyright file. Anyone interested in maintaining an up-to-date version should contact one of the authors at the above email addresses. // Type ? for a list of options acedb> // Parsing file /usr/local/acedb/raw/my_content.ace // 123 objects read with 0 errors // 123 Active Objects acedb> // 123 Active Objects acedb> // A bientot To set up an ACeDB server, please see ACEDB.HOWTO and ACE_SERVER_TRAPS.HOWTO. Lincoln Stein lstein@cshl.org May 12, 2003 AcePerl-1.92/util/0000755000175000017500000000000011106333223013305 5ustar lsteinlsteinAcePerl-1.92/util/install.PLS0000644000175000017500000000344007657737140015362 0ustar lsteinlstein#!perl use Config; use File::Basename qw(&basename &dirname); use Cwd; $origdir = cwd; chdir dirname($0); $file = basename($0, '.PLS'); $file .= $^O eq 'VMS' ? '.com' : '.pl'; open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; print OUT <<"!GROK!THIS!"; $Config{startperl} -w !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; use strict; use File::Copy 'copy'; use IO::Dir; my $source = shift or exit 0; my $dest = shift or exit 0; die "$source is not a directory" unless -d $source; die "$dest is not a directory" unless -d $dest; copy_tree($source,'.',$dest); sub copy_tree { my ($base,$subdir,$dest) = @_; -d "$dest/$subdir" || mkdir("$dest/$subdir",0777); my $dir = IO::Dir->new("$base/$subdir") or die "Can't opendir() $source: $!"; while (my $thing = $dir->read) { next if $thing =~ /^\./; # not hidden files next if $thing =~ /^\#/; # not autosave files next if $thing =~ /~$/; # not autosave files next if $thing eq 'CVS'; # not CVS directories next if $thing eq 'core'; # not core files if (-f "$base/$subdir/$thing") { # a regular file my $result = copy("$base/$subdir/$thing","$dest/$subdir/$thing"); if ($result) { my $mode = (stat("$base/$subdir/$thing"))[2]; chmod $mode,"$dest/$subdir/$thing"; } print STDERR $result ? "OK: " : "FAILED: ","$base/$subdir/$thing => $dest/$subdir/$thing\n", } elsif (-d "$base/$subdir/$thing") { copy_tree($base,"$subdir/$thing",$dest); } } } __END__ !NO!SUBS! close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; chdir $origdir; AcePerl-1.92/util/ace.PLS0000644000175000017500000002042007660006576014435 0ustar lsteinlstein#!perl use Config; use File::Basename qw(&basename &dirname); use Cwd; $origdir = cwd; chdir dirname($0); $file = basename($0, '.PLS'); $file .= $^O eq 'VMS' ? '.com' : '.pl'; open OUT,">$file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; print OUT <<"!GROK!THIS!"; $Config{startperl} -w !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; # Simple interface to acedb. # Uses readline for command-line editing if available. use Ace; use Getopt::Long; use Text::ParseWords; use strict vars; use vars qw/@CLASSES @HELP_TOPICS/; use constant DEBUG => 0; my ($HOST,$PORT,$PATH,$TCSH,$URL,$AUTOSAVE,$USER,$PASS,@EXEC); GetOptions('host=s' => \$HOST, 'port=i' => \$PORT, 'path=s' => \$PATH, 'tcsh' => \$TCSH, 'url' => \$URL, 'login:s' => \$USER, 'user:s' => \$USER, 'password:s' => \$PASS, 'save' => \$AUTOSAVE, 'exec=s' => \@EXEC, ) || die < Server host (localhost) -port Server port (200005) -path Local database path (no default) -url Server URL (see below -login Username -pass Password -tcsh Use T-shell completion mode -save Save database updates automatically -exec Run a command and quit Respects the environment variables \$ACEDB_HOST and \$ACEDB_PORT, if present. You can edit the command line using the cursor keys and emacs style key bindings. Use up and down arrows (or ^P, ^N) to access the history. The tab key completes partial commands. In tcsh mode, the tab key cycles among the completions, otherwise pressing the tab key a second time lists all the possibilities. You may use multiple -exec switches to run a sequence of commands, or separate multiple commands in a single string by semicolons: ace.pl -e 'find Author Thierry-Mieg*' -e 'show' ace.pl -e 'find Author Thierry-Mieg*; show' Server URLs: rpcace://hostname:port RPC server sace://hostname:port Socket server tace:/path/to/database Local database /path/to/database Local database Usernames can be provided as sace://user\@hostname:port USAGE ; $HOST ||= $ENV{ACEDB_HOST} || 'localhost'; $PORT ||= $ENV{ACEDB_PORT} || 200005; $URL = shift if $ARGV[0] =~ /^(rpcace|sace|tace):/; my $PROMPT = "aceperl> "; $USER ||= $1 if $URL && $URL=~ m!//(\w+)\@!; $PASS ||= get_passwd($USER) if $USER; my $DB = $URL ? Ace->connect(-url=>$URL,-user=>$USER,-pass=>$PASS) : $PATH ? Ace->connect(-path=>$PATH) : Ace->connect(-host=>$HOST,-port=>$PORT,-user=>$USER,-pass=>$PASS); $DB || die "Connection failure: ",Ace->error,"\n"; $DB->auto_save($AUTOSAVE); if (@EXEC) { foreach (@EXEC) { foreach (split (';')) { evaluate($_); } } exit 0; } # read_top_material() if $PATH; if (@ARGV || !-t STDIN) { while (<>) { chomp; evaluate($_); } } elsif (eval "require Term::ReadLine") { my $term = setup_readline(); while (defined($_ = $term->readline($PROMPT)) ) { evaluate($_); } } else { $| = 1; print $PROMPT; while (<>) { chomp; evaluate($_); } continue { print $PROMPT; } } quit(); sub quit { undef $DB; print "\n// A bientot!\n"; exit 0; } sub evaluate { my $query = shift; my @commands; if ($query=~/^(quit|exit)/i) { quit(); exit 0; } if ($query =~ /^(p?parse) (?!=)(.*)/i) { push (@commands,setup_parse($1,$2)); } else { push (@commands,$query); } foreach (@commands) { print "$_\n" if @commands > 1; $_ = setup_remote_parse($_) if /^parse (?!=)/ && !$PATH; $DB->db->query($_) || return undef; die "Ace Error: \n",$DB->db->error,"\n" if $DB->db->status == STATUS_ERROR; while ($DB->db->status == STATUS_PENDING) { my $h = $DB->db->read; $h=~s/\0+\Z//; # get rid of nulls in data stream! print $h; print "\n" unless $h =~ /\n\Z/; } die "Ace Error: \n",$DB->db->error,"\n" if $DB->db->status == STATUS_ERROR; } } sub setup_readline { my $term = new Term::ReadLine 'aceperl'; my (@commands) = qw/quit help classes model find follow grep longgrep list show is remove query where table-maker biblio dna peptide keyset-read spush spop swap sand sor sxor sminus parse pparse write edit eedit shutdown who data_version kill status date time_stamps count clear save undo wspec/; eval { readline::rl_basic_commands(@commands); readline::rl_set('TcshCompleteMode', 'On') if $TCSH; $readline::rl_special_prefixes='"'; $readline::rl_completion_function=\&complete; }; $term; } # This is a big function for command completion/guessing. sub complete { my($txt,$line,$start) = @_; return ('"') if $txt eq '"'; # to fix wierdness # Examine current word in the context of the two previous ones $line = substr($line,0,$start+length($txt)); # truncate $line .= '"' if $line=~tr/"/"/ % 2; # correct odd quote parity errors my(@tokens) = quotewords(' ',0,$line); push(@tokens,$txt) unless $txt || $line=~/\"$/; my $old = $txt; $txt = $tokens[$#tokens]; debug ("\n",join(':',@tokens)," (text = $txt, start = $start, old=$old)"); if (lc($tokens[$#tokens-2]) eq 'find') { my $count = $DB->count($tokens[$#tokens-1],"$txt*"); if ($count > 250) { warn "\r\n($count possibilities -- too many to display)\n"; $readline::force_redraw++; readline::redisplay(); return; } else { my @obj = $DB->list($tokens[$#tokens-1],"$txt*"); debug("list(",$tokens[$#tokens-1],',',"$txt*",") :",scalar(@obj)," objects retrieved"); if ($txt=~/(.+\s+)\S*$/) { my $common_prefix = $1; return map { "$_\"" } map { substr($_,index($_,$common_prefix)+length($common_prefix)) } grep(/^$txt/i,@obj); } else { return map { $_=~/\s/ ? "\"$_\"" : $_ } grep(/^$txt/i,@obj); } } } if (lc($tokens[$#tokens-1]) =~/^(find|model)/) { @CLASSES = $DB->classes() unless @CLASSES; return grep(/^$txt/i,@CLASSES); } if ($tokens[$#tokens-1] =~ /^list|show/i) { if ($line=~/-f\s+\S*$/) { return readline::rl_filename_list($txt); } return grep (/^$txt/i,qw/-h -a -p -j -T -b -c -f/); } if ($tokens[$#tokens-1] =~ /^help/i) { @HELP_TOPICS = get_help_topics() unless @HELP_TOPICS; return grep(/^$txt/i,'query_syntax',@HELP_TOPICS); } debug(join(':',@_)); return grep(/^$txt/i,@readline::rl_basic_commands); } # This handles the sub setup_parse { my ($command,$file) = @_; my (@files) = glob($file); # if we're local, then we just create a series # of parse commands and let tace take care of reading # the file return map {"parse $_"} @files if $PATH; # if we're talking to a remote server, we create a series of parse # commands and stop at the first file that we find my @c; local(*F); local($/) = undef; # file slurp foreach (@files) { open (F,$_) || die "Couldn't open $_: $!"; print "parse $_\n"; my $result = $DB->raw_query(scalar(),1); print $result; return if $result=~/error|sorry/i and $command ne 'pparse'; close F; } return (); } sub get_help_topics { return () unless $DB; my $result = $DB->raw_query('help topics'); return grep(/^About/../^nohelp/,split(' ',$result)); } sub debug { return unless DEBUG; my @text = @_; warn "\n",@text,"\n"; $readline::force_redraw++; readline::redisplay(); } sub read_top_material { while ($DB->db->status == STATUS_PENDING) { my $h = $DB->db->low_read; $h=~s/\A\s+\*\*\*.+\.\n\n//s; $h=~s!\n// Type.*\n!!s; $h=~s/acedb> \Z//; $h=~s/\0+\Z//; # get rid of nulls in data stream! print $h; } } sub get_passwd { my $user = shift; local $| = 1; chomp(my $settings = `stty -g ); print "\n"; system "stty $settings $file" or die "Can't create $file: $!"; print "Extracting $file (with variable substitutions)\n"; print OUT <<"!GROK!THIS!"; $Config{startperl} -w !GROK!THIS! # In the following, perl variables are not expanded during extraction. print OUT <<'!NO!SUBS!'; use strict; use File::Copy 'cp'; use IO::Dir; my $source = shift; my $dest = shift; die "$source is not a directory" unless -d $source; die "$dest is not a directory" unless -d $dest; copy_tree($source,'.',$dest); sub copy_tree { my ($base,$subdir,$dest) = @_; my $dir = IO::Dir->new("$base/$subdir") or die "Can't opendir() $source: $!"; while (my $thing = $dir->read) { next if $thing =~ /^./; # not hidden files next if $thing =~ /^\#/; # not autosave files next if $thing =~ /~$/; # not autosave files next if $thing eq 'CVS'; # not CVS directories next if $thing eq 'core'; # not core files if (-f "$base/$subdir/$thing") { # a regular file my $result = copy("$base/$subdir/$thing","$dest/$subdir/$thing"); print STDERR "$base/$subdir/$thing => $dest/$subdir/$thing: ",$result ? "OK\n" : "FAILED: $!\n"; } elsif (-d "$base/$subdir/$thing") { copy_tree($base,"$subdir/$thing",$dest); } } } __END__ !NO!SUBS! close OUT or die "Can't close $file: $!"; chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; chdir $origdir; AcePerl-1.92/README.ACEBROWSER0000644000175000017500000004405707657737136014710 0ustar lsteinlsteinAceBrowser Version 3.1 September 20, 2001 The AcePerl distribution now includes a collection of CGI scripts that run on top of AcePerl to provide a simple browsable interface to ACEDB databases. Some of the code has been tuned for the C. elegans database, but most of it is fully generic. Demos are running at http://stein.cshl.org/elegans/. REQUIREMENTS: 1. AcePerl 1.76 or higher (available at http://stein.cshl.org/AcePerl/) 2. Perl 5.6.0 or higher 3. CGI.pm 2.77 or higher (available at http://stein.cshl.org/WWW/software/CGI) 4. A Web server 5. sgifaceserver 4.8c or higher. For best results, use the version of sgifaceserver available at http://www.acedb.org/. The socket server is generally a better choice than the older RPC-based server. INSTALLATION: 1. Read README first. This describes how to install AcePerl. 2. During the installation, you will be asked whether you wish to install AceBrowser. Answer "yes." 3. You will be asked for the installation locations for several groups of files. The answers depend on the configuration of your web server The install script will attempt to create any directories that do not already exist. a. Site-specific configuration file directory Acebrowser needs access to one or more configuration files. Each file describes a data source and how information from the data source is to be rendered. All configuration files are stored in a directory at the location indicated here. The default is /usr/local/apache/conf/ace/. b. Acebrowser CGI script directory The core of Acebrowser is a set of CGI scripts. This is the directory that will contain them. Choose a directory that will be recognized by the web server as containing CGI script. If you are using Apache/mod_perl, select a directory under the control of Apache::Registry. The default is /usr/local/apache/cgi-bin/ace/ c. Acebrowser HTML files and images Acebrowser uses a small number of static HTML files and images. This is the directory that will contain them. Choose a directory that is located under the web server's document root. The default is /usr/local/apache/htdocs/ace/ Depending on the permissions of your web server directories, you may have to be root in order to create some of these directories. 4. Run "make", "make test" and "make install" as described in the main README. If this is successful, run "make install-browser". This will copy the acebrowser files into the directories chosen in step (3). Depending on the permissions of your web server directories, you may have to be root in order to complete this step. 5. If you installed the CGI scripts in their default location, you should now be able to search the C. elegans database by fetching the following URL: http://your.host/cgi-bin/ace/searches/text You can then follow the links to browse the database. A slightly more sophisticated search allows you to search a subset of object classes: http://your.host/cgi-bin/ace/searches/basic or the entire list of object classes: http://your.host/cgi-bin/ace/searches/browser There is also a default Acebrowser "home page" installed at the URL: http://your.host/ace/index.html You may have to adjust these URLs for the locations of the directories chosen in step (3). CONFIGURATION Acebrowser is configured to allow access to multiple ACEDB databases. You can customize each database extensively by changing the appearance of pages, adding new search capabilities, and adding new displays for particular Ace object classes. Each database has a symbolic name, and each symbolic name corresponds to a configuration file located in the site-specific configuration directory. There are three databases defined in a new Acebrowser installation: simple An acedb database running on port 2005 of the local host moviedb An example database of movies running on port 200008 of stein.cshl.org default An oldish snapshot of the C. elegans database running on port 2005 of stein.cshl.org To select among the data sources, append the symbolic name to the end of the URL of the desired CGI script. For example, to do a text search on the "moviedb" database, fetch this URL: http://your.site/cgi-bin/ace/searches/text/moviedb If no symbolic name is specified, the default database is assumed. http://your.site/cgi-bin/ace/searches/text is equivalent to http://your.site/cgi-bin/ace/searches/text/default As described in EXTENDING ACEBROWSER, another way to select among databases is to place the CGI script itself in a directory with the same name as the database. For example, if you have written a specialized CGI script called screenplay that is designed to work with the "moviedb" database, you could place it in a subdirectory named moviedb, and refer to it this way: http://your.site/cgi-bin/ace/moviedb/screenplay The symbolic name can actually appear anywhere in the path, so this would work as well: http://your.site/cgi-bin/ace/moviedb/custom/screenplay THE CONFIGURATION FILES The configuration files are located in the directory selected for acebrowser configuration. Their names are formed by appending ".pm" to the symbolic name of the database. For example, the configuration file "simple.pm" corresponds to the database "simple". Each of the configuration files is actually an executable Perl script. As such it can use any Perl constructions you wish, including variable interpolation. The purpose of the configuration file is to set a series of configuration variables, which by convention are all uppercase. For example, here is an excerpt from the default.pm configuration file: $HOST = 'stein.cshl.org'; $PORT = 2005; $USERNAME = ''; $PASSWORD = ''; In addition to scalar variables, the configuration file is used to set arrays, hashes and specially-named functions. If you are only interested in accessing a single database, it is easiest to modify the default.pm configuration file. To serve multiple databases, just make a copy of default.pm and edit the copy. If, for some reason, Acebrowser cannot find its configuration files, it will generate an internal server error. The location of the configuration files directory is stored in the module Ace::Browser::LocalSiteDefs, typically somewhere inside the "site_perl" subdirectory of the Perl library directory (use "perl -V" to see where that is). You can find out where Acebrowser expects to find its configuration files by running the following command: perl -MAce::Browser::LocalSiteDefs \ -e 'print $Ace::Browser::LocalSiteDefs::SITE_DEFS,"\n"' To change this value, either reinstall Aceperl or edit LocalSiteDefs.pm manually. EDITING THE CONFIGURATION FILE The settings in the default.pm configuration file distributed with AcePerl should work with little, if any modification. The following variables may need to be tweaked: $ROOT = '/cgi-bin/ace'; This is the root (top level) for all the Acebrowser CGI scripts. Change this if necessary. $DOCROOT = '/ace'; This is the root (top level) for all of Acebrowser's static HTML files and images. You will need to change this if the static files are installed somewhere else. $ICONS = "$DOCROOT/ico"; This is where Acebrowser expects to find its icons. This subdirectory holds icons and other small static images. Note how the previously-defined $DOCROOT variable is used. You will probably not need to change this. $IMAGES = "$DOCROOT/images"; This is where Acebrowser expects to find its "images" subdirectory. This directory contains images generated dynamically by the ACEDB database. It *must* be writable by the web server user, usually "nobody". When the AcePerl install script creates this directory, it makes it world-writable by default. You may prefer to make it owned by the "nobody" user and/or group. $HOST = 'stein.cshl.org'; This is the name of the host where the desired acedb server can be found. $PORT = 2005; This is the network port on which the desired acedb server is listening. Network ports in the range 1024-65535 are assumed to correspond to the newer socket-based sgifaceserver. Ports in the range 65536-4,294,967,296 are assumed to correspond to the older RPC-based gifaceserver. $USERNAME = ''; $PASSWORD = ''; For password-protected ACEDB databases, these variables contain the username and password. $STYLESHEET = "$DOCROOT/stylesheets/aceperl.css"; This is the cascading stylesheet used to set the background color, font, table colors, and so forth. You probably don't need to change this, but you might want to modify the stylesheet itself. @PICTURES = ($IMAGES => "$HTML_PATH/images"); This array indicates the location of the "images" subdirectory. The first element of the array is the location of the directory as a URL, and the second element is the location of the directory as a physical path on the file system. This array is ignored when running under modperl/Apache::Registry; modperl uses $IMAGES to look up the corresponding physical path. @SEARCHES = ( basic => { name => 'Basic Search', url =>"$ROOT/searches/basic", }, text => { name => 'Text Search', url =>"$ROOT/searches/text", }, browser => { name => 'Class Browser', url => "$ROOT/searches/browser", }, query => { name => 'Acedb Query', url => "$ROOT/searches/query", }, ); $SEARCH_ICON = "$ICONS/unknown.gif"; The @SEARCHES array sets the searches made available to users. The first element in each pair is the symbolic name for the search. The second element is a hash reference containing the keys "name" and "url". The name is the bit of human readable text printed in the list of searches located at the top of the AceBrowser page. The url is the URL of the script that performs the search. The $SEARCH_ICON variable selects an icon to use for the search button. @HOME = ( $DOCROOT => 'Home Page' ); Select the URL and label for the "home" link appearing on the bottom of each Acebrowser-generated page. By default, the home will point to "/ace" directory on the local machine. %DISPLAYS = ( tree => { 'url' => "generic/tree", 'label' => 'Tree Display', 'icon' => '/ico/text.gif' }, pic => { 'url' => "generic/pic", 'label' => 'Graphic Display', 'icon' => '/ico/image2.gif' }, ); As described in EXTENDING ACEBROWSER, the %DISPLAYS hash declares a set of pages, or "displays", to be used for displaying certain Ace object types. %CLASSES = ( Default => [ qw/tree pic/ ], ); As described in EXTENDING ACEBROWSER, the %CLASSES hash describes how Acedb classes correspond to displays. sub URL_MAPPER { my ($display,$name,$class) = @_; ... } As described in EXTENDING ACEBROWSER, the URL_MAPPER subroutine allows you to tinker with the way in which Acedb classes are turned into links. $BANNER = <

END The $BANNER variable contains HTML text that will be displayed at the top of each generated page. You will probably want to change this. $FOOTER = ''; The $FOOTER variable contains HTML text that is displayed at the bottom of each generated page. You will probably want to change this. $PRINT_PRIVACY_STATEMENT = 1; If this variable is set to true, then AceBrowser will generate a link in the footer that displays a privacy statement explaining AceBrowser's use of cookies. @FEEDBACK_RECIPIENTS = ( [ " $ENV{SERVER_ADMIN}", 'general complaints and suggestions', 1 ] ); This array contains a list of recipient e-mail addresses for the "feedback" page. Each recipient is an array reference containing least two elements, the e-mail address and a comment. A third, optional, element, if true, indicates that this recipient should be selected by default. The default is the webmaster's e-mail address. Comment out the entire section of you do not want the feedback link to appear. # configuration for the "basic" search script @BASIC_OBJECTS = ('Any' => 'Anything', 'Locus' => 'Confirmed Gene', 'Predicted_gene' => 'Predicted Gene', 'Sequence' => 'Sequence (any)', 'Genome_sequence', => 'Sequence (genomic)', 'Author' => 'Author', 'Genetic_map' => 'Genetic Map', 'Sequence_map' => 'Sequence Map', 'Strain' => 'Worm Strain', 'Clone' => 'Clone' ); The @BASIC_OBJECTS array is used by the "basic" search script. It indicates the Acedb classes to offer to the user to search on, and the labels to use for each class. For example, the default configuration will present the user with a radio button labeled "Confirmed Gene" for use in searching the Acedb class "Locus". USING ACEBROWSER WITH MOD-PERL Acebrowser is designed to work well with modperl (http://perl.apache.org). In fact, using it with a modperl-enabled Apache server will increase its performance dramatically. To use Acebrowser with modperl, install the CGI scripts into a directory that is under the control of Apache::Registry. The section in httpd.conf should look like this: Alias /acedb/ /usr/local/apache/cgi-bin/ace/ SetHandler Perl-script PerlHandler Apache::Registry PerlSendHeader On Options +ExecCGI +Indexes Change the paths as appropriate. The Acebrowser scripts located in /usr/local/apache/cgi-bin/ace can now be accessed under modperl at the URL /acedb, as in: http://your.site/acedb/searches/text When running under modperl, you can force all the CGI scripts in a directory to use a particular configuration file by defining the AceBrowserConf configuration variable . For example, to create a virtual directory named /movies and force all the scripts within it to use the moviedb configuration file: Alias /movies/ /usr/local/apache/cgi-bin/ace/ SetHandler Perl-script PerlHandler Apache::Registry PerlSendHeader On Options +ExecCGI +Indexes PerlSetVar AceBrowserConf /usr/local/apache/conf/acebrowser/moviedb.pm Be sure also to edit moviedb.pm $ROOT variable to indicate the correct location of scripts in URL space: $ROOT = '/movies'; EXTENDING ACEBROWSER Acedb is fundamentally object based. In addition to having a name, each object has a class, such as "Sequence". Acebrowser takes advantage of this object structure by allowing you to assign one or more displays to a class. Each display is a CGI script that fetches the desired object from the database, formats it, and displays it as HTML or an image. Whenever Acebrowser is called upon to display an object, it consults the configuration file to determine what displays are registered for the object, and then presents a row of display names across the top of the window. In Acebrowser jargon, this line of displays is called the "type selector." The user can change the display to use by selecting the corresponding link. Three generic displays, which will work with all databases, come with Acebrowser: tree an HTML representation of the Acedb object which presents the object in the form of a collapsible outline. xml an XML representation of the Acedb object pic a clickable GIF image, as returned from gifaceserver. Writing New Display Scripts --------------------------- To register a new display script with the system, you will need to do three things: 1. Write the script. The easiest way to do this is to take the moviedb "misc/movie" script, copy it, and go from there. The script will be invoked with the CGI parameters "name" and "class", corresponding to the name and class of the Acedb object to display. For example, if the script is located in /cgi-bin/ace/newscript, it will be invoked as: http://your.site/cgi-bin/ace/newscript?name=foo;class=bar 2. Register the display with the %DISPLAYS hash in the configuration file, by adding a hash entry like the following: newdisplay => { url => "/cgi-bin/ace/newscript", label => 'New Display', icon => '/ico/layout.gif', }, The hash key, in this case "newdisplay", is a symbolic name for the display. It can correspond to the acual name of the CGI script, or not. The hash value is itself an anonymous hash containing the required keys "url" and "label", and the optional key "icon". "url" gives the path to the script that will display, and "label" gives a human readable label for the link that Acebrowser puts in the type selector. The "icon" key, if present, will display the indicated icon in the type selector. 3. Bind this display to the class (or classes) for which this display is valid, by adding an entry to the %CLASSES array. For example: NewObject => ['newdisplay'], This indicates that whenever Acebrowser is called upon to display an object of type "NewObject", it will display the object using the CGI script designated by the "newdisplay" display. If you have several displays that are appropriate for a class, you can bind them all to the class in the following fashion: NewObject => ['newdisplay','newerdisplay','newestdisplay'], When creating a link for an Acedb object, Acebrowser will choose the first display in the array. When the object is displayed, all three of the alternative displays will appear in the type selector. More information on writing display scripts can be found in the documentation for Ace::Browser::AceSubs. From the command line, run: perldoc Ace::Browser::AceSubs Writing New Searches -------------------- To create a new search, 1. Write a script following the model of one of the existing scripts. Ace::Browser::SearchSubs exports subroutines that are useful in managing the multiple pages of results produced by most search scripts. 2. Register the new script in the @SEARCHES array. Provide an explanatory name for the search script, and a pointer to its URL. More information on writing search scripts can be found in the documentation for Ace::Browser::SearchSubs. From the command line, run: perldoc Ace::Browser::SearchSubs FOR HELP Please write to the Acedb newsgroup, acedb@sanger.ac.uk for help or to report possible bugs. If you get really stuck, write to the author, lstein@cshl.org. Lincoln D. Stein September 24, 2001 AcePerl-1.92/README0000644000175000017500000001737207666266556013260 0ustar lsteinlsteinThis is version 1.86 of AcePerl, a Perl interface for the ACEDB object-oriented database. Designed specifically for use in genome sequencing projects, ACEDB provides powerful modeling and management services for biological and laboratory data. For others, it is a good open source introduction to the world of object-oriented databases See the ChangeLog for important notices, including recent user interfaces changes. Please see DISCLAIMER.txt for disclaimers of warranty. INSTALLATION: In addition to this package, you will need Perl 5.00503 or higher (5.6.0 or higher recommended), and the Digest::MD5 module. Both are available on CPAN (http://www.cpan.org). If you are using AcePerl to communicate with WormBase, a public server is running on host aceserver.cshl.org, port 2005. You can open a connection to this server like this: $db = Ace->connect('sace://aceserver.cshl.org:2005'); Otherwise, if you wish to communicate with your own ACEDB database, you must use ACEDB version 4.8a or higher, available from this location: ftp://ncbi.nlm.nih.gov/repository/acedb/ To take full advantage of the sequence annotation features in the Ace::Sequence and Ace::Sequence::Feature classes, you will need version 4.9r or higher. If you wish to use AcePerl in a client-server fashion, you must get sgifaceserver up and running. Some hints on installing the sgifaceserver application are given later in this README. Follow these steps to unpack, build and install AcePerl: 1. Unpack the AcePerl distribution with this command: gunzip -c AcePerl-X.XX.tar.gz | tar xvf - Replace X.XX with the current version number of AcePerl. 2. cd AcePerl-X.XX 3. perl Makefile.PL This script will ask you whether you wish to build: (1) the minimal package with support only for newer (socket) versions of the Ace server, (3) the maximum package, which supports both older (RPC) and newer (socket) versions of the Ace server, or (2) a version that supports the socket server and has some C language optimizations. Choice (3) is recommended. All versions will support local Acedb databases. The script will also ask you whether you wish to install support for the AceBrowser Web server extensions. Only answer yes if you are installing on a machine that already runs a web server and you wish to have AceBrowser installed. If you answer in the affirmative, then you will be asked a number of directory configuration questions. See README.ACEBROWSER for more details on installation. At this point, Makefile.PL will create the make files necessary to build AcePerl. Among other things, the Makefile.PL script will attempt to guess the type of your machine and its operating system. This information is needed to select the correct makefile in the ACEDB library directory, AcePerl-X.XX/ace/. If AcePerl fails to make correctly later in the process, it may be because the script guessed wrong. You can override this guess by setting the machine type using the ACEDB_MACHINE environment variable. On a C-shell or TC-shell machine, use a command like this one: setenv ACEDB_MACHINE ALPHA_4_GCC; perl Makefile.PL On a Bourne-shell or Korn-shell system, use: ACEDB_MACHINE=ALPHA_4_GCC; export ACEDB_MACHINE perl Makefile.PL You can find a list of machine definitions in AcePerl-X.XX/ace/wmake. There are lots of them, but only one or two per operating system, so it's usually pretty easy to choose the right one. The definitions have names like ALPHA_4_GCC_DEF. Before setting the corresponding environment variable, remove the "_DEF" from the end of the name. In case you're wondering the "4" stands for version 4 of the ACEDB server. Please drop me a line to let me know what you had to do to get the ACEDB libraries to compile. I'll fix up the Makefile so that it works correctly for the next person who tries it. 4. make This will build the ACEDB client library, libaceperl.a, in the ace subdirectory. It will then link in the Perl client subs. 5. make test (optional) You may "make test" to test the system. It will attempt to open a connection to a database at beta.crbm.cnrs-mop.fr:20000100. You may change these defaults by setting the environment variables ACEDB_HOST and ACEDB_PORT, or by defining them on the command line, as in: make test ACEDB_HOST=localhost ACEDB_PORT=200005 However, since some of the tests are dependent on specific values in the database, this may cause some tests to fail. Do not be alarmed if a handful of tests fail. Do be alarmed if all of the tests fail. 6. make install This will install AcePerl into your perl5 library directory. You may need to be root (superuser) in order to "make install". This is because Perl will want to install the newly-built files into its library tree, /usr/local/lib/perl5/site_perl (or something similar), and this tree is usually not writable by mere mortals. Do not despair: see the next section. INSTALLING ACEPERL IN A NON-STANDARD LOCATION By default, Perl will install AcePerl's library files within the site-specific subdirectory of its library tree, usually /usr/local/lib/perl5/site_perl. If you wish, you can install the library files elsewhere. Simply change to the AcePerl distribution directory and run the Makefile.PL script with the INSTALLSITELIB switch set to the full path of the directory you want to install into: perl Makefile.PL INSTALLSITELIB=/path/to/library Then "make" and "make install" as described before. You will now have to tell Perl where to find AcePerl. You can do this on a script-by-script basis, or by defining an environment variable that will affect all scripts. To tell a single script where to find AcePerl, add a "use lib" line to your script. Put it _before_ the "use Ace" line: use lib /path/to/library; use Ace; To change Perl's library search path so that it finds AcePerl automatically, define the PERL5LIB environment variable in your .login, .cshrc or .profile script. PERL5LIB is a colon-delimited list of directories in which Perl will search for included libraries. For example: setenv PERL5LIB "/path/to/library"; If AcePerl was built as part of the main Ace distribution, you will want to define PERL5LIB to be the location of the machine-specific build directory. For example: setenv PERL5LIB $HOME/ace/bin.LINUX_4_OPT Or you could reinstall AcePerl in the main Perl library tree just by entering the wperl/ subdirectory, and rerunning "perl Makefile.PL" without defining INSTALLSITELIB. See ACEDB.HOWTO in the docs/ subdirectory for instructions on obtaining and setting up the ACeDB database. You'll find other hints here too. USING ACEPERL A. Read the copious documentation perldoc Ace B. Review the examples A few useful examples can be found in the "examples" subdirectory. Among these is a script called "ace.pl", which implements a text interface to any local or remote ace database. If you have the Perl Term::readline module installed, it gives you command-line editing, completion, and history. The script "dump_cdna.pl" shows you how to dump out all spliced cDNAs from wormbase.org. Other dump scripts show similar tricks. You can use these as templates for doing other biologically interesting tricks. There is also family of CGI scripts that run on top of AcePerl to give a WebAce-like interface to Ace (it is not as feature-full as WebAce, but it is probably easier to set up and run). This package is now part of the AcePerl distribution, but is not installed unless you specifically request it. See README.ACEBROWSER for details. INSTALLING THE ACEDB SERVER See ACEDB.HOWTO in the docs/ directory for instructions on compiling acedb and installing the server application to start up when needed. Lincoln Stein lstein@cshl.org AcePerl-1.92/make_docs.PLS0000644000175000017500000000164007564777275014676 0ustar lsteinlstein#!/usr/local/bin/perl use Pod::Html; $marker = shift; print STDERR "Creating HTML documentation in docs...\n"; mkdir "docs",0755; mkdir "docs/Ace",0755; mkdir "docs/Ace/Sequence",0755; mkdir "docs/Ace/Browser",0755; mkdir "docs/Ace/Graphics",0755; foreach $pod ('Ace.pm',,) { (my $out = $pod) =~ s/\.pm$/.html/; if (open(POD,"-|")) { open (OUT,">docs/$out"); while () { if (//) { print OUT <

AcePerl Main Page END ; } else { print OUT; } } } else { # child process open STDERR,">/dev/null"; pod2html( $pod, '--podroot=.', '--podpath=.', '--noindex', '--htmlroot=/AcePerl/docs', "--infile=$pod", "--outfile=-" ); exit 0; } } system "touch $marker" if $marker; print STDERR " ....done!\n"; AcePerl-1.92/acebrowser/0000755000175000017500000000000011106333223014464 5ustar lsteinlsteinAcePerl-1.92/acebrowser/conf/0000755000175000017500000000000011106333223015411 5ustar lsteinlsteinAcePerl-1.92/acebrowser/conf/moviedb.pm0000644000175000017500000000610110126545473017407 0ustar lsteinlsteinuse Ace::Browser::LocalSiteDefs '$HTML_PATH'; # ========= DIRECTORIES ========= # base of all our scripts #$ROOT = '/movies'; $ROOT = '/cgi-bin/ace'; # base of our html files $DOCROOT = '/ace'; # base of our icons $ICONS = "$DOCROOT/ico"; # base of our images $IMAGES = "$DOCROOT/images"; # ========= $HOST ========= # name of the host to connect to $HOST = 'stein.cshl.org'; # ========= $PORT ========= # Port number to connect to $PORT = 200008; # ========= $STYLESHEET ========= # stylesheet to use $STYLESHEET = "$DOCROOT/stylesheets/moviedb.css"; # ========= $PICTURES ========== # Where to write temporary picture files to: # The URL and the physical location, which must be writable # by the web server. This is meaningless under Apache::Modperl. # Otherwise the value is determined by Makefile.PL @PICTURES = ($IMAGES => "$HTML_PATH/images"); # ========= @SEARCHES ========= # search scripts available # NOTE: the order is important @SEARCHES = ( text => { name => 'Text Search', url =>"$ROOT/searches/text", }, browser => { name => 'Class Browser', url => "$ROOT/searches/browser", }, query => { name => 'Acedb Query', url => "$ROOT/searches/query", }, ); $SEARCH_ICON = "$ICONS/unknown.gif"; # ========= %HOME ========= # Home page URL @HOME = ( $DOCROOT => 'Home Page' ); # ========= %DISPLAYS ========= # displays to show %DISPLAYS = ( movie => { url => "$ROOT/moviedb/movie", label => 'Movie Report', }, person => { url => "$ROOT/moviedb/person", label => 'Person Profile', }, tree => { 'url' => "generic/tree", 'label' => 'Tree Display', }, pic => { 'url' => "generic/pic", 'label' => 'Graphic Display', }, xml => { 'url' => "generic/xml", 'label' => 'XML Display', }, ); # ========= %CLASSES ========= # displays to show %CLASSES = ( Person => ['person'], Movie => ['movie'], # default is a special "dummy" class to fall back on Default => [ qw/tree xml pic/ ], ); # ========= &URL_MAPPER ========= # mapping from object type to URL. Return empty list to fall through # to default. sub URL_MAPPER { my ($display,$name,$class) = @_; return; } # ========= $BANNER ========= # Banner HTML # This will appear at the top of each page. $BANNER = <

END # ========= PRIVACY STATEMENT $PRINT_PRIVACY_STATEMENT = 1; # ========= FEEDBACK STATEMENT @FEEDBACK_RECIPIENTS = ( [ " $ENV{SERVER_ADMIN}", 'general complaints and suggestions', 1 ] ); # ========= $FOOTER ========= # Footer HTML # This will appear at the bottom of each page $FOOTER = ''; # configuration for the "basic" seqarch script @BASIC_OBJECTS = ('Any' => 'Anything', 'Movie' => 'Movie Title', 'Person' => 'Person (author/actor/director)', 'Director' => 'Director', 'Author' => 'Author', 'Actor' => 'Actor', 'Book' => 'Book'); 1; AcePerl-1.92/acebrowser/conf/default.pm0000644000175000017500000000750210126545473017414 0ustar lsteinlsteinuse Ace::Browser::LocalSiteDefs '$HTML_PATH'; # ========= DIRECTORIES ======= # base of all our scripts $ROOT = '/cgi-bin/ace'; # base of our html files $DOCROOT = '/ace'; # base of our icons $ICONS = "$DOCROOT/ico"; # base of our images $IMAGES = "$DOCROOT/images"; # ========= $HOST ========= # name of the host to connect to $HOST = 'stein.cshl.org'; # ========= $PORT ========= # Port number to connect to $PORT = 2005; # ========= $USERNAME ========= # Username for connections (none) $USERNAME = ''; # ========= $PASSWORD ========= # Password for connections (none) $PASSWORD = ''; # ========= $STYLESHEET ========= # stylesheet to use $STYLESHEET = "$DOCROOT/stylesheets/aceperl.css"; # ========= $PICTURES ========== # Where to write temporary picture files to: # The URL and the physical location, which must be writable # by the web server. This is meaningless under Apache::Modperl. # Otherwise the value is determined by Makefile.PL @PICTURES = ($IMAGES => "$HTML_PATH/images"); # ========= @SEARCHES ========= # search scripts available # NOTE: the order is important @SEARCHES = ( text => { name => 'Text Search', url =>"$ROOT/searches/text", }, browser => { name => 'Class Browser', url => "$ROOT/searches/browser", }, query => { name => 'Acedb Query', url => "$ROOT/searches/query", }, ); $SEARCH_ICON = "$ICONS/unknown.gif"; # ========= %HOME ========= # Home page URL @HOME = ( $DOCROOT => 'Home Page' ); # ========= %DISPLAYS ========= # displays to show %DISPLAYS = ( tree => { 'url' => "generic/tree", 'label' => 'Tree Display', 'icon' => "$ICONS/text.gif" }, pic => { 'url' => "generic/pic", 'label' => 'Graphic Display', 'icon' => "$ICONS/image2.gif" }, xml => { 'url' => "generic/xml", 'label' => 'XML Display', 'icon' => "$ICONS/text.gif" }, model => { 'url' => "generic/model", 'label' => 'AceDB Schema', 'icon' => "$ICONS/text.gif" }, ); # ========= %CLASSES ========= # displays to show %CLASSES = ( # default is a special "dummy" class to fall back on Default => [ qw/tree pic model xml/ ], ); # ========= &URL_MAPPER ========= # mapping from object type to URL. Return empty list to fall through # to default. sub URL_MAPPER { my ($display,$name,$class) = @_; # Small Ace inconsistency: Models named "#name" should be # transduced to Models named "?name" $name = "?$1" if $class eq 'Model' && $name=~/^\#(.*)/; my $n = CGI->escape("$name"); # looks superfluous, but avoids Ace::Object name conversions errors my $c = CGI->escape($class); # pictures remain pictures if ($display eq 'pic') { return ('pic' => "name=$n&class=$c"); } # otherwise display it with a tree else { return ('tree' => "name=$n&class=$c"); } } # ========= $BANNER ========= # Banner HTML # This will appear at the top of each page. $BANNER = <AceDB Database on $HOST:$PORT END ; # ========= PRIVACY STATEMENT $PRINT_PRIVACY_STATEMENT = 1; # ========= FEEDBACK STATEMENT @FEEDBACK_RECIPIENTS = ( [ " $ENV{SERVER_ADMIN}", 'general complaints and suggestions', 1 ] ); # ========= $FOOTER ========= # Footer HTML # This will appear at the bottom of each page $FOOTER = ''; # configuration for the "basic" seqarch script @BASIC_OBJECTS = ('Any' => 'Anything', 'Locus' => 'Confirmed Gene', 'Predicted_gene' => 'Predicted Gene', 'Sequence' => 'Sequence (any)', 'Genome_sequence', => 'Sequence (genomic)', 'Author' => 'Author', 'Genetic_map' => 'Genetic Map', 'Sequence_map' => 'Sequence Map', 'Strain' => 'Worm Strain', 'Clone' => 'Clone' ); 1; AcePerl-1.92/acebrowser/conf/simple.pm0000644000175000017500000000761410126545473017265 0ustar lsteinlsteinuse Ace::Browser::LocalSiteDefs '$HTML_PATH'; # ========= DIRECTORIES ======= # base of all our scripts $ROOT = '/cgi-bin/ace'; # base of our html files $DOCROOT = '/ace'; # base of our icons $ICONS = "$DOCROOT/ico"; # base of our images $IMAGES = "$DOCROOT/images"; # ========= $HOST ========= # name of the host to connect to $HOST = 'localhost'; # ========= $PORT ========= # Port number to connect to $PORT = 2005; # ========= $STYLESHEET ========= # stylesheet to use $STYLESHEET = "$DOCROOT/stylesheets/aceperl.css"; # ========= $USERNAME ========= # Username for connections (none) $USERNAME = ''; # ========= $PASSWORD ========= # Password for connections (none) $PASSWORD = ''; # ========= $PICTURES ========== # Where to write temporary picture files to: # The URL and the physical location, which must be writable # by the web server. This is meaningless under Apache::Modperl. # Otherwise the value is determined by Makefile.PL @PICTURES = ($IMAGES => "$HTML_PATH/images"); # ========= @SEARCHES ========= # search scripts available # NOTE: the order is important @SEARCHES = ( 'searches/basic' => 'Basic Search', 'searches/text' => 'Text Search', 'searches/browser' => 'Class Browser', 'searches/query' => 'Acedb Query', ); @SEARCHES = ( basic => { name => 'Basic Search', url => "$ROOT/searches/basic", }, text => { name => 'Text Search', url =>"$ROOT/searches/text", }, browser => { name => 'Class Browser', url => "$ROOT/searches/browser", }, query => { name => 'Acedb Query', url => "$ROOT/searches/query", }, ); $SEARCH_ICON = "$ICONS/unknown.gif"; # ========= %HOME ========= # Home page URL @HOME = ( $DOCROOT => 'Home Page' ); # ========= %DISPLAYS ========= # displays to show %DISPLAYS = ( tree => { 'url' => "generic/tree", 'label' => 'Tree Display', 'icon' => "$ICONS/text.gif" }, pic => { 'url' => "generic/pic", 'label' => 'Graphic Display', 'icon' => "$ICONS/image2.gif" }, xml => { 'url' => "generic/xml", 'label' => 'XML Display', 'icon' => "$ICONS/text.gif" }, model => { 'url' => "generic/model", 'label' => 'AceDB Schema', 'icon' => "$ICONS/text.gif" }, ); # ========= %CLASSES ========= # displays to show %CLASSES = ( # default is a special "dummy" class to fall back on Default => [ qw/tree pic model xml/ ], ); # ========= &URL_MAPPER ========= # mapping from object type to URL. Return empty list to fall through # to default. sub URL_MAPPER { my ($display,$name,$class) = @_; # Small Ace inconsistency: Models named "#name" should be # transduced to Models named "?name" $name = "?$1" if $class eq 'Model' && $name=~/^\#(.*)/; my $n = CGI::escape("$name"); # looks superfluous, but avoids Ace::Object name conversions errors my $c = CGI::escape($class); # pictures remain pictures if ($display eq 'pic') { return ('pic' => "name=$n&class=$c"); } # otherwise display it with a tree else { return ('tree' => "name=$n&class=$c"); } } # ========= $BANNER ========= # Banner HTML # This will appear at the top of each page. $BANNER = <

AceBrowser Default Page

This is the default page installed by AceBrowser. You'd better change it!

If you have stored the cgi-bin scripts at the URL http://your.host/cgi-bin/ace, then the following links should work. Otherwise change them as appropriate.

  1. Text Search
  2. Class Browser
  3. Ace Query
AcePerl Home Page
Last modified: Wed Sep 19 11:59:19 EDT 2001 AcePerl-1.92/acebrowser/cgi-bin/0000755000175000017500000000000011106333223015774 5ustar lsteinlsteinAcePerl-1.92/acebrowser/cgi-bin/misc/0000755000175000017500000000000011106333223016727 5ustar lsteinlsteinAcePerl-1.92/acebrowser/cgi-bin/misc/feedback0000755000175000017500000001320707353756476020440 0ustar lsteinlstein#!/usr/bin/perl # -*- Mode: perl -*- # file: feedback # Provide feedback to data curator(s) use strict; use CGI 2.42 qw(:standard); use Ace::Browser::AceSubs qw(:DEFAULT Header DB_Name); use vars '@FEEDBACK_RECIPIENTS'; # This page called with the parameters: # recipients- numeric index(es) for recipients of message # name - name of object to update # class - class of object to update # from - sender's e-mail address # subject - subject of mail message # remark - body of e-mail message my $object_name = param('name'); my $object_class = param('class'); my $where_from = param('referer') || referer(); if (param('return') && $where_from !~ /\/feedback/ ) { print redirect($where_from); exit 0; } PrintTop(undef,undef,'Feedback Page'); if (Configuration->Feedback_recipients) { @FEEDBACK_RECIPIENTS = @{Configuration->Feedback_recipients}; if (param('submit') && send_mail($object_name,$object_class,$where_from)) { print_confirmation(); } else { print start_form; print_instructions(); print_form( $object_name,$object_class,DB_Name(),$where_from ); print end_form; } } else { print p("No recipients for feedback are defined."); print start_form(), hidden(-name=>'referer',-value=>$where_from),br, submit(-name=>'return',-value=>'Cancel & Return',-class=>'error'), end_form(); } PrintBottom; sub print_top { my $title = 'Data Submissions and Comments'; print start_html ( '-Title' => $title, '-style' => Style(), ), Header, h1($title); } sub print_instructions { my @defaults; for (my $i=0; $i<@FEEDBACK_RECIPIENTS; $i++) { push @defaults,$i if $FEEDBACK_RECIPIENTS[$i][2]; } print p({-class=>'small'}, "Use this form to send new data or corrections to", "the maintainers of this database. An e-mail message", "will be sent to the individuals selected from the list", "below."), blockquote({-class=>'small'}, checkbox_group(-name => 'recipients', -Values => [(0..$#FEEDBACK_RECIPIENTS)], -Labels => { map { $_=>"$FEEDBACK_RECIPIENTS[$_]->[0] ($FEEDBACK_RECIPIENTS[$_]->[1])" } (0..$#FEEDBACK_RECIPIENTS) }, -defaults=>\@defaults, -linebreak=>1)); } sub print_bottom { print Footer; } sub print_form { my ($name,$class,$db,$where_from) = @_; print table( TR(th({-align=>'RIGHT'},"Your full name:"), td({-align=>'LEFT'},textfield(-name=>'full_name',-size=>40))), TR(th({-align=>'RIGHT'},"Your institution:"), td({-align=>'LEFT'},textfield(-name=>'institution',-size=>40))), TR(th({-align=>'RIGHT'},"Your e-mail address:"), td({-align=>'LEFT'},textfield(-name=>'from',-size=>40))), TR(th({-align=>'RIGHT'},"Subject:"), td({-align=>'LEFT'},textfield(-name=>'subject', -value=>$class && $name ? "Comments on $class $name ($db db)": '', -size=>60))), TR(th({-colspan=>2,-align=>'LEFT'},'Comment or Correction:')), TR(td({-colspan=>2},textarea(-name=>'remark', -rows=>12, -cols=>80, -wrap=>'VIRTUAL' ))), ), hidden(-name=>'name',-value=>$name), hidden(-name=>'class',-value=>$class), hidden(-name=>'db',-value=>$db), hidden(-name=>'referer',-value=>$where_from),br, submit(-name=>'return',-value=>'Cancel & Return',-class=>'error'), submit(-name=>'submit',-value=>'Submit Data'); } sub send_mail { my ($obj_name,$obj_class,$where_from) = @_; $obj_name ||= '(unknown name)'; $obj_class ||= '(unknown class)'; $where_from ||= '(unknown)'; my @addresses = map { $FEEDBACK_RECIPIENTS[$_] ? $FEEDBACK_RECIPIENTS[$_]->[0] : () } param('recipients'); my @missing; push @missing,"At least one message recipient" unless @addresses; push @missing,"Your full name (needed for proper attribution)" unless my $name = param('full_name'); push @missing,"Your institution (needed for proper attribution)" unless my $institution = param('institution'); push @missing,"Your e-mail address" unless my $from = param('from'); push @missing,"A properly formatted e-mail address" if $from && $from !~ /.+\@[\w.]+/; push @missing,"A subject line" unless my $subject = param('subject'); push @missing,"A comment or correction" unless my $remark = param('remark'); if (@missing) { print p({-class=>'error'}, "Your submission could not be processed because", "the following information was missing:"), ol({-class=>'error'}, li(\@missing)), p({-class=>'error'}, "Please fill in the missing fields and try again."); return; } my $error = <'restart',-label=>'Submit Another Report'), hidden('referer'), submit(-name=>'return',-label=>'Return to Database'), end_form; } AcePerl-1.92/acebrowser/cgi-bin/misc/privacy0000755000175000017500000000214007353756507020356 0ustar lsteinlstein#!/usr/bin/perl # -*- Mode: perl -*- # file: privacy # Privacy statement use strict; use Ace::Browser::AceSubs; use CGI 2.42 qw/redirect h1 start_form end_form start_html hidden submit param referer p/; my $where_from = param('referer') || referer(); if (param('return') && $where_from !~ /\/privacy/ ) { print redirect($where_from); exit 0; } PrintTop(undef,undef,'Privacy Statement'); print p( "This server logs the IP address of your browser and each database query.", "This is done in order to track usage statistics", "and to identify operational problems. This information is not used", "to identify individuals or organizations, and is never shared with third", "parties." ), p( "Cookies are used by the search pages in order to bookmark your search", "requests. They do not persist after you exit the browser, and are never", "used for identification or tracking purposes." ), start_form, hidden(-name=>'referer',-value=>$where_from), submit(-name=>'return',-label=>'Return to Database'), end_form; PrintBottom(); AcePerl-1.92/acebrowser/cgi-bin/generic/0000755000175000017500000000000011106333223017410 5ustar lsteinlsteinAcePerl-1.92/acebrowser/cgi-bin/generic/pic0000755000175000017500000003207510157643406020134 0ustar lsteinlstein#!/usr/bin/perl # -*- Mode: perl -*- # file: pic # NOTE: This is a very confusing looking script. It is basically a client-side image map, but it # uses a variety of workarounds so that when the user clicks in an area that isn't part of the map, # the coordinates of the click are passed back to the script as a server-side image map. It uses # javascript tricks to do this, but unfortunately the tricks are different for Netscape and Internet # explorer. use strict; use Ace 1.51; use File::Path; use CGI 2.42 qw/:standard escape Map Area Layer *p *TR *td *table/; use CGI::Carp; use Ace::Browser::AceSubs qw(:DEFAULT Style Url); use Ace::Browser::GeneSubs 'NCBI'; # these constants should be moved into configuration file use constant DISABLED => 0; use constant WIDTH => 1024; use constant HEIGHT => 768; use constant ICONS => Configuration()->Icons; use constant UP_ICON => ICONS .'/a_up.gif'; use constant DOWN_ICON => ICONS .'/a_down.gif'; use constant ZOOMIN_ICON => ICONS .'/a_zoomin.gif'; use constant ZOOMOUT_ICON => ICONS .'/a_zoomout.gif'; use constant JSCRIPT => <<<'END'; M1TE&.#=A8`$W`/```+\``/___RP`````8`$W```"_H2/<<'M#Q^(+BF%;%YR M3PJ&XDB6YCERE8&V[@O'((LQ-"VKW?KAM?W!!!LXG>R(3+I\Q*'R"8U2@D4@ MTFC=_8A-;?LUV>SNLAH&I+1]&G7BOJ9 MV0G(BE)(FBDK(2OI=EI7-%B:93C9BURZ:Y8\9^.[E:S1PX-*?5SWT[<-O:D" MKMCMR!QQ`[-[')F(:9[XFGKGX3[7GDV=.OK'I?U\[=$73><`%I0F<%^9*L+> M=8/D\.%`B`F#V8-7"XL__GHB\/F*1&F-CGITTF&RYHI<(W%^BAG$]C*C-W@K MJ9PDR$R>MV4D_S"Z"`9:BDOS$J);.*PH+*6@_AD]2NL42)$\ERD+RNXG2)H% M9Q[D&FXBB;!+D(H="G.:4F"+N'78QO5"TKAOY9H#M>JL1*=[+6YERA+J5X4Q MM<(]X6SPE*>).X8]_W=8=^6V:2Z="-PL%6KG"4ZR:AWDVK!:ME]." MT^;;_#(?X7[1QJ&K.)G/QIL\CY(JC*AS5=^2US5BLB?-.VJ-.&'BB__OW\ M_ON?L>Q?@`(.2&"!!I9T8((*+LA@@[HPY&"$$DY(87_'58AAAAINR&&''GX( M8H@"XL>?1DNU]H*)))+!G8DBOAA1"2OFMTE'5!V!QXR"G&@>C##J*.-^QJR5 M!)`I/(C13R6.H22#1MJH7TM62?$D4&,E56486:;4X4[9&#$??.=]EU)&HI!5 MC%3O=<&<*6[>=`:6TKUIQ9RB/&1F)U'A])9[/K57&V9IXCG<4GPB1UJ=*N68 MU47AP)8;A>;$) MJ$.0!D2,2I2*QNB#N7Q6J4D>P81/9;'(^BI'6HS:_M!>7Z[R3:'.S8K5A81) MF:@VL2J::#VY(A9K3\1*%RI[KCK+%TVAU74G;]=5FV2V4U8++92P.II<2)=> M]2F`,U)K'EFOH59:NY@"9FY>C$;J+VP"WQIP;`K?ZZ]1\?)8<*N3;1NG/:/: MVR.[LRE;[L\-)Z;*7Y"C>IE0++A(Q>/L?RV[B`A0+R+M9Q74G'P*Q44U*X=O_+RRTQ4IRW8D+O MG:J?8G;L8R!;-@YYE$U&_J[EY)1?;J'EF%_Q^.:>/U'XYVIH+GKIII^.>NJ; MNUA@YZJ__B/IDL-.>^W]VHY[[IFCJ'OO'I;,-ISVM0VTM,\!?VB??;)W8O*^ M/W\9.$MSJNFC]!5-SL,#Z:7I/Z%#WWO*D-YA\W0G1]N\QIFM6A_CX./^<-G? ML<[G^3V78^/Z:=G_ON_0BJ\D5#T->SN0A``']C+9]<]T`*237Z3&/^W1KUE_ M2>`"W]=`\KC/4Q%\%]VBID%E\>^"\$O8A8X#M./U+(7`X]WRQ"4VHG&*A*^3 M%M7FH[[%\28Z6`"83!J5`#&YCH8A6E%;'`2D(Q)QB5;CDFB0F*)#,'&*+BQ3 =&@A;QSHK(H2*7!3/E;(XHBH9KXMD+*,9?5<``#L` ` END #` ; my $click = param('click'); my $obj = GetAceObject(); unless ($obj) { AceError(<name and class, where "name" and "class" correspond to the name and class of the Ace object of interest. END ; } my $style = Style(); $style->{'code'} =< '#FFFFFF', # important to have a white bg for the gifs '-Style' => $style, -Script => JSCRIPT ); print_prompt(); AceNotFound() unless $obj; display_object($obj,$click); PrintBottom(); sub print_prompt { print start_form(-name=>'question'), table( TR (th('Name'),td(textfield(-name=>'name')), th('Class'),td(textfield(-name=>'class',-size=>15,-onChange=>'document.question.submit()')), td(submit({-style=>'background: white',-name=>'Change'}))), ), end_form; } sub display_object { my ($obj,$click) = @_; my $class = param('class'); my $name = $obj->name; if (DISABLED) { print h1({-class=>'error'},'Sorry, but graphical displays have been disabled temporarily.'); return; } # special case for sequences if (lc($class) eq 'sequence' && $name =~ /SUPERLINK|CHROMOSOME/) { print h1('This sequence is too large to display. Try a shorter segment.'); return; } build_map_navigation_panel($obj,$name,$class) if $class =~ /Map/i; my $map_start = param('map_start'); my $map_stop = param('map_stop'); my $has_coords = defined $map_start && defined $map_stop; my $safe_name = $name; $safe_name=~tr/[a-zA-Z0-9._\-]/_/c; my $db = Configuration->Name; $db=~s!^/!!; my $path = join('/',$db,$class); umask 002; # want this writable by group my ($pic,$picroot) = @{Configuration()->Pictures}; if ($ENV{MOD_PERL} && Apache->can('request')) { # we have apache, so no reason not to take advantage of it my $r = Apache->request; my $subr = $r->lookup_uri($pic ."/"); $picroot = $subr->filename if $subr; } mkpath (["$picroot/$path"],0,0777) || AceError("Can't create directory to store image in") unless -d "$picroot/$path"; # should be some sort of state variable? $safe_name .= "." . param('click') if param('click'); $safe_name .= ".start=$map_start,stop=$map_stop" if $has_coords; $safe_name .= ".gif"; my $image_file = "$picroot/$path/$safe_name"; my $image_path = "$pic/$path/$safe_name"; # get the parameters for the image generation my @clicks = map { [ split('-',$_) ] } split(',',param('click')); my @param = (-clicks=>\@clicks); if ($class =~ /Map/) { push(@param,(-dimensions=>[WIDTH,HEIGHT])); push(@param,(-coords=>[param('map_start'),param('map_stop')])) if $has_coords; } my ($gif,$boxes) = $obj ? $obj->asGif(@param) : (); unless (-e $image_file && -M $image_file < 0) { local(*F); open (F,">$image_file") || AceError("Can't open image file $image_file for writing: $!\n"); print F $gif || unpack("u",ERROR_GIF); close F; } my $u = Url('pic') . "?" . query_string(); $u .= param('click') ? ',' : '&click='; print img({-src => $image_path, -name => 'theMapImg', -border=> 0, # this is for Internet Explorer, has no effect on Netscape! -onClick=>"send_click(event,'$u')", -usemap=>'#theMap', -isMap=>undef}), ; print_map($name,$class,$boxes); } sub print_map { my ($name,$class,$boxes) = @_; my @lines; my $old_clicks = param('click'); Delete('click'); # Collect some statistics in order to inhibit those features # that are too dense to click on sensibly. my %centers; foreach my $box (@$boxes) { my $center = center($box->{'coordinates'}); $centers{$center}++; } my $user_agent = http('User_Agent'); my $modern = $user_agent=~/Mozilla\/([\d.]+)/ && $1 >= 4; my $max = Configuration()->Max_in_column || 100; foreach my $box (@$boxes) { my $center = center($box->{'coordinates'}); next if $centers{$center} > $max; my $coords = join(',',@{$box->{'coordinates'}}); (my $jcomment = $box->{'comment'} || "$box->{class}:$box->{name}" ) =~ s/'/\\'/g; # escape single quotes for javascript CASE : { if ($box->{name} =~ /gi\|(\d+)/ or ($box->{class} eq 'System' and $box->{'comment'}=~/([NP])ID:g(\d+)/)) { my($db) = $2 ? $1 : 'n'; my($gid) = $2 || $1; my $url = NCBI . "?db=$db&form=1&field=Sequence+ID&term=$gid"; push(@lines,qq()); last CASE; } last CASE if $box->{class} eq 'System'; if ($box->{class} eq 'BUTTON') { my ($c) = map { "$_->[0]-$_->[1]" } [ map { 2+$_ } @{$box->{coordinates}}[0..1]]; my $clicks = $old_clicks ? "$old_clicks,$c" : $c; my $url = Url('pic',query_string() . "&click=$clicks"); push(@lines,qq()); last CASE; } my $n = escape($box->{'name'}); my $c = escape($box->{'class'}); my $href = Object2URL($box->{'name'},$box->{'class'}); push(@lines,qq()); } } # Create default handling. Bad use of javascript, but can't think of any other way. my $url = Url('pic', query_string()); my $simple_url = $url; $url .= "&click=$old_clicks"; $url .= "," if $old_clicks; push(@lines,qq()) if $modern; print qq(),join("\n",@lines),qq(),"\n"; } # special case for maps # this builds the whole map control/navigation panel sub build_map_navigation_panel { my $obj = shift; my ($name,$class) = @_; my $map_start = param ('map_start'); my $map_stop = param ('map_stop'); my($start,$stop) = $obj->asGif(-getcoords=>1); $map_start ||= $start; $map_stop ||= $stop; my($min,$max) = get_extremes($obj->db,$name); # this section is responsible for centering on the place the user clicks if (param('click')) { my ($x,$y) = split '-',param('click'); my $pos = $map_start + $y/HEIGHT * ($map_stop - $map_start); my $offset = $pos - ($map_start + $map_stop)/2; $map_start += $offset; $map_stop += $offset; param('map_start' => $map_start); param('map_stop' => $map_stop); Delete('click'); } my $self = url(-path_info=>1); my $half = ($map_stop - $map_start)/2; my $a1 = $map_start - $half; $a1 = $min if $min > $a1; my $a2 = $map_stop - ($map_start - $a1); my $b2 = $map_stop + $half; $b2 = $max if $b2 > $max; my $b1 = $b2 - ($map_stop - $map_start); my $m1 = $map_start + $half/2; my $m2 = $map_stop - $half/2; print start_table({-border=>1}); print TR(td({-align=>'CENTER',-class=>'datatitle',-colspan=>2},'Map Control')); print start_TR(); print td( table({-border=>0}, TR(td(' '), td( $map_start > $min ? a({-href=>"$self?name=$name;class=$class;map_start=$a1;map_stop=$a2"}, img({-src=>UP_ICON,-align=>'MIDDLE',-border=>0}),' Up') : font({-color=>'#A0A0A0'},img({-src=>UP_ICON,-align=>'MIDDLE',-border=>0}),' Up') ), td(' ') ), TR(td({-valign=>'CENTER',-align=>'CENTER'}, a({-href=>"$self?name=$name;class=$class;map_start=$a1;map_stop=$b2"}, img({-src=>ZOOMOUT_ICON,-align=>'MIDDLE',-border=>0}),' Shrink') ), td({-valign=>'CENTER',-align=>'CENTER'}, a({-href=>"$self?name=$name;class=$class;map_start=$min;map_stop=$max"},'WHOLE') ), td({-valign=>'CENTER',-align=>'CENTER'}, a({-href=>"$self?name=$name;class=$class;map_start=$m1;map_stop=$m2"}, img({-src=>ZOOMIN_ICON,-align=>'MIDDLE',-border=>0}),' Magnify') ) ), TR(td(' '), td( $map_stop < $max ? a({-href=>"$self?name=$name;class=$class;map_start=$b1;map_stop=$b2"}, img({-src=>DOWN_ICON,-align=>'MIDDLE',-border=>0}),' Down') : font({-color=>'#A0A0A0'},img({-src=>DOWN_ICON,-align=>'MIDDLE',-border=>0}),' Down') ), td(' ')) ) ); print start_td({-rowspan=>2}); print start_form; print start_p; print hidden($_) foreach qw(class name); print 'Show region between: ', textfield(-name=>'map_start',-value=>sprintf("%.2f",$map_start),-size=>8,-override=>1), ' and ', textfield(-name=>'map_stop',- value=>sprintf("%.2f",$map_stop),-size=>8,-override=>1), ' '; print submit('Change'); print end_p; print end_form; print end_td(),end_TR(),end_table(); } sub get_extremes { my $db = shift; my $chrom = shift; my $select = qq(select gm[Position] from g in object("Map","$chrom")->Contains[2], gm in g->Map where gm = "$chrom"); my @positions = $db->aql("select min($select),max($select)"); my ($min,$max) = @{$positions[0]}[0,1]; return ($min,$max); } sub center { my $c = shift; my ($left,$right) = @{$c}[0,2]; # round to nearest 2 pixels int( ($left + (($right-$left)/2)) / 2 ) * 2; } AcePerl-1.92/acebrowser/cgi-bin/generic/xml0000755000175000017500000000112607353666247020166 0ustar lsteinlstein#!/usr/bin/perl # generic xml display # should work with any data model use strict; use vars qw($DB); use Ace 1.65; use CGI 2.42 qw/:standard :html3 escape/; use CGI::Carp qw/fatalsToBrowser/; use Ace::Browser::AceSubs; AceError(<name and class, where "name" and "class" correspond to the name and class of the Ace object of interest. END my $obj = GetAceObject() || AceNotFound(); print header('text/plain'); print qq(\n\n); print $obj->asXML; AcePerl-1.92/acebrowser/cgi-bin/generic/tree0000755000175000017500000000717207657737137020340 0ustar lsteinlstein#!/usr/bin/perl # generic tree display # should work with any data model use strict; use vars qw/$DB $URL $NAME $CLASS/; use Ace 1.51; use CGI 2.42 qw/:standard :html3 escape/; use CGI::Carp qw/fatalsToBrowser/; use Ace::Browser::AceSubs qw(:DEFAULT Url); use Ace::Browser::TreeSubs; my $obj = GetAceObject(); unless ($obj) { AceError(<name and class, where "name" and "class" correspond to the name and class of the Ace object of interest. END } PrintTop($obj); print_prompt(); AceNotFound() unless $obj; display_object($obj); PrintBottom(); sub print_prompt { print start_form(-name=>'question'), table( TR (th('Name'),td(textfield(-name=>'name')), th('Class'),td(textfield(-name=>'class',-size=>15,-onChange=>'document.question.submit()')), td(submit({-style=>'background: white',-name=>'Change'}))), ), end_form; } sub display_object { my $obj = shift; my $name = $obj->name; my $class = $obj->class; my ($n,$c) = (escape($name),escape($class)); my $myimage = ($class =~ /^Picture/ ? $obj->Pick_me_to_call->right->right : 'No_Image') ; if ($class eq 'LongText'){ print $obj->asHTML(sub { pre(shift) }); } else{ print $obj->asHTML(\&to_href) || strong('No more text information about this object in the database'), "\n"; } } sub to_href { my $obj = shift; unless ($obj->isObject or $obj->isTag) { if ($obj=~/\S{50}/){ # if you have >50 chars without a space $obj=~s/(\S{50})/$1\n/g; # add some $obj = "
$obj
";# and assume preformatted (e.g. seq) } else { $obj =~s/\\n/
/g; } return ($obj,0); } # if we get here, we're dealing with an object or tag my $name = $obj->name; # modperl screws up with subroutine references for some reason my $page_name = param('name'); my $page_class = param('class'); my %squash = map { $_ => 1; } grep($_ ne '',param('squash')); my %expand = map { $_ => 1; } grep($_ ne '',param('expand')); my ($n,$c) = (escape($name),escape($obj->class)); my ($pn,$pc) = (escape($page_name),escape($page_class)); my $cnt = $obj->col; # here's a hack case for external images if ($obj->isTag && $name eq 'Pick_me_to_call' && $obj->right(2)=~/\.(jpg|jpeg|gif)$/i) { return (td({-colspan=>2},img({-src=>AceImageHackURL($obj->right(2))})),1,1); } my $title = $name; if ($cnt > 1) { if ($squash{$name} || ($cnt > MAXEXPAND && !$expand{$name})) { my $to_squash = join('&squash=',map { escape($_) } grep $name ne $_,keys %squash); my $to_expand = join('&expand=',map { escape($_) } (keys %expand,$name)); return (a({-href=>Url(url(-relative=>1),"name=$pn&class=$pc") . ($to_squash ? "&squash=$to_squash" : '') . ($to_expand ? "&expand=$to_expand" : '') . "#$name", -name=>"$name", -target=>"_self"}, b(font({-color=>CLOSEDCOLOR},"$title ($cnt)"))), 1); } else { my $to_squash = join('&squash=',map { escape($_) } (keys %squash,$name)); my $to_expand = join('&expand=',map { escape($_) } grep $name ne $_,keys %expand); return (a({-href=>Url(url(-relative=>1), "name=$pn&class=$pc") . ($to_squash ? "&squash=$to_squash" : '') . ($to_expand ? "&expand=$to_expand" : '') . "#$name", -name=>"$name", -target=>"_self"}, b(font({-color=>OPENCOLOR},"$title"))), 0); } } return i($title) if $obj->isComment; if ($obj->isObject) { my $href = Object2URL($obj); return (a({ -href=>$href},$title), 0); } if ($obj->isTag) { return ("$title",0); } # shouldn't ever get here. } AcePerl-1.92/acebrowser/cgi-bin/generic/model0000755000175000017500000000523110157643456020460 0ustar lsteinlstein#!/usr/bin/perl # -*- Mode: perl -*- # file: model # do an internal redirect to show the model for selected object use strict; use CGI qw(:standard escape); use Ace::Browser::AceSubs; use Ace::Browser::TreeSubs; # get the requested object my $object = GetAceObject; PrintTop(param('name'),param('class'),"Acedb Schema for Class ".param('class')); # get its model my $db = OpenDatabase; my $class = $object->class; my ($model) = $db->fetch(Model=>"?$class"); unless ($model) { AceError("No model of type ?$class found"); PrintBottom(); exit 0; } print_tree($model); PrintBottom(); exit 0; sub print_tree { my $obj = shift; print $obj->asHTML(\&to_href) || strong('No more text information about this object in the database'),"\n"; } # this is cut-and-paste out of etree, but with simplifications sub to_href { my $obj = shift; unless ($obj->isObject or $obj->isTag) { $obj =~s/\\n/
/g; return ($obj,0); } # if we get here, we're dealing with an object or tag my $name = $obj->name; # modperl screws up with subroutine references for some reason my $page_name = param('name'); my $page_class = param('class'); my %squash = map { $_ => 1; } grep($_ ne '',param('squash')); my %expand = map { $_ => 1; } grep($_ ne '',param('expand')); my ($n,$c) = (escape($name),escape($obj->class)); my ($pn,$pc) = (escape($page_name),escape($page_class)); my $cnt = $obj->col; my $title = $name; if ($cnt > 1) { if ($squash{$name} || ($cnt > MAXEXPAND && !$expand{$name})) { my $to_squash = join('&squash=',map { escape($_) } grep $name ne $_,keys %squash); my $to_expand = join('&expand=',map { escape($_) } (keys %expand,$name)); return (a({-href=>url(-relative=>1,-path_info=>1) . "?name=$pn&class=$pc" . ($to_squash ? "&squash=$to_squash" : '') . ($to_expand ? "&expand=$to_expand" : '') . "#$name", -name=>"$name", -target=>"_self"}, b(font({-color=>CLOSEDCOLOR},"$title ($cnt)"))), 1); } else { my $to_squash = join('&squash=',map { escape($_) } (keys %squash,$name)); my $to_expand = join('&expand=',map { escape($_) } grep $name ne $_,keys %expand); return (a({-href=>url(-relative=>1,-path_info=>1) . "?name=$pn&class=$pc" . ($to_squash ? "&squash=$to_squash" : '') . ($to_expand ? "&expand=$to_expand" : '') . "#$name", -name=>"$name", -target=>"_self"}, b(font({-color=>OPENCOLOR},"$title"))), 0); } } return i($title) if $obj->isComment; if ($obj->isObject) { my $href = Object2URL($obj); return (a({ -href=>$href},$title), 0); } if ($obj->isTag) { return ("$title",0); } # shouldn't ever get here. } AcePerl-1.92/acebrowser/cgi-bin/generic/acetable0000755000175000017500000000220607352110445021105 0ustar lsteinlstein#!/usr/bin/perl use strict 'vars'; use vars qw/$DB $URL $NAME $CLASS %PAPERS/; use Ace 1.38; use CGI 2.42 qw/:standard :html3 escape/; use CGI::Carp qw/fatalsToBrowser/; use Ace::Browser::AceSubs; AceInit(); $NAME = param('name'); #$PARMS = param('parms'); # fetch database handle $DB = OpenDatabase() || AceError("Couldn't open database."); AceHeader(); AceError(<name and parms, where "name" is the name of a table definition in acedb END display_table($NAME," "); exit 0; sub display_table { my ($name,$parms) = @_; my $obj = $DB->raw_query("table -title -n $name $parms") || AceMissing($name,$parms); my ($n,$c) = (escape($name),escape($parms)); print start_html(-Title=>"$name: $parms", -Style=>STYLE, -Class=>'tree', -Bgcolor=>BGCOLOR_TREE), h1("$name: $parms"), &show_table($obj), #$obj->asHTML() || strong('No more text information about this object in the database'), FOOTER, end_html; } sub show_table { my $obj = shift; my $dna = "$obj"; #$dna=~s/(\w{50})/$1/g; return (pre($dna),0); } AcePerl-1.92/acebrowser/cgi-bin/moviedb/0000755000175000017500000000000011106333223017421 5ustar lsteinlsteinAcePerl-1.92/acebrowser/cgi-bin/moviedb/movie0000755000175000017500000000214407353756562020517 0ustar lsteinlstein#!/usr/bin/perl # -*- Mode: perl -*- # file: movie # Moviedb "movie" display use strict; use lib '..'; use vars '$DB'; use Ace 1.51; use Ace::Browser::AceSubs; use CGI 2.42 qw/:standard :html3 escape/; my $movie = GetAceObject(); PrintTop($movie,'Movie'); print_prompt(); AceNotFound() unless $movie; print_report($movie); PrintBottom(); exit 0; sub print_prompt { print start_form(), p("Database ID", textfield(-name=>'name'), hidden(class=>'Movie'), ), end_form; } sub print_report { my $movie = shift; print h2($movie->Title); print p("Directed by ",map { ObjectLink($_,$_->Full_name) } $movie->Director); print table( TR({-align=>'LEFT'}, th('Released'), td($movie->Released)), TR({-align=>'LEFT'}, th(em('Starring')), td(map { ObjectLink($_,$_->Full_name) } $movie->Cast)), TR({-align=>'LEFT'}, th(em('Writer(s)')), td(map { ObjectLink($_,$_->Full_name) } $movie->Writer)), $movie->Based_on ? (TR({-align=>'LEFT'}, th(em('Adapted from')), td(map { ObjectLink($_,$_->Title) } $movie->Based_on))) : '', ); } AcePerl-1.92/acebrowser/cgi-bin/moviedb/person0000755000175000017500000000353707353756554020716 0ustar lsteinlstein#!/usr/local/bin/perl # -*- Mode: perl -*- # file: person # Moviedb "person" display use strict; use lib '..'; use vars '$DB'; use Ace 1.51; use Ace::Browser::AceSubs; use CGI 2.42 qw/:standard :html3 escape/; my $person = GetAceObject(); PrintTop($person,'Person'); print_prompt(); AceNotFound() unless $person; print_report($person); PrintBottom(); sub print_prompt { print start_form({-name=>'form1',-action=>Url(url(-relative=>1))}), p("Database ID", hidden(class=>'Person'), textfield(-name=>'name') ), end_form; } sub print_report { my $person = shift; print h2($person->Full_name); if (my @address = $person->Address(2)) { print h3('Contact Information'),blockquote(address(join(br,@address))); print a({-href=>'mailto:' . $person->Email(1)},"Send e-mail to this person") if $person->Email; } else { print p(font({-color=>'red'},'No contact information in database')); } if ($person->Born || $person->Height) { print h3('Fun Facts'), table({-border=>undef}, TR({-align=>'LEFT'}, th('Height'), td($person->Height(1) || '?')), TR({-align=>'LEFT'}, th('Birthdate'),td($person->Born(1)|| '?')) ), } if (my @directed = $person->Directed) { print h3('Movies Directed'); my @full_names = map { ObjectLink($_,$_->Title) } @directed; print ol(li \@full_names); } if (my @scripted = $person->Scripted) { print h3('Movies Scripted'); my @full_names = map { ObjectLink($_,$_->Title) } @scripted; print ol(li \@full_names); } if (my @stars_in = $person->Stars_in) { print h3('Starring Roles In'); my @full_names = map { ObjectLink($_,$_->Title) } @stars_in; print ol(li \@full_names); } if (my @books = $person->Wrote) { print h3('Wrote'); my @full_names = map { ObjectLink($_,$_->Title) } @books; print ol(li \@full_names); } } AcePerl-1.92/acebrowser/cgi-bin/searches/0000755000175000017500000000000011106333223017571 5ustar lsteinlsteinAcePerl-1.92/acebrowser/cgi-bin/searches/text0000755000175000017500000000374007353756521020532 0ustar lsteinlstein#!/usr/bin/perl use strict; use vars qw/$DB $URL/; use Ace 1.51; use CGI 2.42 qw/:standard :html3 escape/; use CGI::Carp qw/fatalsToBrowser/; use Ace::Browser::AceSubs; use Ace::Browser::SearchSubs; # zero globals in utilities my $pattern = param('query'); my $search_type = param('type'); my $offset = AceSearchOffset(); $URL = url(); $URL=~s!^http://[^/]+!!; # fetch database handle $DB = OpenDatabase() || AceError("Couldn't open database."); my ($objs,$count); ($objs,$count) = do_search($pattern,$offset,$search_type) if $pattern; DoRedirect(@$objs) if $count==1; PrintTop(undef,undef,'AceDB Text Search'); display_search_form(); display_search($objs,$count,$offset,$pattern) if $pattern; PrintBottom(); exit 0; sub display_search_form { print p({-class=>'small'}, "Type in text or keywords to search for.", "The * and ? wildcard characters are allowed."); print start_form, table( TR( td("Search text: "), td(textfield(-name=>'query',-size=>40)), td(submit(-label=>'Search'))), TR( td(), td({-colspan=>2}, radio_group(-name=>'type', -value=>[qw/short long/], -labels=>{'short'=>'Fast search', 'long' =>'In-depth search'} ) ) ) ), end_form; } sub do_search { my ($pattern,$offset,$type) = @_; my $count; my (@objs) = $DB->grep(-pattern=> $pattern, -count => MAXOBJECTS, -offset => $offset, -total => \$count, -long => $type eq 'long', ); return unless @objs; return (\@objs,$count); } sub display_search { my ($objs,$count,$offset,$pattern) = @_; my $title = p(strong($count),"objects contain the keywords \"$pattern\""); if(!$objs) { print "No matches were found.

\n"; return; } my @objects = map { ObjectLink($_,font({-color=>'red'},$_->class) . ": $_") } sort { $a->class cmp $b->class } @$objs; AceResultsTable(\@objects,$count,$offset,$title) if @objects; } AcePerl-1.92/acebrowser/cgi-bin/searches/basic0000755000175000017500000000642207353756545020635 0ustar lsteinlstein#!/usr/bin/perl use strict 'vars'; use vars qw/$DB $URL %EQUIV/; use Ace 1.51; use CGI 2.42 qw/:standard :html3 escape/; use CGI::Carp qw/fatalsToBrowser/; use Ace::Browser::AceSubs qw(:DEFAULT DoRedirect); use Ace::Browser::SearchSubs; my $classlist = Configuration()->Basic_objects; my @classlist = @{$classlist}[map {2*$_} (0..@$classlist/2-1)]; # keep keys, preserving the order my $JSCRIPT=< param('query') . '*') if !$count && param('query') !~ /\*$/; #autoadd } DoRedirect(@$objs) if $count==1; PrintTop(undef,undef,img({-src=>SEARCH_ICON,-align=>CENTER}).'Simple Search'); print p({-class=>'small'}, "Select the type of object you are looking for and optionally", "type in a name or a wildcard pattern", "(? for any one character. * for zero or more characters).", "If no name is entered, the search displays all objects of the selected type.", i('Anything'),'searches for the entered text across the entire database.'); display_search_form(); display_search($objs,$count,$offset,$search_class) if $search_class; PrintBottom(); sub display_search_form { CGI::autoEscape(0); print start_form(-name=>'SimpleForm'), table( TR({-valign=>TOP}, td(radio_group(-name=>'class', -Values=>\@classlist, -Labels=>{@$classlist}, -default=>'Any', -rows=>3)), td({-align=>LEFT,-class=>'large'}, b('Name:'),textfield(-name=>'query'),br, submit(-name=>'Search') ) ), ); CGI::autoEscape(1); print end_form(); } sub do_search { my ($class,$pattern,$offset) = @_; my $count; my (@objs) = $DB->fetch(-class=>$class,-pattern=>$pattern, -count=>MAXOBJECTS,-offset=>$offset, -total=>\$count); return unless @objs; return (\@objs,$count); } sub display_search { my ($objs,$count,$offset,$class) = @_; my $label = $class eq 'Any' ? '' :$class; if ($count > 0) { print p(strong($count),"$label objects found"); } else { print p(font{-color=>'red'},'No matching objects found.', 'Try searching again with a * wildcard before or after the name (already added for you).'); return; } my @objects; if ($class eq 'Any') { @objects = map { a({-href=>Object2URL($_)},$_->class . ": $_") } sort { $a->class cmp $b->class } @$objs; } else { @objects = map { a({-href=>Object2URL($_)},"$_") } @$objs; } AceResultsTable(\@objects,$count,$offset); } sub do_grep { my ($text,$offset) = @_; my $count; my (@objs) = $DB->grep(-pattern=> $text, -count => MAXOBJECTS, -offset => $offset, -total => \$count, ); return unless @objs; return (\@objs,$count); } AcePerl-1.92/acebrowser/cgi-bin/searches/query0000755000175000017500000000345607353756537020726 0ustar lsteinlstein#!/usr/bin/perl use strict; use vars qw/$DB $URL %PAPERS/; use Ace 1.38; use CGI 2.42 qw/:standard :html3 escape/; use CGI::Carp qw/fatalsToBrowser/; use Ace::Browser::AceSubs qw(:DEFAULT DoRedirect); use Ace::Browser::SearchSubs; # zero globals in utilities my $query = param('query'); my $offset = AceSearchOffset(); $URL = url(); $URL=~s!^http://[^/]+!!; # fetch database handle $DB = OpenDatabase() || AceError("Couldn't open database."); my ($objs,$count); ($objs,$count) = do_search($query,$offset) if $query; DoRedirect(@$objs) if $count==1; PrintTop(undef,undef,'AceDB Query'); display_search_form(); display_search($objs,$count,$offset,$query) if $query; PrintBottom(); sub display_search_form { print p({-class=>'small'}, "Type in a search term using the Ace query language. Separate multiple statements with semicolons.", br, "Examples: ", ul( li( [cite({-style=>'font-size: 10pt'},'find Author COUNT Paper > 100'), cite({-style=>'font-size: 10pt'},'find Author IS "Garvin*" ; >Laboratory; >Staff') ]),br, a({-href=>"http://probe.nalusda.gov:8000/aboutacedbquery.html", -style=>'font-size: 10pt'}, 'Documentation and more examples') ), ); print start_form, textfield(-name=>'query',-size=>80),br, submit(-label=>'Query'), end_form; } sub do_search { my ($query,$offset) = @_; my $count; my (@objs) = $DB->find(-query=> $query, -count => MAXOBJECTS, -offset => $offset, -total => \$count); return unless @objs; return (\@objs,$count); } sub display_search { my ($objs,$count,$offset,$query) = @_; print p(strong($count),"objects satisfy the query",strong($query)); my @objects = map { a({-href=>Object2URL($_)},"$_") } @$objs; AceResultsTable(\@objects,$count,$offset) if @objects; } AcePerl-1.92/acebrowser/cgi-bin/searches/browser0000755000175000017500000000367607353756527021247 0ustar lsteinlstein#!/usr/bin/perl use strict; use vars qw($DB); use lib '..'; use Ace 1.76; use CGI::Carp qw/fatalsToBrowser/; use CGI 2.42 qw/:standard :html3 escape/; use Ace::Browser::AceSubs qw(:DEFAULT ResolveUrl DoRedirect); use Ace::Browser::SearchSubs; my $search_class = param('class'); my $search_pattern = param('query'); my $offset = AceSearchOffset(); # fetch database handle $DB = OpenDatabase() || AceError("Couldn't open database."); # here's where the search happens my ($objs,$count); $search_pattern ||= '*'; ($objs,$count) = do_search($search_class,$search_pattern || '*',$offset) if $search_class; DoRedirect(@$objs) if $count==1; PrintTop(undef,undef,'Acedb Class Search'); display_search($objs,$count,$offset,$search_class,$search_pattern) if defined $search_class; display_search_form(); PrintBottom; sub display_search_form { my @classlist = $DB->classes; my $name = Configuration()->Name; AceSearchTable("$name Class Browser", table({-align=>'CENTER'}, TR({-valign=>'MIDDLE'}, td(td({-class=>'large',-rowspan=>2},scrolling_list(-name=>'class', -Values=>\@classlist,-size=>10, ))), td({-align=>'LEFT',-valign=>'TOP'}, table({-border=>0}, TR(td('Search pattern (optional):',textfield(-name=>'query'))), TR(td({-align=>'RIGHT'},submit(-label=>'Search ACE'))))) ) ) ); } sub do_search { my ($class,$pattern,$offset) = @_; my $count; my (@objs) = $DB->fetch(-class=>$class,-pattern=>$pattern, -count=>MAXOBJECTS,-offset=>$offset, -total=>\$count); return unless @objs; return (\@objs,$count); } sub display_search { my ($objs,$count,$offset,$class,$pattern) = @_; my $title; $title = $count > 0 ? p(strong($count),"objects of type",strong($class),"contain pattern",strong($pattern)) :p({-class=>'error'},'No matching objects found'); my @objects = map { ObjectLink($_) } @$objs; AceResultsTable(\@objects,$count,$offset,$title); } AcePerl-1.92/Freesubs/0000755000175000017500000000000011106333223014106 5ustar lsteinlsteinAcePerl-1.92/Freesubs/Freesubs.pm0000644000175000017500000000025707121336700016233 0ustar lsteinlsteinpackage Ace::Freesubs; use strict; use vars qw($VERSION @ISA); require DynaLoader; @ISA = qw(DynaLoader); $VERSION = '1.00'; bootstrap Ace::Freesubs $VERSION; 1; __END__ AcePerl-1.92/Freesubs/Freesubs.xs0000644000175000017500000000526107122265527016262 0ustar lsteinlstein#ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef __cplusplus } #endif #define metachar(c) (c == '"' || c == '\n') MODULE = Ace::Freesubs PACKAGE = Ace SV* freeprotect(CLASS,string) char* CLASS char* string PREINIT: unsigned long count = 2; char *cp,*new,*a; CODE: /* count the number of characters that need to be escaped */ for (cp = string; *cp; cp++ ) { count += metachar(*cp) ? 2 : 1; } /* create a new char* large enough to hold the result */ New(0,new,count+1,char); if (new == NULL) XSRETURN_UNDEF; a = new; *a++ = '"'; cp = string; for (cp = string; *cp; *a++ = *cp++) { if (metachar(*cp)) *a++ = '\\'; if (*cp == '\n') { *a++ = 'n' ; cp++ ; } } *a++ = '"'; *a++ = '\0'; RETVAL = newSVpv("",0); sv_usepvn(RETVAL,new,count); OUTPUT: RETVAL void split(CLASS,string) char* CLASS char* string PREINIT: char *class,*name,*cp,*dest,*timestamp; SV* c,n; int class_size,name_size,timestamp_size,total_size; PPCODE: if (*string != '?') XSRETURN_EMPTY; /* first scan for the class */ total_size = strlen(string) + 1; Newz(0,class,total_size,char); SAVEFREEPV(class); for (cp = string+1,dest=class; *cp; *cp && (*dest++ = *cp++) ) { while (*cp && *cp == '\\') { cp++; /* skip character */ if (!*cp) break; if (*cp == 'n') { *dest++ = '\n'; cp++; } else if (*cp == 't') { *dest++ = '\t'; cp++; } else *dest++ = *cp++; /* copy next character */ } if (*cp == '?') break; } *dest = '\0'; /* paranoia */ if (!*cp) XSRETURN_EMPTY; /* dest should now point at the '?' character, and class holds the class name */ class_size = dest-class; /* now we go after the object name */ Newz(0,name,total_size - (cp-string),char); SAVEFREEPV(name); for (++cp, dest=name; *cp ; *cp && (*dest++ = *cp++) ) { while (*cp && *cp == '\\') { cp++; /* skip character */ if (!*cp) break; if (*cp == 'n') { *dest++ = '\n'; cp++; } else if (*cp == 't') { *dest++ = '\t'; cp++; } else *dest++ = *cp++; /* copy next character */ } if (*cp == '?') break; } *dest = '\0'; name_size = dest - name; if (!*cp) XSRETURN_EMPTY; XPUSHs(sv_2mortal(newSVpv(class,class_size))); XPUSHs(sv_2mortal(newSVpv(name,name_size))); /* dest should now point at the '?' character, and name holds the object id */ if (*++cp) { Newz(0,timestamp,total_size - (cp-string),char); SAVEFREEPV(timestamp); for (dest=timestamp; *cp ; *cp && (*dest++ = *cp++) ) ; *dest = '\0'; timestamp_size = dest - timestamp - 1; XPUSHs(sv_2mortal(newSVpv(timestamp,timestamp_size))); } AcePerl-1.92/Freesubs/Makefile.PL0000644000175000017500000000072407121463011016064 0ustar lsteinlsteinuse ExtUtils::MakeMaker; use Config; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'Ace::Freesubs', 'VERSION_FROM' => 'Freesubs.pm', # finds $VERSION 'LIBS' => ['-lc'], 'DEFINE' => '', 'OBJECT' => '$(O_FILES)', 'XS' => { 'Freesubs.xs' => 'Freesubs.c' }, 'XSPROTOARG' => '-noprototypes', ); AcePerl-1.92/acelib/0000755000175000017500000000000011106333223013547 5ustar lsteinlsteinAcePerl-1.92/acelib/wh/0000755000175000017500000000000011106333223014165 5ustar lsteinlsteinAcePerl-1.92/acelib/wh/regular.h0000644000175000017500000003635107565000306016016 0ustar lsteinlstein/* Last edited: Dec 21 13:45 1998 (fw) */ /* $Id: regular.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */ /*************************************************************** * File regular.h : header file for ACEDB utility functions * Author: Richard Durbin (rd@sanger.ac.uk) * Copyright (C) J Thierry-Mieg and R Durbin, 1994 *------------------------------------------------------------------- * This file is part of the ACEDB genome database package, written by * Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and * Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr * * HISTORY: * Last edited: Aug 20 11:50 1997 (rbrusk) * * Sep 9 16:54 1998 (edgrif): Add messErrorInit decl. * * Sep 9 14:31 1998 (edgrif): Add filGetFilename decl. * * Aug 20 11:50 1998 (rbrusk): AUL_FUNC_DCL * * Sep 3 11:50 1998 (edgrif): Add macro version of messcrash to give * file/line info for debugging. * Created: 1991 (rd) *------------------------------------------------------------------- */ #ifndef DEF_REGULAR_H #define DEF_REGULAR_H /* library EXPORT/IMPORT symbols */ #if defined (WIN32) #include "win32libspec.h" /* must come before mystdlib.h...*/ #else #define UTIL_FUNC_DCL #define UTIL_VAR_DCL extern #define UTIL_FUNC_DEF #define UTIL_VAR_DEF #endif #include "mystdlib.h" /* contains full prototypes of system calls */ #if defined(WIN32) #if defined(_DEBUG) #define MEM_DEBUG /* must be defined here, before acelibspec.h */ #include #endif UTIL_VAR_DCL char* linkDate ; UTIL_VAR_DCL int isInteractive ; /* can set FALSE, i.e. in tace */ #endif #ifdef FALSE typedef int BOOL ; #else typedef enum {FALSE=0,TRUE=1} BOOL ; #endif typedef unsigned char UCHAR ; /* for convenience */ typedef unsigned int KEY ; typedef void (*VoidRoutine)(void) ; typedef void (*Arg1Routine)(void *arg1) ; /* magic_t : the type that all magic symbols are declared of. They become magic (i.e. unique) by using the pointer to that unique symbol, which has been placed somewhere in the address space by the compiler */ /* type-magics and associator codes are defined at magic_t MYTYPE_MAGIC = "MYTYPE"; The address of the string is then used as the unique identifier (as type->magic or graphAssXxx-code), and the string can be used during debugging */ typedef char* magic_t; typedef struct freestruct { KEY key ; char *text ; } FREEOPT ; /*---------------------------------------------------------------------*/ /* The free package for reading from files/stdout, see freesubs.c */ /* */ UTIL_FUNC_DCL void freeinit (void) ; UTIL_FUNC_DCL int freeCurrLevel(void) ; /* Returns current level. */ UTIL_FUNC_DCL char* freecard (int level) ; /* 0 if below level (returned by freeset*) */ UTIL_FUNC_DCL void freecardback (void) ; /* goes back one card */ UTIL_FUNC_DCL void freeforcecard (char *string); UTIL_FUNC_DCL int freesettext (char *string, char *parms) ; /* returns level to be used in freecard () */ UTIL_FUNC_DCL int freesetfile (FILE *fil, char *parms) ; UTIL_FUNC_DCL int freesetpipe (FILE *fil, char *parms) ; /* will call pclose */ UTIL_FUNC_DCL void freeclose(int level) ; /* closes the above */ UTIL_FUNC_DCL void freespecial (char *set) ; /* set of chars to be recognized from "\n;/%\\@$" */ UTIL_FUNC_DCL BOOL freeread (FILE *fil) ; /* returns FALSE if EOF */ UTIL_FUNC_DCL int freeline (FILE *fil) ; /* line number in file */ UTIL_FUNC_DCL int freestreamline (int level) ;/* line number in stream(level)*/ UTIL_FUNC_DCL char *freeword (void) ; #if defined(WIN32) /* A variation to correctly parse MS DOS/Windows pathnames */ UTIL_FUNC_DCL char *freepath (void) ; #else /* NOT defined(WIN32) */ #define freepath freeword /* freeword() works fine if not in WIN32 */ #endif /* defined(WIN32) */ UTIL_FUNC_DCL char *freewordcut (char *cutset, char *cutter) ; UTIL_FUNC_DCL void freeback (void) ; /* goes back one word */ UTIL_FUNC_DCL BOOL freeint (int *p) ; UTIL_FUNC_DCL BOOL freefloat (float *p) ; UTIL_FUNC_DCL BOOL freedouble (double *p) ; UTIL_FUNC_DCL BOOL freekey (KEY *kpt, FREEOPT *options) ; UTIL_FUNC_DCL BOOL freekeymatch (char *text, KEY *kpt, FREEOPT *options) ; UTIL_FUNC_DCL void freemenu (void (*proc)(KEY), FREEOPT *options) ; UTIL_FUNC_DCL char *freekey2text (KEY k, FREEOPT *o) ; /* Return text corresponding to key */ UTIL_FUNC_DCL BOOL freeselect (KEY *kpt, FREEOPT *options) ; UTIL_FUNC_DCL BOOL freelevelselect (int level, KEY *kpt, FREEOPT *options); UTIL_FUNC_DCL void freedump (FREEOPT *options) ; UTIL_FUNC_DCL BOOL freestep (char x) ; UTIL_FUNC_DCL void freenext (void) ; UTIL_FUNC_DCL BOOL freeprompt (char *prompt, char *dfault, char *fmt) ;/* gets a card */ UTIL_FUNC_DCL BOOL freecheck (char *fmt) ; /* checks remaining card fits fmt */ UTIL_FUNC_DCL int freefmtlength (char *fmt) ; UTIL_FUNC_DCL BOOL freequery (char *query) ; UTIL_FUNC_DCL char *freepos (void) ; /* pointer to present position in card */ UTIL_FUNC_DCL char *freeprotect (char* text) ; /* protect so freeword() reads correctly */ UTIL_FUNC_DCL char* freeunprotect (char *text) ; /* reverse of protect, removes \ etc */ UTIL_VAR_DCL char FREE_UPPER[] ; #define freeupper(x) (FREE_UPPER[(x) & 0xff]) /* table is only 128 long */ UTIL_VAR_DCL char FREE_LOWER[] ; #define freelower(x) (FREE_LOWER[(x) & 0xff]) /**********************************************************************/ /******************** message routines - messubs.c ********************/ /**********************************************************************/ /* 'Internal' functions, do not call directly. */ UTIL_FUNC_DCL void uMessSetErrorOrigin(char *filename, int line_num) ; UTIL_FUNC_DCL void uMessCrash(char *format, ...) ; /* External Interface. */ /* Note that messcrash is a macro and that it makes use of the ',' operator */ /* in C. This means that the messcrash macro will only produce a single C */ /* statement and hence can be used within brackets etc. and will not break */ /* existing code, e.g. */ /* funcblah(messcrash("hello")) ; */ /* will become: */ /* funcblah(uMessSetErrorOrigin(__FILE__, __LINE__), uMessCrash("hello")) ; */ /* */ UTIL_FUNC_DEF void messErrorInit (char *progname) ; /* Record the applications name for use in error messages, etc */ UTIL_FUNC_DEF char *messGetErrorProgram (void) ; /* Returns the application name */ UTIL_FUNC_DCL char *messprintf (char *format, ...) ; /* sprintf into (static!) string */ /* !!!! beware finite buffer size !!!! */ UTIL_FUNC_DCL void messbeep (void) ; /* make a beep */ UTIL_FUNC_DCL void messout (char *format, ...) ; /* simple message */ UTIL_FUNC_DCL void messdump (char *format, ...) ; /* write to log file */ UTIL_FUNC_DCL void messerror (char *format, ...) ; /* error message and write to log file */ UTIL_FUNC_DCL void messExit(char *format, ...) ; /* error message, write to log file & exit */ #define messcrash uMessSetErrorOrigin(__FILE__, __LINE__), uMessCrash /* abort - but see below */ UTIL_FUNC_DCL BOOL messQuery (char *text,...) ; /* ask yes/no question */ UTIL_FUNC_DCL BOOL messPrompt (char *prompt, char *dfault, char *fmt) ; /* ask for data satisfying format get results via freecard() */ UTIL_FUNC_DCL char* messSysErrorText (void) ; /* wrapped system error message for use in messerror/crash() */ UTIL_FUNC_DCL int messErrorCount (void); /* return numbers of error so far */ UTIL_FUNC_DCL BOOL messIsInterruptCalled (void); /* return TRUE if an interrupt key has been pressed */ /**** registration of callbacks for messubs ****/ typedef void (*OutRoutine)(char*) ; typedef BOOL (*QueryRoutine)(char*) ; typedef BOOL (*PromptRoutine)(char*, char*, char*) ; typedef BOOL (*IsInterruptRoutine)(void) ; UTIL_FUNC_DCL VoidRoutine messBeepRegister (VoidRoutine func) ; UTIL_FUNC_DCL OutRoutine messOutRegister (OutRoutine func) ; UTIL_FUNC_DCL OutRoutine messDumpRegister (OutRoutine func) ; UTIL_FUNC_DCL OutRoutine messErrorRegister (OutRoutine func) ; UTIL_FUNC_DCL OutRoutine messExitRegister (OutRoutine func) ; UTIL_FUNC_DCL OutRoutine messCrashRegister (OutRoutine func) ; UTIL_FUNC_DCL QueryRoutine messQueryRegister (QueryRoutine func) ; UTIL_FUNC_DCL PromptRoutine messPromptRegister (PromptRoutine func) ; UTIL_FUNC_DCL IsInterruptRoutine messIsInterruptRegister (IsInterruptRoutine func) ; /**** routines to catch crashes if necessary, e.g. when acedb dumping ****/ #include UTIL_FUNC_DCL jmp_buf* messCatchCrash (jmp_buf* ) ; UTIL_FUNC_DCL jmp_buf* messCatchError (jmp_buf* ) ; UTIL_FUNC_DCL char* messCaughtMessage (void) ; /* if a setjmp() stack context is set using messCatch*() then rather than exiting or giving an error message, messCrash() and messError() will longjmp() back to the context. messCatch*() return the previous value. Use argument = 0 to reset. messCaughtMessage() can be called from the jumped-to routine to get the error message that would have been printed. */ /********************************************************************/ /************** memory management - memsubs.c ***********************/ /********************************************************************/ typedef struct _STORE_HANDLE_STRUCT *STORE_HANDLE ; /* opaque outside memsubs.c */ UTIL_FUNC_DCL STORE_HANDLE handleHandleCreate (STORE_HANDLE handle) ; #define handleCreate() handleHandleCreate(0) #define handleDestroy(handle) messfree(handle) #if defined(WIN32) && defined(_DEBUG) #define MEM_DEBUG #include #endif #if !defined(MEM_DEBUG) UTIL_FUNC_DCL void *handleAlloc (void (*final)(void *), STORE_HANDLE handle, int size) ; /* handleAlloc is deprecated, use halloc, and blockSetFinalize instead */ UTIL_FUNC_DCL void *halloc(int size, STORE_HANDLE handle) ; UTIL_FUNC_DCL char *strnew(char *old, STORE_HANDLE handle) ; #else /* MEM_DEBUG from rbrusk */ void *halloc_dbg(int size, STORE_HANDLE handle, const char *hfname, int hlineno) ; UTIL_FUNC_DCL void *handleAlloc_dbg(void (*final)(void *), STORE_HANDLE handle, int size, const char *hfname, int hlineno) ; UTIL_FUNC_DCL char *strnew_dbg(char *old, STORE_HANDLE handle, const char *hfname, int hlineno) ; #define halloc(s, h) halloc_dbg(s, h, __FILE__, __LINE__) #define handleAlloc(f, h, s) handleAlloc_dbg(f, h, s, __FILE__, __LINE__) #define strnew(o, h) strnew_dbg(o, h, __FILE__, __LINE__) #define messalloc_dbg(size,fname,lineno) halloc_dbg(size, 0, fname, lineno) #endif UTIL_FUNC_DCL void blockSetFinalise(void *block, void (*final)(void *)) ; UTIL_FUNC_DCL void handleSetFinalise(STORE_HANDLE handle, void (*final)(void *), void *arg) ; UTIL_FUNC_DCL void handleInfo (STORE_HANDLE handle, int *number, int *size) ; #define messalloc(size) halloc(size, 0) UTIL_FUNC_DCL void umessfree (void *cp) ; #define messfree(cp) ((cp) ? umessfree((void*)(cp)),(cp)=0,TRUE : FALSE) UTIL_FUNC_DCL void messalloccheck (void) ; /* can be used anywhere - does nothing unless MALLOC_CHECK set in messubs.c */ UTIL_FUNC_DCL int messAllocStatus (int *np) ; /* returns number of outstanding allocs *np is total mem if MALLOC_CHECK */ UTIL_FUNC_DCL int regExpMatch (char *cp,char *tp) ; /* in messubs.c CLH 5/23/95 */ /********************************************************************/ /******** growable arrays and flexible stacks - arraysub.c **********/ /********************************************************************/ /* to be included after the declarations of STORE_HANDLE etc. */ #include "array.h" /********************************************************************/ /************** file opening/closing from filsubs.c *****************/ /********************************************************************/ UTIL_FUNC_DCL void filAddPath (char *path) ; /* Adds a set of pathnames to the pathname stack */ UTIL_FUNC_DCL void filAddDir (char *dir) ; /* Adds a single pathname to the pathname stack */ /* returns an absolute path string for dir in relation to user's CWD */ /* returns pointer to internal static */ UTIL_FUNC_DCL char *filGetFullPath (char *dir); /* returns filename part of a pathname. */ /* returns pointer to internal static */ UTIL_FUNC_DCL char *filGetFilename(char *path); /* returns the file-extension part of a path or file-name */ /* returns pointer to internal static */ UTIL_FUNC_DCL char *filGetExtension(char *path); UTIL_FUNC_DCL char *filName (char *name, char *ending, char *spec) ; UTIL_FUNC_DCL char *filStrictName (char *name, char *ending, char *spec) ; /* determines time since last modification, FALSE if no file */ UTIL_FUNC_DCL BOOL filAge (char *name, char *ending, int *diffYears, int *diffMonths, int *diffDays, int *diffHours, int *diffMins, int *diffSecs); UTIL_FUNC_DCL FILE *filopen (char *name, char *ending, char *spec) ; UTIL_FUNC_DCL FILE *filmail (char *address) ; UTIL_FUNC_DCL void filclose (FILE* fil) ; UTIL_FUNC_DCL BOOL filremove (char *name, char *ending) ; UTIL_FUNC_DCL FILE *filtmpopen (char **nameptr, char *spec) ; UTIL_FUNC_DCL BOOL filtmpremove (char *name) ; UTIL_FUNC_DCL void filtmpcleanup (void) ; /* file chooser */ typedef FILE* (*QueryOpenRoutine)(char*, char*, char*, char*, char*) ; UTIL_FUNC_DCL QueryOpenRoutine filQueryOpenRegister (QueryOpenRoutine new); /* allow graphic file choosers to be registered */ UTIL_FUNC_DCL FILE *filqueryopen (char *dirname, char *filname, char *ending, char *spec, char *title); /* if dirname is given it should be DIR_BUFFER_SIZE long and filname FILE_BUFFER_SIZE long if not given, then default (static) buffers will be used */ /* directory access */ UTIL_FUNC_DCL Array filDirectoryCreate (char *dirName, char *ending, char *spec); UTIL_FUNC_DCL void filDirectoryDestroy (Array filDirArray); /*******************************************************************/ /************* randsubs.c random number generator ******************/ UTIL_FUNC_DCL double randfloat (void) ; UTIL_FUNC_DCL double randgauss (void) ; UTIL_FUNC_DCL int randint (void) ; UTIL_FUNC_DCL void randsave (int *arr) ; UTIL_FUNC_DCL void randrestore (int *arr) ; /* Unix debugging. */ /* put "break invokeDebugger" in your favourite debugger init file */ /* this function is empty, it is defined in messubs.c used in messerror, messcrash and when ever you need it. */ UTIL_FUNC_DCL void invokeDebugger(void) ; /*******************************************************************/ /************* some WIN32 debugging utilities **********************/ #if defined (WIN32) #if defined(_DEBUG) /* See win32util.cpp for these functions */ UTIL_FUNC_DCL const char *dbgPos( const char *caller, int lineno, const char *called ) ; UTIL_FUNC_DCL void WinTrace(char *prompt, unsigned long code) ; UTIL_FUNC_DCL void AceASSERT(int condition) ; UTIL_FUNC_DCL void NoMemoryTracking() ; #else /* !defined(_DEBUG) */ #define dbgPos(c,l,fil) (const char *)(fil) #endif /* !defined(_DEBUG) */ #endif /* defined(WIN32) */ #endif /* defined(DEF_REGULAR_H) */ /******************************* End of File **********************************/ AcePerl-1.92/acelib/wh/mydirent.h0000644000175000017500000000346207565000306016205 0ustar lsteinlstein/* Last edited: Nov 9 23:01 1997 (rd) */ /* mydirent.h - file/directory entity datatypes and symbols * - filDirectory() declared here instead of regular.h since it * returns Arrays; besides, mydirent.h is directory related anyway * * Jun 5 17:35 1996 (rbrusk): not much by end of day * - Cleaning up WIN32 file system port in filsubs.c et al. * * Jun 4 22:07 1996 (rd) */ /* $Id: mydirent.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */ /* * Filesystem-independent directory information. */ #ifndef DEFINE_MYDIRENT_H #define DEFINE_MYDIRENT_H #if defined(NEXT) #include typedef struct direct MYDIRENT ; /* Crazy next */ #endif #if defined(ALLIANT)|| defined(IBM) #include typedef struct dirent MYDIRENT ; #endif #if defined(CONVEX) #include #include #define S_IFMT _S_IFMT #define S_IFDIR _S_IFDIR #define S_IFBLK _S_IFBLK #define S_IFCHR _S_IFCHR #define S_IFREG _S_IFREG #define S_IFLNK _S_IFLNK #define S_IFSOCK _S_IFSOCK #define S_IFIFO _S_IFIFO #define S_ISVTX _S_ISVTX #define S_IREAD _S_IREAD #define S_IWRITE _S_IWRITE #define S_IEXEC _S_IEXEC typedef struct dirent MYDIRENT ; #endif #if !(defined(MACINTOSH) || defined(WIN32)) #include #endif #if defined (HP) || defined (SOLARIS) || defined (WIN32) #if !defined (WIN32) #include #endif #define getwd(buf) getcwd(buf,MAXPATHLEN - 2) #else /* HP || SOLARIS || WIN32 */ extern char *getwd(char *pathname) ; #endif /* HP || SOLARIS || WIN32 */ #if defined (POSIX) || defined(SUN) || defined(SUNSVR4) || defined(SOLARIS) || defined(DEC) || defined(ALPHA) || defined(SGI) || defined(LINUX) || defined(HP) || defined (INTEL_SOLARIS) #include typedef struct dirent MYDIRENT ; #endif #endif /* #ifndef DEFINE_MYDIRENT_H */ AcePerl-1.92/acelib/wh/liste.h0000644000175000017500000000314207565000306015465 0ustar lsteinlstein/* File: liste.h * Author: Richard Durbin (rd@sanger.ac.uk) * Copyright (C) J Thierry-Mieg and R Durbin, 1995 *------------------------------------------------------------------- * This file is part of the ACEDB genome database package, written by * Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and * Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr * * Description: You can add and remove from a liste in a loop without making the list grow larger then the max current nimber this is more economic than hashing, where removing is inneficient and faster than an ordered set This library will not check for doubles, i.e. it maintains a list, not a set. * Exported functions: * HISTORY: * Last edited: Dec 4 14:45 1998 (fw) * Created: oct 97 (mieg) *------------------------------------------------------------------- */ /* $Id: liste.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */ #ifndef LISTE_H #define LISTE_H #include "regular.h" /* The LISTE structure is private DO NOT LOOK AT OR TOUCH IT IN CLIENT CODE!! Only use it via the subroutine interface. */ typedef struct listeStruct { void *magic ; int i ; /* probably lowest empty slot */ Array a ; /* the actual liste */ } * Liste ; Liste listeCreate (STORE_HANDLE hh) ; #define listeDestroy(_ll) ((_ll) ? messfree(_ll) , _ll = 0, TRUE : FALSE) #define listeMax(_ll) (arrayMax((_ll)->a) - 1) int listeFind (Liste liste, void *vp) ; int listeAdd (Liste liste, void *vp) ; void listeRemove (Liste liste, void *vp, int i) ; #endif /* ndef LISTE_H */ /******* end of file ********/ AcePerl-1.92/acelib/wh/menu_.h0000644000175000017500000000216607565000306015455 0ustar lsteinlstein/* File: menu_.h * Author: Richard Durbin (rd@sanger.ac.uk) * Copyright (C) J Thierry-Mieg and R Durbin, 1995 *------------------------------------------------------------------- * This file is part of the ACEDB genome database package, written by * Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and * Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr * * Description: private header for menu package with full structures * Exported functions: * HISTORY: * Last edited: Jan 14 15:01 1995 (rd) * Created: Mon Jan 9 22:54:36 1995 (rd) *------------------------------------------------------------------- */ /* $Id: menu_.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */ #ifndef DEF_MENU_H typedef struct MenuStruct *MENU ; typedef struct MenuItemStruct *MENUITEM ; typedef void (*MENUFUNCTION)(MENUITEM) ; #define MENU_DEFINED struct MenuItemStruct { char* label ; MENUFUNCTION func ; unsigned int flags ; char* call ; int value ; void* ptr ; MENU submenu ; MENUITEM up, down ; } ; struct MenuStruct { char *title ; MENUITEM items ; } ; #include "menu.h" #endif /* DEF_MENU_H */ AcePerl-1.92/acelib/wh/aceversion.h0000644000175000017500000000407607121260302016502 0ustar lsteinlstein/* File: version.h * Author: Ed Griffiths (edgrif@mrc-lmba.cam.ac.uk) * Copyright (C) J Thierry-Mieg and R Durbin, 1998 *------------------------------------------------------------------- * 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@crbm1.cnusc.fr * * Description: Declares functions in the new acedb_version module. * These functions allow the retrieval of various parts * of the current acedb version number or string. * Exported functions: See descriptions below. * HISTORY: * Last edited: Dec 3 14:58 1998 (edgrif) * * Dec 3 14:39 1998 (edgrif): Changed the interface to fit in with * libace. * Created: Wed Apr 29 13:46:41 1998 (edgrif) *------------------------------------------------------------------- */ #ifndef ACE_VERSION_H #define ACE_VERSION_H /* Use this set of functions to return the individual parts of the ACEDB release numbers, */ /* including version number, release number, update letter and build date/time. */ int aceGetVersion(void) ; int aceGetRelease(void) ; char *aceGetUpdate(void) ; char *aceGetLinkDate(void) ; /* Use this set of functions to return standard format string versions of the ACEDB */ /* release version and build date. */ /* Version string is in the form: */ /* "ACEDB Version _" e.g. "ACEDB Version 4_6d" */ /* */ /* LinkDate string is in the form: */ /* "compiled on: __DATE__ __TIME__" e.g. "compiled on: Dec 3 1998 13:59:07" */ /* */ char *aceGetVersionString(void) ; char *aceGetLinkDateString(void) ; #endif /* end of ACE_VERSION_H */ AcePerl-1.92/acelib/wh/call.h0000644000175000017500000000310207565000306015254 0ustar lsteinlstein/* File: call.h * Author: Richard Durbin (rd@sanger.ac.uk) * Copyright (C) J Thierry-Mieg and R Durbin, 1994 *------------------------------------------------------------------- * This file is part of the ACEDB genome database package, written by * Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and * Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr * * Description: Header file for message system to allow calls by name * Exported functions: * HISTORY: * Last edited: Oct 19 11:06 1998 (fw) * * Nov 3 16:15 1994 (mieg): callCdScript, first cd to establish the pwd of the command, needed for ghostview etc. * Created: Mon Oct 3 14:57:16 1994 (rd) *------------------------------------------------------------------- */ /* $Id: call.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */ #ifndef DEF_CALL_H #define DEF_CALL_H #include "regular.h" typedef int MESSAGERETURN ; typedef void (*CallFunc)() ; void callRegister (char *name, CallFunc func) ; BOOL call (char *name, ...) ; BOOL callExists (char *name) ; int callScript (char *script, char *args) ; int callCdScript (char *dir, char *script, char *args) ; FILE* callScriptPipe (char *script, char *args) ; FILE* callCdScriptPipe (char *dir, char *script, char *args) ; BOOL externalAsynchroneCommand (char *command, char *parms, void *look, void(*g)(FILE *f, void *lk)) ; void externalFileDisplay (char *title, FILE *f, Stack s) ; void externalPipeDisplay (char *title, FILE *f, Stack s) ; void acedbMailComments(void) ; void externalCommand (char* command) ; #endif AcePerl-1.92/acelib/wh/bump.h0000644000175000017500000000355607565000306015321 0ustar lsteinlstein/* File: bump.h * Author: Jean Thierry-Mieg (mieg@mrc-lmb.cam.ac.uk) * Copyright (C) J Thierry-Mieg and R Durbin, 1992 *------------------------------------------------------------------- * This file is part of the ACEDB genome database package, written by * Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and * Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr * * Description: * Exported functions: * HISTORY: * Last edited: Dec 17 16:05 1998 (fw) * Created: Thu Aug 20 10:42:03 1992 (mieg) *------------------------------------------------------------------- */ /* $Id: bump.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */ #ifndef DEF_BUMP_H #define DEF_BUMP_H /* forward declaration of opaque type */ typedef struct BumpStruct *BUMP; BUMP bumpCreate (int ncol, int minSpace) ; BUMP bumpReCreate (BUMP bump, int ncol, int minSpace) ; void bumpDestroy (BUMP bump) ; float bumpSetSloppy( BUMP bump, float sloppy) ; /* Bumper works by resetting x,y bumpItem inserts and fills the bumper bumpTest restes x,y, but does not fill bumper this allows to reconsider the wisdom of bumping bumpRegister (called after bumpTest) fills Test+Register == Add bumpText returns number of letters that can be bumped without *py moving more than 3*dy */ #define bumpItem(_b,_w,_h,_px,_py) bumpAdd(_b,_w,_h,_px,_py,TRUE) #define bumpTest(_b,_w,_h,_px,_py) bumpAdd(_b,_w,_h,_px,_py,FALSE) BOOL bumpAdd (BUMP bump, int wid, float height, int *px, float *py, BOOL doIt); void bumpRegister (BUMP bump, int wid, float height, int *px, float *py) ; int bumpText (BUMP bump, char *text, int *px, float *py, float dy, BOOL vertical) ; int bumpMax(BUMP bump) ; void asciiBumpItem (BUMP bump, int wid, float height, int *px, float *py) ; /* works by resetting x, y */ #endif /* DEF_BUMP_H */ AcePerl-1.92/acelib/wh/dict.h0000644000175000017500000000276207121260303015270 0ustar lsteinlstein/* File: dict.h * Author: Richard Durbin (rd@sanger.ac.uk) * Copyright (C) J Thierry-Mieg and R Durbin, 1995 *------------------------------------------------------------------- * This file is part of the ACEDB genome database package, written by * Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and * Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr * * Description: public header for cut-out lex package in dict.c * Exported functions: * HISTORY: * Last edited: Dec 4 14:50 1998 (fw) * Created: Tue Jan 17 17:34:44 1995 (rd) *------------------------------------------------------------------- */ /* @(#)dict.h 1.4 9/16/97 */ #ifndef DICT_H #define DICT_H #include "regular.h" /* The DICT structure is private to lexhash.c DO NOT LOOK AT OR TOUCH IT IN CLIENT CODE!! Only use it via the subroutine interface. */ typedef struct { int dim ; int max ; Array table ; /* hash table */ Array names ; /* mark in text Stack per name */ Stack nameText ; /* holds names themselves */ } DICT ; DICT *dictCreate (int size) ; DICT *dictHandleCreate (int size, STORE_HANDLE handle) ; void uDictDestroy (DICT *dict) ; #define dictDestroy(_dict) {uDictDestroy(_dict) ; _dict=0;} BOOL dictFind (DICT *dict, char *s, int *ip) ; BOOL dictAdd (DICT *dict, char *s, int *ip) ; char *dictName (DICT *dict, int i) ; int dictMax (DICT *dict) ; /* 1 + highest index = number of names */ DICT *dictCopy (DICT *dict) ; #endif /* ndef DICT_H */ /******* end of file ********/ AcePerl-1.92/acelib/wh/freeout.h0000644000175000017500000000077107121260303016014 0ustar lsteinlstein/* Last edited: Dec 4 14:50 1998 (fw) */ /* @(#)freeout.h 1.2 12/13/95 */ #ifndef FREEOUT_H_DEF #define FREEOUT_H_DEF #include "regular.h" int freeOutSetFile (FILE *fil) ; int freeOutSetStack (Stack s) ; void freeOutInit (void) ; void freeOut (char *text) ; void freeOutf (char *format,...) ; void freeOutxy (char *text, int x, int y) ; void freeOutBinary (char *data, int size) ; void freeOutClose (int level) ; int freeOutLine (void) ; int freeOutByte (void) ; int freeOutPos (void) ; #endif AcePerl-1.92/acelib/wh/heap.h0000644000175000017500000000160107565000306015260 0ustar lsteinlstein/* File: heap.h * Author: Richard Durbin (rd@mrc-lmb.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-lmb.cam.ac.uk, and * Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr * * Description: header file for heap package * Exported functions: * HISTORY: * Last edited: Feb 6 00:20 1993 (mieg) * Created: Sat Oct 12 21:30:43 1991 (rd) *------------------------------------------------------------------- */ /* $Id: heap.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */ #ifndef HEAP_INTERNAL typedef void* Heap ; #endif Heap heapCreate (int size) ; void heapDestroy (Heap heap) ; int heapInsert (Heap heap, float score) ; int heapExtract (Heap heap, float *sp) ; /* end of file */ AcePerl-1.92/acelib/wh/help.h0000644000175000017500000000574607121260303015302 0ustar lsteinlstein/* File: help.h * Author: Fred Wobus (fw@sanger.ac.uk) * Copyright (C) J Thierry-Mieg and R Durbin, 1998 *------------------------------------------------------------------- * This file is part of the ACEDB genome database package, written by * Richard Durbin (MRC LMB, UK) rd@sanger.ac.uk, and * Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr * * SCCS: %W% %G% * Description: part of the utility-library that handles the on-line help package. The system works on the basis that all help files are HTML documents contained in one directory. Depending on what display function is registered, they can be shown as text, using the built-in simple browser or even dispatched to an external browser. * Exported functions: see below * HISTORY: * Last edited: Oct 23 12:19 1998 (fw) * Created: Thu Oct 8 14:01:07 1998 (fw) *------------------------------------------------------------------- */ #ifndef _HELP_H #define _HELP_H #include "regular.h" /* basic header for util-lib */ /************** public routines of the help-package *******************/ UTIL_FUNC_DCL BOOL helpOn (char *subject); /* displays help on the given subject. Dispatches to registered display function. defaults to helpPrint (text-help) */ UTIL_FUNC_DCL QueryRoutine helpOnRegister (QueryRoutine func); /* register any func to display help-page, the functions are >> BOOL func (char *filename) <<, where the filename is a *full* pathname to an HTML document that is to be shown */ UTIL_FUNC_DCL char *helpSetDir (char *dirname); /* set the /whelp/ dir if possible, returns path to it */ UTIL_FUNC_DCL char *helpGetDir (void); /* find the /whelp/ dir if possible, returns pointer to path If called for the first time without prior helpSetDir(), it will try to init to whelp/, but return 0 if it is not accessible*/ UTIL_FUNC_DCL BOOL helpPrint (char *helpFilename); /* dump helpfile as text - default for helpOn, if helpOnRegister wasn't called to change it. */ UTIL_FUNC_DCL BOOL helpWebBrowser(char *link); /* counter-part to graphWebBrowser(), which remote-controls netscape using the -remote command line option. Useful for textual applications running in an X11 environment, where x-apps can be called from within the applcation, but the Xtoolkit (used to drive netscape via X-atoms) shoiuldn't be linked in, because it is a textual app. */ UTIL_FUNC_DCL char *helpSubjectGetFilename (char *subject); /* Returns the complete file name of the html help file for a given subject. Returns ? if subject was ? to signal, that a dynamically created index or some kind of help should be displayed. Returns NULL of no helpfile is available. */ UTIL_FUNC_DCL char *helpLinkGetFilename (char *link_href); /* given a relative link in a page it returns the full pathname to the file that is being linked to. The pointer returned belongs to an internal static copy that is reused every tjis function is called */ #endif /* !def _HELP_H */ AcePerl-1.92/acelib/wh/menu.h0000644000175000017500000000501007565000306015305 0ustar lsteinlstein/* Last edited: Aug 19 09:44 1998 (rd) */ /* $Id: menu.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */ #ifndef DEF_MENU_H #define DEF_MENU_H #include "regular.h" /************* types *****************/ #ifndef MENU_DEFINED #define MENU_DEFINED typedef void *MENU, *MENUITEM ; /* public handles */ typedef void (*MENUFUNCTION)(MENUITEM) ; #endif typedef struct menuspec { MENUFUNCTION f ; /* NB can be 0 if using menuSetCall() below */ char *text ; } MENUSPEC ; /********** MENUITEM flags ***********/ #define MENUFLAG_DISABLED 0x01 #define MENUFLAG_TOGGLE 0x02 #define MENUFLAG_TOGGLE_STATE 0x04 #define MENUFLAG_START_RADIO 0x08 #define MENUFLAG_END_RADIO 0x10 #define MENUFLAG_RADIO_STATE 0x20 #define MENUFLAG_SPACER 0x40 #define MENUFLAG_HIDE 0x80 /************* functions *************/ MENU menuCreate (char *title) ; /* makes a blank menu */ MENU menuInitialise (char *title, MENUSPEC *spec) ; /* makes a simple menu from a spec terminated with label = 0 */ /* if called on same spec, give existing menu */ MENU menuCopy (MENU menu) ; /* a copy that you can then vary */ void menuDestroy (MENU menu) ; /* also destroys items */ MENUITEM menuCreateItem (char *label, MENUFUNCTION func) ; MENUITEM menuItem (MENU menu, char *label) ; /* find item from label */ BOOL menuAddItem (MENU menu, MENUITEM item, char *beforeLabel) ; /* add an item; if before == 0 then add at end */ BOOL menuDeleteItem (MENU menu, char *label) ; /* also destroys item */ BOOL menuSelectItem (MENUITEM item) ; /* triggers a call back and adjusts toggle/radio states */ /* returns true if states changed - mostly for graph library to use */ /* calls to set properties of items */ /* can use by name e.g. menuSetValue (menuItem (menu, "Frame 3"), 3) */ BOOL menuSetCall (MENUITEM item, char *callName) ; BOOL menuSetFunc (MENUITEM item, MENUFUNCTION func) ; BOOL menuSetFlags (MENUITEM item, unsigned int flags) ; BOOL menuUnsetFlags (MENUITEM item, unsigned int flags) ; BOOL menuSetValue (MENUITEM item, int value) ; BOOL menuSetPtr (MENUITEM item, void *ptr) ; BOOL menuSetMenu (MENUITEM item, MENU menu) ; /* pulldown for boxes */ /* and to get properties */ unsigned int menuGetFlags (MENUITEM item) ; int menuGetValue (MENUITEM item) ; void* menuGetPtr (MENUITEM item) ; /* extra routines */ void menuSuppress (MENU menu, char *string) ; /* HIDE block */ void menuRestore (MENU menu, char *string) ; /* reverse of Suppress */ void menuSpacer (void) ; /* dummy routine for spaces in opt menus */ #endif /* DEF_MENU_H */ AcePerl-1.92/acelib/wh/acedb.h0000644000175000017500000000540307565000306015405 0ustar lsteinlstein/* File: acedb.h * Author: Jean Thierry-Mieg (mieg@mrc-lmb.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-lmb.cam.ac.uk, and * Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr * * Description: general include for any acedb code * can only declare general stuff, * i.e. not graph-specific things * HISTORY: * Last edited: Dec 17 15:59 1998 (fw) * * Nov 18 17:00 1998 (fw): added decl for mainActivityRegister stuff * * Nov 18 16:59 1998 (fw): moved pickDraw, getPickArgs to main.h * as they are for graphical versions * * Oct 22 11:43 1998 (edgrif): Add dec. of pickDraw. * * Sep 17 09:43 1998 (edgrif): Add declaration of pickGetArgs function. * * Oct 21 14:01 1991 (mieg): added overflow protection in KEYMAKE * Created: Mon Oct 21 14:01:19 1991 (mieg) *------------------------------------------------------------------- */ /* $Id: acedb.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */ /*********************************************/ /* ACeDB.h */ /* type definitions and size limits */ /*********************************************/ #ifndef DEF_ACeDB_h #define DEF_ACeDB_h #include "regular.h" #include "mytime.h" /* not yet included in regular.h */ #include "keyset.h" /* contains KEYSET */ #include "aceversion.h" /* library EXPORT/IMPORT symbols */ #if defined (WIN32) #include "win32libspec.h" #else #define ACEDB_FUNC_DCL #define ACEDB_VAR_DCL extern #define ACEDB_FUNC_DEF #define ACEDB_VAR_DEF #endif /************************************************************/ /* mainActivity () - function called by graphical and non-graphical code but only in programs that call acedbGraphInit() the text will be dispatched to mainActivityDisplayInWindow(char*) */ void mainActivity(char * text); OutRoutine mainActivityRegister (OutRoutine func); /************************************************************/ #define KEYMAKE(t,i) ((KEY)( (((KEY) (t))<<24) | ( ((KEY) (i)) & 0xffffffL) )) #define KEYKEY(kk) ((KEY)( ((KEY) (kk)) & ((KEY) 0xffffffL) )) #define class(kk) ((int)( ((KEY) (kk))>>24 )) char* name(KEY k); /*returns the name or the word "NULL" in case of a wrong key */ char* className(KEY k) ; /* returns the name of the class of key */ KEY str2tag (char* tagName) ; typedef BOOL (*DisplayFunc)(KEY key, KEY from, BOOL isOld) ; typedef BOOL (*ParseFunc)(int level, KEY key) ; typedef BOOL (*DumpFunc)(FILE *f, Stack s, KEY k) ; typedef BOOL (*KillFunc)(KEY k) ; typedef void (*BlockFunc)(KEY) ; #endif AcePerl-1.92/acelib/wh/regression.h0000644000175000017500000000063407565000306016530 0ustar lsteinlstein/* Last edited: Dec 4 14:48 1998 (fw) */ /* header file for regression.c */ /* $Id: regression.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */ #ifndef DEFINE_REGRESSION_h #define DEFINE_REGRESSION_h #include "regular.h" typedef struct point {double x, y ;} POINT ; void linearRegression(Array a, double *ap, double *bp, double *rp, double *wp) ; void plotLinearRegression(char *title, Array a) ; #endif AcePerl-1.92/acelib/wh/help_.h0000644000175000017500000000564207121260303015434 0ustar lsteinlstein/* File: helpsubs_.h * Author: Fred Wobus (fw@sanger.ac.uk) * Copyright (C) J Thierry-Mieg and R Durbin, 1998 *------------------------------------------------------------------- * This file is part of the ACEDB genome database package, written by * Richard Durbin (MRC LMB, UK) rd@sanger.ac.uk, and * Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr * * SCCS: %W% %G% * Description: private headerfile for the help-system. * Exported functions: none * HISTORY: * Last edited: Dec 4 14:35 1998 (fw) * * Oct 8 14:15 1998 (fw): renamed from helpsubs_.h to help_.h * * Oct 8 11:35 1998 (fw): introduced macro for HELP_FILE_EXTENSION * Created: Tue Aug 18 17:38:27 1998 (fw) *------------------------------------------------------------------- */ #ifndef _HELP__H #define _HELP__H #include "help.h" #include /* for isspace etc.. */ /************************************************************/ #define HELP_FILE_EXTENSION "html" /* forward declaration of struct type */ typedef struct HtmlPageStruct HtmlPage; typedef struct HtmlNodeStruct HtmlNode; /************************************************************/ /********** routines shared by the help-package *************/ HtmlPage *htmlPageCreate (char *helpFilename); /* parse the HTML page for the given file */ HtmlPage *htmlPageCreateFromFile (FILE *fil); /* parse the HTML source from an opened file */ void htmlPageDestroy (HtmlPage *page); /* clear all memory taken up by the page */ void stripSpaces (char *cp); /* utility : remove whitespaces from free text in non-

 mode */


/************************************************************/

typedef enum { 
  HTML_SECTION=1, 
  HTML_COMMENT, 
  HTML_DOC, 
  HTML_BODY, 
  HTML_HEAD,
  HTML_TITLE, 
  HTML_HEADER, 
  HTML_TEXT, 
  HTML_HREF, 
  HTML_RULER, 
  HTML_LINEBREAK, 
  HTML_PARAGRAPH, 
  HTML_LIST, 
  HTML_LISTITEM, 
  HTML_GIFIMAGE,
  HTML_BOLD_STYLE, 
  HTML_STRONG_STYLE, 
  HTML_ITALIC_STYLE, 
  HTML_CODE_STYLE,
  HTML_STARTPREFORMAT, 
  HTML_ENDPREFORMAT,
  HTML_STARTBLOCKQUOTE, 
  HTML_ENDBLOCKQUOTE,
  HTML_UNKNOWN, 
  HTML_NOIMAGE 
} HtmlNodeType ;
 
typedef enum {
  HTML_LIST_BULLET=1, 
  HTML_LIST_NUMBER, 
  HTML_LIST_NOINDENT, 
  HTML_LIST_NOBULLET, 
  HTML_LIST_NOINDENT_NOBULLET
} HtmlListType ;
/* a 
     node and its 
  •  items are LIST_BULLET
   a 
       node and its 
    1.  items are LIST_NUMBER
   a 
       node is LIST_NOINDENT,
               its 
    2.  node are also LIST_NOINDENT
               but 
       items are LIST_NOBULLET
	       and 
       items are LIST_NOINDENT_NOBULLET
*/

/************************************************************/


struct HtmlNodeStruct {
  HtmlNodeType type ;
  HtmlNode *left, *right ;
  char *text ;
  char *link ;
  int hlevel ;
  HtmlListType lstyle ;
  BOOL isNameRef ;
};


struct HtmlPageStruct {
  char *htmlText;		/* source text */
  HtmlNode *root;		/* root node of parsetree */
  STORE_HANDLE handle;
};


#endif /* !def _HELP__H */
AcePerl-1.92/acelib/wh/aceclient.h0000644000175000017500000000161007565000306016272 0ustar  lsteinlstein/*  Last edited: Jan 19 18:10 1996 (mieg) */
#ifndef _ACECLIENT_
#define _ACECLIENT_

/* $Id: aceclient.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */

#define DEFAULT_PORT 0x20000101

#define ACE_UNRECOGNIZED 100
#define ACE_OUTOFCONTEXT 200
#define ACE_INVALID      300
#define ACE_SYNTAXERROR  400

#define HAVE_ENCORE   -1
#define WANT_ENCORE   -1
#define DROP_ENCORE   -2

struct ace_handle {
	int clientId;
	int magic;
	void *clnt;
};
typedef struct ace_handle ace_handle;

extern ace_handle *openServer(char *host, unsigned long rpc_port, int timeOut);
extern void closeServer(ace_handle *handle);
extern int askServer(ace_handle *handle, char *request, char **answerPtr, int chunkSize) ; 
extern int askServerBinary(ace_handle *handle, char *request, unsigned char **answerPtr, 
			   int *answerLength, int *encorep, int chunkSize) ; 

/* do not write behind this line */
#endif /* _ACECLIENT_ */

AcePerl-1.92/acelib/wh/mystdlib.h0000644000175000017500000003044707565000306016204 0ustar  lsteinlstein/*  File: mystdlib.h
 *  Author: Jean Thierry-Mieg (mieg@mrc-lmb.cam.ac.uk)
 *  Copyright (C) J Thierry-Mieg and R Durbin, 1992
 *-------------------------------------------------------------------
 * This file is part of the ACEDB genome database package, written by
 * 	Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr
 *
 * Description:
 ** Prototypes of system calls
 ** One should in principle use stdlib, however on the various machines,
    stdlibs do not always agree, I found easier to look by hand 
    and copy here my human interpretation of what I need.
    Examples of problems are: reservations for multi processor
    architectures on some Silicon machines, necessity to define myFile_t on
    some machines and not on others etc.
 * Exported functions:
 * HISTORY:
 * Last edited: Dec  4 16:03 1998 (fw)
 * * Feb  6 14:04 1997 (srk)
 * * Jun 11 16:46 1996 (rbrusk): WIN32 tace fixes
 * * Jun 10 17:46 1996 (rbrusk): strcasecmp etc. back to simple defines...
 * * Jun  9 19:29 1996 (rd)
 * * Jun 5 15:36 1996 (rbrusk): WIN32 port details
 *	-	Added O/S specific pathname syntax token conventions as #defined symbols
 * * Jun 5 10:06 1996 (rbrusk): moved X_OK etc. from filsubs.c for IBM
 * Jun  4 23:33 1996 (rd)
 * * Jun  4 21:19 1996 (rd): WIN32 changes
 * Created: Fri Jun  5 18:29:09 1992 (mieg)
 *-------------------------------------------------------------------
 */

/* $Id: mystdlib.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */

#ifndef DEF_MYSTDLIB_H
#define DEF_MYSTDLIB_H

/* below needed for MAXPATHLEN */
#if !defined(WIN32)
#include 
#endif

#if defined(MSDOS)
  #define O_RDONLY 1
  #define O_WRONLY 2
  #define O_RDWR   4
  #define O_BINARY 0x8000
#else
#if !(defined(MACINTOSH) || defined(WIN32))
#define O_BINARY 0
#endif
#endif

#if defined(ALLIANT) || defined(CONVEX) 
#define O_RDONLY 0
#endif

/************************ WIN32 stuff ************************/
#if defined(WIN32)

#include  /* for S_IREAD | S_IWRITE */

#define X_OK	0
#define W_OK	2
#define R_OK	4
#define F_OK	X_OK /* if i exist in WIN32, then i might be executable? */

#include 		/* for access() in dotter.c */
typedef int uid_t ;	/* UNIX/RPC types not currently used in WIN32 */

/*  O/S specific file system pathname conventions:
	general syntax conventions symbolically defined */

/* In WIN32/DOS... */ 

#define PATH_DELIMITER ';'
#define DRIVE_DELIMITER ':'			/* Not used in UNIX */
#define DRIVE_DELIMITER_STR ":"		/* Not used in UNIX */
#define SUBDIR_DELIMITER '\\'
#define SUBDIR_DELIMITER_STR "\\"

char *DosToPosix(char *path) ; /* defined in filsubs.c */
#define UNIX_PATHNAME(z) DosToPosix(z)

/**************** some NON-WIN32 equivalents ******************/
#else  /* UNIX-like, NOT WIN32 */

#define PATH_DELIMITER ':'
#define SUBDIR_DELIMITER '/'
#define SUBDIR_DELIMITER_STR "/"

#define UNIX_PATHNAME(z) z   /* Already a UNIX filename? */

#endif
/************** #endif !defined(WIN32) *************************/


  /*<<--neil 16Sep92: to avoid using values.h*/
#define ACEDB_MAXINT 2147483647
#define ACEDB_MINDOUBLE 1.0e-305
#define ACEDB_LN_MINDOUBLE -700

/* The next few are designed to determine how the compiler aligns structures,
   not what we can get away with; change only if extreme circumstances */

#define INT_ALIGNMENT (sizeof(struct{char c; int i; }) - sizeof(int))
#define DOUBLE_ALIGNMENT (sizeof(struct {char c; double d; }) - sizeof(double))
#define SHORT_ALIGNMENT (sizeof(struct {char c; short s; }) - sizeof(short))
#define FLOAT_ALIGNMENT (sizeof(struct {char c; float f; }) - sizeof(float))
#define PTR_ALIGNMENT (sizeof(struct {char c; void *p; }) - sizeof(void *))

/* Constants for store alignment */

/* These are defined as follows:
   MALLOC_ALIGNMENT
   Alignment of most restrictive data type, the system malloc will 
   return addresses aligned to this, and we do the same in messalloc.

   STACK_ALIGNMENT 
   Alignment of data objects on a Stack; this should really be
   the same as MALLOC_ALIGNMENT, but for most 32 bit pointer machines
   we align stacks to 4 bytes to save memory.

   STACK_DOUBLE_ALIGNMENT
   Alignment of doubles required on stack, if this is greater than
   STACK_ALIGNMENT, we read and write doubles on a stack by steam.


   Put specific exceptions first, the defaults below should cope 
   with most cases. Oh, one more thing, STACK_ALIGNMENT and
   STACK_DOUBLE ALIGNMENT are used on pre-processor constant 
   expressions so no sizeofs, sorry.
*/


/* 680x0 processors can fix up unaligned accesses so we trade off speed
   against memory usage on a Mac. I have no idea if this is a good
   trade-off, I only program real computers - srk */

#if defined(NEXT) || defined(MACINTOSH) 
#  define STACK_ALIGNMENT 2
#  define STACK_DOUBLE_ALIGNMENT 2
#  define MALLOC_ALIGNMENT 4
#endif

/* Alpha pointers are 8 bytes, so align the stack to that */
#if defined(ALPHA) || defined(ALIGNMENT_64_BIT)
#  define STACK_ALIGNMENT 8
#endif

#if !defined(STACK_ALIGNMENT)
#  define STACK_ALIGNMENT 4
#endif

#if !defined(STACK_DOUBLE_ALIGNMENT)
#  define STACK_DOUBLE_ALIGNMENT 8
#endif

#if !defined(MALLOC_ALIGNMENT) 
#  define MALLOC_ALIGNMENT DOUBLE_ALIGNMENT
#endif

#if defined(POSIX) || defined(LINUX) || defined(SOLARIS) || defined(SGI) || \
	defined(HP) || defined(WIN32) || defined(INTEL_SOLARIS)

#ifdef WIN32
#include 
#endif /* WIN32 */

#include 
#include 
#include 
#include 
#include 

#include 
#include 

#if !defined(WIN32)
#include 
#include 
#endif /* !WIN32 */

#if defined(HP)
#include 
#define seteuid setuid     /* bizare that this is missing on the HP ?? */
#endif /* HP */

typedef size_t mysize_t;
/* typedef fpos_t myoff_t;  why? i remove this on jan 98 to compile on fujitsu */
typedef off_t myoff_t;
typedef mysize_t myFile_t;

#define FIL_BUFFER_SIZE 256
#define DIR_BUFFER_SIZE MAXPATHLEN

#if defined(WIN32)

  /* _MAX_PATH is 260 in WIN32 but each path component can be max. 256 in size */
#undef DIR_BUFFER_SIZE
#define DIR_BUFFER_SIZE   FIL_BUFFER_SIZE
#define MAXPATHLEN        _MAX_PATH

#define popen _popen
#define pclose _pclose

/* rename to actual WIN32 built-in functions
* (rbrusk): this little code generated a "trigraph" error message
* when built in unix with the gcc compiler; however, I don't understand
* why gcc even sees this code, which is #if defined(WIN32)..#endif protected.
* Changing these to macros is problematic in lex4subs.c et al, which expects
* the names as function names (without parentheses.  So, I change them back..
* If the trigraph error message returns, look for another explanation,
* like MSDOS carriage returns, or something? */
#define strcasecmp  _stricmp 
#define strncasecmp  _strnicmp 
#endif /* WIN32 */

#else  /* not POSIX etc. e.g. SUNOS */

/* local versions of general types */

#if defined(ALLIANT) || defined (DEC) || defined(MAC_AUX) || defined(MACINTOSH)
  typedef unsigned int mysize_t ;
#elif defined(SGI)
  typedef unsigned mysize_t ;
#elif defined(NEXT) || defined(IBM) || defined(MACINTOSH)
  typedef unsigned long mysize_t ;
#else
  typedef int mysize_t ;
#endif

/* stdio */

#include 

/* Definition of the file position type */
#if defined(SUN) 
  typedef long    fpos_t;
#endif /* SUN */

#if defined(ALLIANT) || defined(CONVEX) || defined(MAC_AUX) || defined(METROWERKS)
  typedef long myoff_t ;
#else
  typedef fpos_t myoff_t ;
#endif

/* Constants to be used as 3rd argument for "fseek" function */
#if !defined(SGI) && !defined(ALLIANT)
#define SEEK_CUR        1
#define SEEK_END        2
#define SEEK_SET        0
#endif


/* io.h definitions and prototypes */
#ifndef METROWERKS
#include 
#endif /* !METROWERKS */

#ifdef IBM
#include 
#include 
#endif /* IBM */


#if !defined(MACINTOSH)
#include 
#include 

#include 
#include 
#endif /* !MACINTOSH */


/* string and memory stuff */

#include 
#include 


/* missing */
#if defined(DEC) || defined(MACINTOSH) || defined (SUN) || defined (NEC)|| defined(HP) || defined(IBM)
/* case-insensitive string comparison */
int     strcasecmp (const char *a, const char *b) ;
int     strncasecmp(const char *s1, const char *s2, mysize_t n);
#endif

#ifndef	__malloc_h
void free (void *block) ;  /* int on SUN, void on SGI etc */
#endif

/* system functions and sorts - simplest to give full prototypes for all */
int      system    (const char *command);
#ifndef IBM
void     exit      (int status); 
#endif
char   * getenv    (const char *name);

#if !defined(NEXT) && !defined(ALPHA)
void     qsort     (void *base, mysize_t nelem, mysize_t width,
                    int  (*fcmp)(const void *, const void *)) ;
#endif /* !NEXT or !ALPHA */

/* math stuff */
#include 

#ifndef THINK_C
extern double atof (const char *cp) ; /* I hope ! */
#endif

#ifndef MAXPATHLEN
#define MAXPATHLEN 1024
#endif
#define FIL_BUFFER_SIZE 256
#define DIR_BUFFER_SIZE MAXPATHLEN 

#endif  /* not POSIX etc. */



/***************** missing in some stdio.h ****************/
#ifdef SUN
int rename (const char *from, const char *to);
#endif /* SUN */



/************** missing in some unistd.h *******************/
#if defined SUN || defined SOLARIS 
int lockf(int filedes, int request, off_t size );
int gethostname(char *name, int namelen);
#endif /* SOLARIS */

/************* handling of variable-length parameter lists *********/

#include 

#if !(defined(MACINTOSH)  || defined(SOLARIS) || defined(POSIX) || defined(WIN32))
 int vfprintf (FILE *stream, const char *format, va_list arglist);
 int vprintf  (const char *format, va_list arglist);
#endif	/* !( defined(MACINTOSH)  etc. ) */

#if defined(SUN)
 char *vsprintf (char *buffer, const char *format, va_list arglist);
#else
#if ! defined(POSIX) && ! defined(SOLARIS)
 int vsprintf (char *buffer, const char *format, va_list arglist);
#endif /* !POSIX */
#endif /* !SUN */

/*******************************************************************/

#ifdef SUN			/* missing prototypes on SUN */
int       fclose   (FILE *stream);
int       fflush   (FILE *stream);
int       fgetc    (FILE *stream);
int       ungetc   (int c, FILE *stream) ;
int       _filbuf  (FILE *stream) ;
int       _flsbuf  (unsigned char x, FILE *stream) ;
int       fprintf  (FILE *stream, const char *format, ...);
int       fscanf   (FILE *stream, const char *format, ...);
int       scanf    (const char *format, ...);
int       printf   (const char *format, ...);
int       sscanf   (const char *buffer, const char *format, ...);
int       fgetpos  (FILE *stream, fpos_t *pos);
char    * fgets    (char *s, int n, FILE *stream);
FILE    * fopen    (const char *path, const char *mode);
int       fputc    (int c, FILE *stream);
int       fputs    (const char *s, FILE *stream);
int       fseek    (FILE *stream, long offset, int whence);
int       fsetpos  (FILE *stream, const fpos_t *pos);
long      ftell    (FILE *stream);
mysize_t  fread    (void *ptr, mysize_t size, mysize_t n, FILE *stream);
mysize_t  fwrite   (const void *ptr, mysize_t size, mysize_t n,
                          FILE *stream);
void      perror   (const char *s);
FILE      *popen   (const char *command, const char *type);
int       pclose   (FILE *stream);
void      rewind   (FILE *stream);
void      setbuf   (FILE *stream, char *buf);

/*int       isalpha  (int c); - fails for some reason with "parse error before `+'" */
char      getopt   (int c, char **s1, char *s2);
#endif /* defined SUN */

/************************************************************/

#ifdef SUN
/* memmove is not included in SunOS libc, bcopy is */
#define memmove(d,s,l) bcopy(s,d,l)
void  bcopy(char *b1, char *b2, int length);

/* for 'bare' calls, in case the storage is destroyed by 
   lower-level libraries not using messalloc */
#include "malloc.h"

/* not defined in SUN's unistd.h */
int setruid(uid_t ruid);
int seteuid(uid_t euid);
#endif /* SUN */

/*******************************************************************/


/* some stdlib.h don't define these exit codes */
#ifndef EXIT_FAILURE
#define EXIT_FAILURE   (1)              /* exit function failure        */
#endif /* if !EXIT_FAILURE */

#ifndef EXIT_SUCCESS
#define EXIT_SUCCESS    0               /* exit function success        */
#endif /* if !EXIT_SUCCESS */


#endif  /* DEF_MYSTDLIB_H */

/***********************************************************/
AcePerl-1.92/acelib/wh/array.h0000644000175000017500000002702007121260303015455 0ustar  lsteinlstein/*  File: array.h
 *  Author: Richar Durbin (rd@sanger.ac.uk)
 *  Copyright (C) J Thierry-Mieg and R Durbin, 1998
 *-------------------------------------------------------------------
 * This file is part of the ACEDB genome database package, written by
 * 	Richard Durbin (Sanger Centre, UK) rd@sanger.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@crbm.cnrs-mop.fr
 *
 * Description: header for arraysub.c
 *              NOT to be included by the user, included by regular.h
 * Exported functions:
 *              the Array type and associated functions
 *              the Stack type and associated functions
 *              the Associator functions
 * HISTORY:
 * Last edited: Dec  4 11:03 1998 (fw)
 * Created: Fri Dec  4 11:01:35 1998 (fw)
 *-------------------------------------------------------------------
 */

#ifndef DEF_ARRAY_H
#define DEF_ARRAY_H
 
unsigned int stackused (void) ;
 
/************* Array package ********/

/* #define ARRAY_CHECK either here or in a single file to
   check the bounds on arr() and arrp() calls
   if defined here can remove from specific C files by defining
   ARRAY_NO_CHECK (because some of our finest code
                   relies on abuse of arr!) YUCK!!!!!!!
*/

/* #define ARRAY_CHECK */

typedef struct ArrayStruct
  { char* base ;    /* char* since need to do pointer arithmetic in bytes */
    int   dim ;     /* length of alloc'ed space */
    int   size ;
    int   max ;     /* largest element accessed via array() */
    int   id ;      /* unique identifier */
    int   magic ;
  } *Array ;
 
    /* NB we need the full definition for arr() for macros to work
       do not use it in user programs - it is private.
    */

#define ARRAY_MAGIC 8918274
#define STACK_MAGIC 8918275
#define   ASS_MAGIC 8918276

#if !defined(MEM_DEBUG)
  Array   uArrayCreate (int n, int size, STORE_HANDLE handle) ;
  void    arrayExtend (Array a, int n) ;
  Array   arrayCopy (Array a) ;
#else
  Array   uArrayCreate_dbg (int n, int size, STORE_HANDLE handle,
			    const char *hfname,int hlineno) ;
  void    arrayExtend_dbg (Array a, int n, const char *hfname,int hlineno) ;
  Array	arrayCopy_dbg(Array a, const char *hfname,int hlineno) ; 
#define uArrayCreate(n, s, h) uArrayCreate_dbg(n, s, h, __FILE__, __LINE__)
#define arrayExtend(a, n ) arrayExtend_dbg(a, n, __FILE__, __LINE__)
#define arrayCopy(a) arrayCopy_dbg(a, __FILE__, __LINE__)
#endif

Array   uArrayReCreate (Array a,int n, int size) ;
void    uArrayDestroy (Array a);
char    *uArray (Array a, int index) ;
char    *uArrCheck (Array a, int index) ;
char    *uArrayCheck (Array a, int index) ;
#define arrayCreate(n,type)	uArrayCreate(n,sizeof(type), 0)
#define arrayHandleCreate(n,type,handle) uArrayCreate(n, sizeof(type), handle)
#define arrayReCreate(a,n,type)	uArrayReCreate(a,n,sizeof(type))
#define arrayDestroy(x)		((x) ? uArrayDestroy(x), x=0, TRUE : FALSE)

#if (defined(ARRAY_CHECK) && !defined(ARRAY_NO_CHECK))
#define arrp(ar,i,type)	((type*)uArrCheck(ar,i))
#define arr(ar,i,type)	(*(type*)uArrCheck(ar,i))
#define arrayp(ar,i,type)	((type*)uArrayCheck(ar,i))
#define array(ar,i,type)	(*(type*)uArrayCheck(ar,i))
#else
#define arr(ar,i,type)	((*(type*)((ar)->base + (i)*(ar)->size)))
#define arrp(ar,i,type)	(((type*)((ar)->base + (i)*(ar)->size)))
#define arrayp(ar,i,type)	((type*)uArray(ar,i))
#define array(ar,i,type)	(*(type*)uArray(ar,i))
#endif /* ARRAY_CHECK */

            /* only use arr() when there is no danger of needing expansion */
Array   arrayTruncatedCopy (Array a, int x1, int x2) ;
void    arrayStatus (int *nmadep,int* nusedp, int *memAllocp, int *memUsedp) ;
int     arrayReportMark (void) ; /* returns current array number */
void    arrayReport (int j) ;	/* write stderr about all arrays since j */
#define arrayMax(ar)            ((ar)->max)
#define arrayForceFeed(ar,j) (uArray(ar,j), (ar)->max = (j))
#define arrayExists(ar)		((ar) && (ar)->magic == ARRAY_MAGIC ? (ar)->id : 0 ) 
            /* JTM's package to hold sorted arrays of ANY TYPE */
BOOL    arrayInsert(Array a, void * s, int (*order)(void*, void*));
BOOL    arrayRemove(Array a, void * s, int (*order)(void*, void*));
void    arraySort(Array a, int (*order)(void*, void*)) ;
void    arraySortPos (Array a, int pos, int (*order)(void*, void*));
void    arrayCompress(Array a) ;
BOOL    arrayFind(Array a, void *s, int *ip, int (*order)(void*, void*));
BOOL    arrayIsEntry(Array a, int i, void *s);
 
/************** Stack package **************/
 
typedef struct StackStruct      /* assumes objects <= 16 bytes long */
  { Array a ;
    int magic ;
    char* ptr ;         /* current end pointer */
    char* pos ;         /* potential internal pointer */

    char* safe ;        /* need to extend beyond here */
    BOOL  textOnly; /* If this is set, don't align the stack.
		       This (1) save space (esp on ALPHA) and
		       (2) provides stacks which can be stored and got
		       safely between architectures. Once you've set this,
		       using stackTextOnly() only pushText, popText, etc, 
		       no other types. */   
  } *Stack ;
 
        /* as with ArrayStruct, the user should NEVER access StackStruct
           members directly - only through the subroutines/macros
        */
#if !defined(MEM_DEBUG)
  Stack   stackHandleCreate (int n, STORE_HANDLE handle) ;
#else
  Stack   stackHandleCreate_dbg (int n, STORE_HANDLE handle,
				 const char *hfname,int hlineno) ;
#define stackHandleCreate(n, h) stackHandleCreate_dbg(n, h, __FILE__, __LINE__)
#endif

#define stackCreate(n) stackHandleCreate(n, 0)
Stack   stackReCreate (Stack s, int n) ;
Stack   stackCopy (Stack, STORE_HANDLE handle) ;
void    stackTextOnly(Stack s);
void    uStackDestroy (Stack s);
#define stackDestroy(x)	 ((x) ? uStackDestroy(x), (x)=0, TRUE : FALSE)
void    stackExtend (Stack s, int n) ;
void    stackClear (Stack s) ;
#define stackEmpty(stk)  ((stk)->ptr <= (stk)->a->base)
#define stackExists(stk) ((stk) && (stk)->magic == STACK_MAGIC ? arrayExists((stk)->a) : 0)


/* Stack alignment: we use two strategies: the smallest type we push is
   a short, so if the required alignment is to 2 byte boundaries, we 
   push each type to its size, and alignments are kept.

   Otherwise, we push each type to STACK_ALIGNMENT, this ensures 
   alignment but can waste space. On machines with 32 bits ints and
   pointers, we make satck alignment 4 bytes, and do the consequent unaligned
   access to doubles by steam.

   Characters and strings are aligned separately to STACK_ALIGNMENT.
*/ 
   

#if (STACK_ALIGNMENT<=2)
#define push(stk,x,type) ((stk)->ptr < (stk)->safe ? \
                           ( *(type *)((stk)->ptr) = (x) , (stk)->ptr += sizeof(type)) : \
			    (stackExtend (stk,16), \
			     *(type *)((stk)->ptr) = (x) , (stk)->ptr += sizeof(type)) )
#define pop(stk,type)    (  ((stk)->ptr -= sizeof(type)) >= (stk)->a->base ? \
			    *((type*)((stk)->ptr)) : \
                          (messcrash ("User stack underflow"), *((type*)0)) )
#define stackNext(stk,type) (*((type*)(  (stk)->pos += sizeof(type) )  - 1 )  )

#else

#define push(stk,x,type) ((stk)->ptr < (stk)->safe ? \
                           ( *(type *)((stk)->ptr) = (x) , (stk)->ptr += STACK_ALIGNMENT) : \
			    (stackExtend (stk,16), \
			     *(type *)((stk)->ptr) = (x) , (stk)->ptr += STACK_ALIGNMENT) )
#define pop(stk,type)    (  ((stk)->ptr -= STACK_ALIGNMENT) >= (stk)->a->base ? \
			    *((type*)((stk)->ptr)) : \
                          (messcrash ("User stack underflow"), *((type*)0)) )
#define stackNext(stk,type) (*((type*)(  ((stk)->pos += STACK_ALIGNMENT ) - \
                                             STACK_ALIGNMENT ))  )
#endif

#if STACK_DOUBLE_ALIGNMENT > STACK_ALIGNMENT
void ustackDoublePush(Stack stk, double x);
double ustackDoublePop(Stack stk);
double stackDoubleNext(Stack stk);
#define pushDouble(stk,x) ustackDoublePush(stk, x)
#define popDouble(stk) ustackDoublePop(stk)
#define stackDoubleNext(stk) ustackDoubleNext(stk) 
#else
#define pushDouble(stk,x) push(stk, x, double)
#define popDouble(stk) pop(stk, double)
#define stackDoubleNext(stk) stackNext(stk, double)
#endif  


void    pushText (Stack s, char *text) ;
char*   popText (Stack s) ;	/* returns last text and moves pointer before it */
void    catText (Stack s, char *text) ;  /* like strcat */
void	stackTokeniseTextOn(Stack s, char *text, char *delimiters) ; /* tokeniser */

int     stackMark (Stack s) ;              /* returns a mark of current ptr */
int     stackPos (Stack s) ;              /* returns a mark of current pos, useful with stackNextText */
void    stackCursor (Stack s, int mark) ;  /* sets ->pos to mark */
#define stackAtEnd(stk)     ((stk)->pos >= (stk)->ptr)
char*   stackNextText (Stack s) ;
 
#define stackText(stk,mark) ((char*)((stk)->a->base + (mark)))
#define stackTextForceFeed(stk,j) (arrayForceFeed((stk)->a,j) ,\
                 (stk)->ptr = (stk)->pos = (stk)->a->base + (j) ,\
                 (stk)->safe = (stk)->a->base + (stk)->a->dim - 16 )
void    catBinary (Stack s, char* data, int size) ;
 
/********** Line breaking package **********/
 
int     uLinesText (char *text, int width) ;
char    *uNextLine (char *text) ;
char    *uPopLine (char *text) ;
char    **uBrokenLines (char *text, int width) ; /* array of lines */
char    *uBrokenText (char *text, int width) ; /* \n's intercalated */

/********** Associator package *************/

typedef struct AssStruct
  { int magic ;                 /* Ass_MAGIC */
    int id ;                    /* unique identifier */
    int n ;			/* number of items stored */
    int m ;			/* power of 2 = size of arrays - 1 */
    int i ;                     /* Utility state */
    void **in,**out ;
    unsigned int mask ;		/* m-1 */
  } *Associator ; 
 
#define assExists(a) ((a) && (a)->magic == ASS_MAGIC ? (a)->id : 0 )

#if !defined(MEM_DEBUG)
  Associator assHandleCreate (STORE_HANDLE handle) ;
  Associator assBigCreate (int size) ;
#else
  Associator assHandleCreate_dbg (STORE_HANDLE handle,
				 const char *hfname, int hlineno) ;
  Associator assBigCreate_dbg (int size, const char *hfname, int hlineno) ;
#define assHandleCreate(h) assHandleCreate_dbg(h, __FILE__, __LINE__)
#define assBigCreate(s) assBigCreate_dbg(s, __FILE__, __LINE__)
#endif

#define assCreate() assHandleCreate(0)
Associator assReCreate (Associator a) ;
void    uAssDestroy (Associator a) ;
#define assDestroy(x)  ((x) ? uAssDestroy(x), x = 0, TRUE : FALSE)
BOOL    uAssFind (Associator a, void* xin, void* *pout) ;
BOOL    uAssFindNext(Associator a, void* xin, void * *pout);
#define assFind(ax,xin,pout)    uAssFind((ax),(xin),(void**)(pout))
            /* if found, updates *pout and returns TRUE, else returns FALSE */
#define assFindNext(ax,xin,pout) uAssFindNext((ax),(xin),(void**)(pout))
BOOL    assInsert (Associator a, void* xin, void* xout) ;
            /* if already there returns FALSE, else inserts and returns TRUE */
void    assMultipleInsert(Associator a, void* xin, void* xout);
           /* allow multiple Insertions */
BOOL    assRemove (Associator a, void* xin) ;
            /* if found, removes entry and returns TRUE, else returns FALSE */
BOOL    assPairRemove (Associator a, void* xin, void* xout) ;
            /* remove only if both fit */
void    assDump (Associator a) ;
           /* for debug - uses printf */
void    assClear (Associator a) ;
BOOL    uAssNext (Associator a, void* *pin, void* *pout) ;
#define assNext(ax,pin,pout)	uAssNext((ax),(void**)(pin),(void**)pout)
/* convert an integer to a void * without generating a compiler warning */
#define assVoid(i) ((void *)(((char *)0) + (i))) 
#define assInt(v) ((int)(((char *)v) - ((char *)0)))

#endif /* defined(DEF_ARRAY_H) */

/**************************** End of File ******************************/

 
AcePerl-1.92/acelib/wh/version.h0000644000175000017500000001636107565000306016041 0ustar  lsteinlstein/*  File: version.h
 *  Author: Ed Griffiths (edgrif@sanger.ac.uk)
 *  Copyright (c) J Thierry-Mieg and R Durbin, 1998
 *-------------------------------------------------------------------
 * This file is part of the ACEDB genome database package, written by
 * 	Richard Durbin (Sanger Centre, UK) rd@sanger.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.crbm.cnrs-mop.fr
 *
 * Description: Macros to support version numbering of libraries and
 *              applications in acedb.
 * Exported functions:
 * HISTORY:
 * Last edited: Dec 10 13:32 1998 (edgrif)
 * * Dec  3 14:37 1998 (edgrif): Set up macros to insert copyright strings.
 * Created: Tue Dec  1 13:29:08 1998 (edgrif)
 * CVS info:   $Id: version.h,v 1.1 2002/11/14 20:00:06 lstein Exp $
 *-------------------------------------------------------------------
 */

#ifndef UT_VERSION_H
#define UT_VERSION_H


/* Tools for creating version strings in an application or library.          */
/*                                                                           */


/* This macro creates a routine that must be provided by all applications    */
/* that use the ACECB kernel code or libace. libace routines expect to be    */
/* able to query the date on which the applications main routine was         */
/* compiled so that this information can be displayed to the user.           */
/* The function must have this prototype and must return a string that gives */
/* the build date:                                                           */
/*                                                                           */
char *utAppGetCompileDate(void) ;
/* The acedb                                                                 */
/* makefile is arranged so that the main routine is recompiled every time    */
/* the application is relinked. This means that the date represents the      */
/* 'build' date of the application.                                          */
/*                                                                           */
/* Code the macro by simply putting it in the .c file that contains the      */
/* main function of the application, it's probably best to put it just       */
/* before or after the main function. Do not put a terminating ';' after     */
/* the macro, this will cause a compile error.                               */
/*                                                                           */
#define UT_COMPILE_PHRASE "compiled on:"

#define UT_MAKE_GETCOMPILEDATEROUTINE()                                      \
char *utAppGetCompileDate(void) { return UT_COMPILE_PHRASE " " __DATE__ " " __TIME__ ; }



/* These tools assume that various numbers/strings are defined, e.g.         */
/*                                                                           */
/* #define SOME_TITLE   "UT library"         (definitive name for library)   */
/* #define SOME_DESC    "brief description"  (purpose of library - one liner)*/
/* #define SOME_VERSION 1                    (major version)                 */
/* #define SOME_RELEASE 0                    (minor version)                 */
/* #define SOME_UPDATE  1                    (latest fix number)             */
/*                                                                           */

/* 1) Use UT_MAKESTRING to make strings out of #define'd numbers.            */
/*    (required because of the way ANSI preprocessor handles strings)        */
/*    e.g. UT_MAKESTRING(6)  produces "6"                                    */
/*                                                                           */
#define UT_PUTSTRING(x) #x
#define UT_MAKESTRING(x) UT_PUTSTRING(x)

/* 2) Make a single version number out of the version, release and update    */
/*    numbers.                                                               */
/* NOTE that there will be no more than 100 (i.e. 0 - 99) revisions per      */
/* version, or updates per revision, otherwise version will be wrong.        */
/*                                                                           */
#define UT_MAKE_VERSION_NUMBER(VERSION, RELEASE, UPDATE) \
((VERSION * 10000) + (RELEASE * 100) + UPDATE)

/* 3) Make a version string containing the title of the application/library  */
/*    and the version, release and update numbers.                           */
/*                                                                           */
#define UT_MAKE_VERSION_STRING(TITLE, VERSION, RELEASE, UPDATE) \
TITLE " - " UT_MAKESTRING(VERSION) "." UT_MAKESTRING(RELEASE) "." UT_MAKESTRING(UPDATE)


/* 4) Macro for creating a standard copyright string to be inserted into    */
/*    compiled applications and libraries. The macro ensures a common       */
/*    format for version numbers etc.                                       */
/*                                                                           */
/* The macro is a statement, NOT an expression, but does NOT require a       */
/* terminating semi-colon. The macro should be coded like this:              */
/*                                                                           */
/*    UT_COPYRIGHT_STRING(prefix, title, description)                        */
/*                                                                           */
/*    where  prefix is some a string locally used to prefix variables        */
/*    where  title is a string of the form   "Appname  1.0.1"                */
/*      and  description is of the form  "Application to blah, blah."        */
/*                                                                           */
#define UT_COPYRIGHT()                                                               \
"@(#) Copyright (c):  J Thierry-Mieg and R Durbin, 1998 \n"                          \
"@(#) \n"                                                                            \
"@(#) This file contains the above Sanger Informatics Group library, \n"             \
"@(#) written by   Richard Durbin (Sanger Centre, UK) rd@sanger.ac.uk \n"            \
"@(#)              Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.crbm.cnrs-mop.fr \n" \
"@(#)              Ed Griffiths (Sanger Centre, UK) edgrif@sanger.ac.uk \n"          \
"@(#)              Fred Wobus (Sanger Centre, UK) fw@sanger.ac.uk \n"                \
"@(#) You may redistribute this software subject to the conditions in the \n"        \
"@(#) accompanying copyright file. Anyone interested in obtaining an up to date \n"  \
"@(#) version should contact one of the authors at the above email addresses. \n"


#define UT_COPYRIGHT_STRING(TITLE, VERSION, RELEASE, UPDATE, DESCRIPTION_STRING)     \
static const char *ut_copyright_string =                                             \
"@(#) \n"                                                                            \
"@(#) --------------------------------------------------------------------------\n"  \
"@(#) Title/Version:  "UT_MAKE_VERSION_STRING(TITLE, VERSION, RELEASE, UPDATE)"\n"   \
"@(#)      Compiled:  "__DATE__" "__TIME__"\n"                                       \
"@(#)   Description:  " DESCRIPTION_STRING"\n"                                       \
UT_COPYRIGHT()                                                                       \
"@(#) --------------------------------------------------------------------------\n"  \
"@(#) \n" ;


#endif	/* UT_VERSION_H */
AcePerl-1.92/acelib/wh/keyset.h0000644000175000017500000000530107565000306015650 0ustar  lsteinlstein/*  File: keyset.h
 *  Author: R Durbin (rd@sanger.ac.uk)
 *  Copyright (C) J Thierry-Mieg and R Durbin, 1998
 *-------------------------------------------------------------------
 * This file is part of the ACEDB genome database package, written by
 * 	Richard Durbin (Sanger Centre, UK) rd@sanger.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@crbm.cnrs-mop.fr
 *
 * Description: public header for keyset operations.
 *              This file is part of acedb.h and NOT to be included
 *              by other source files.
 *              The KEYSET operations are built upon the Array ops
 *              provided by the utilities library libfree.a
 * Exported functions:
 * HISTORY:
 * Last edited: Dec 11 09:44 1998 (fw)
 * Created: Fri Dec 11 09:42:41 1998 (fw)
 *-------------------------------------------------------------------
 */

/* $Id: keyset.h,v 1.1 2002/11/14 20:00:06 lstein Exp $ */

#ifndef DEFINE_KEYSET_H
#define DEFINE_KEYSET_H

#include "regular.h"		/* header for libfree.a */

/***************************************************************/
/*  a KEYSET is an ordered array of KEYs.                         */
/***************************************************************/

typedef Array KEYSET ;  /* really KEYSET = array(,,KEY) always ordered */
#define keySetCreate()		arrayCreate(32,KEY)
#define keySetHandleCreate(h)	arrayHandleCreate(32,KEY,h)
#define keySetReCreate(s)	arrayReCreate(s,32,KEY)
#define keySet(s,i)		array(s,i,KEY)
#define keySetDestroy(s)	arrayDestroy(s)

#define keySetInsert(s,k)	arrayInsert(s,&(k),keySetOrder)
#define keySetRemove(s,k)	arrayRemove(s,&(k),keySetOrder)
#define keySetSort(s)		arraySort((s),keySetOrder) 
#define keySetCompress(s)	arrayCompress(s)
#define keySetFind(s,k,ip)	arrayFind ((s),&(k),(ip),keySetOrder)
#define keySetMax(s)		arrayMax(s)
#define keySetExists(s)		(arrayExists(s) && (s)->size == sizeof(KEY))
#define keySetCopy(s)		arrayCopy(s)

KEYSET  keySetAND (KEYSET x, KEYSET y) ;
KEYSET  keySetOR (KEYSET x, KEYSET y) ;
KEYSET  keySetXOR (KEYSET x, KEYSET y) ;
KEYSET  keySetMINUS (KEYSET x, KEYSET y) ;
int     keySetOrder (void *a, void*b) ;
int     keySetAlphaOrder (void *a, void*b) ;
KEYSET  keySetHeap (KEYSET source, int nn, int (*order)(KEY *, KEY *)) ;
KEYSET  keySetNeighbours (KEYSET ks) ;
KEYSET  keySetAlphaHeap (KEYSET ks, int nn) ;    /* jumps aliases/deletes */
KEYSET  keySetAlphaHeapAll (KEYSET ks, int nn) ; /* do not jump aliases */
int	keySetCountVisible (KEYSET ks) ;


/**************************************************************/

BOOL keySetActive (KEYSET *setp, void** lookp) ;
void keySetSelect () ;
BOOL keySetDump(FILE *f, Stack buffer, KEYSET s);

#endif
/*************************************************************/


AcePerl-1.92/acelib/wh/bump_.h0000644000175000017500000000265707121260303015452 0ustar  lsteinlstein/*  File: bump_.h
 *  Author: Fred Wobus (fw@sanger.ac.uk)
 *  Copyright (C) J Thierry-Mieg and R Durbin, 1998
 *-------------------------------------------------------------------
 * This file is part of the ACEDB genome database package, written by
 * 	Richard Durbin (Sanger Centre, UK) rd@sanger.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@crbm.cnrs-mop.fr
 *
 * Description: private header for the internals of the BUMP-package
 * Exported functions:  none
 *              completion of the BUMP structure to allow
 *              the inside if the BUMP-package to access the members
 *              of the structure.
 * HISTORY:
 * Last edited: Dec 17 16:20 1998 (fw)
 * Created: Thu Dec 17 16:17:32 1998 (fw)
 *-------------------------------------------------------------------
 */


#ifndef DEF_BUMP__H
#define DEF_BUMP__H

#include "bump.h"		/* include public header */

/* allow verification of a BUMP pointer */
extern magic_t BUMP_MAGIC;

/* completion of public opaque type as declared in bump.h */

struct BumpStruct {
  magic_t *magic ;		/* == &BUMP_MAGIC */
  int n ;         /* max x, i.e. number of columns */
  float *bottom ; /* array of largest y in each column */
  int minSpace ;  /* longest loop in y */
  float sloppy ;
  float maxDy ;  /* If !doIt && maxDy !=0,  Do not add further down */
  int max ;      /* largest x used (maxX <= n) */
  int xAscii, xGapAscii ;
  float yAscii ;
} ;

#endif /* DEF_BUMP_H */
AcePerl-1.92/acelib/wh/mytime.h0000644000175000017500000000607707565000306015663 0ustar  lsteinlstein/*  File: mytime.h
 *  Author: Richard Durbin (rd@sanger.ac.uk)
 *  Copyright (C) J Thierry-Mieg and R Durbin, 1996
 *-------------------------------------------------------------------
 * This file is part of the ACEDB genome database package, written by
 * 	Richard Durbin (MRC LMB, UK) rd@sanger.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr
 *
 * $Id: mytime.h,v 1.1 2002/11/14 20:00:06 lstein Exp $
 * Description:
 * Exported functions:
 * HISTORY:
 * Last edited: Dec  4 14:58 1998 (fw)
 * * Jul  9 17:20 1998 (fw): added timeComparison function
 * * Jul  8 15:48 1998 (fw): added timeDiff functions for mins,hours,months,years
 *                           as required by the new AQL date-functions
 * Created: Thu Jan 25 21:30:55 1996 (rd)
 *-------------------------------------------------------------------
 */

#ifndef DEFINE_MYTIME_h
#define DEFINE_MYTIME_h

   /* march 94: these functions can be used in conjunction
      with the _DateType fundamental type which can
      now be used in the same way as _Int _Float in models.wrm
   */

typedef unsigned int mytime_t;	/* for all machines */

/* define some missing prototypes for SunOS */
#ifdef SUN
time_t  time (time_t *timer) ;
mysize_t strftime (char *buf, mysize_t bufsize, const char *fmt,
		   const struct tm *tm) ;
/* double 	difftime (time_t , time_t) ;  seems bsent on Sun */
#define difftime(__t1,__t2) ((__t1) - (__t2))
time_t 	mktime (struct tm *) ;

#else  /* non-SunOS */

#include 

#endif /* !SUN */

/*****************************************************************/

/* create a dateType from a date string */
mytime_t timeParse (char *cp) ;

/* create a string representation from a dateType */
char*    timeShow (mytime_t t) ;

/* the following timeDiff functions will only update tdiff and return TRUE
   if both dates contain the portion of timestamp-detail that is referred to */
BOOL	 timeDiffSecs (mytime_t t1, mytime_t t2, int *tdiff) ; 
BOOL	 timeDiffMins (mytime_t t1, mytime_t t2, int *tdiff) ; 
BOOL	 timeDiffHours (mytime_t t1, mytime_t t2, int *tdiff) ; 
BOOL	 timeDiffDays (mytime_t t1, mytime_t t2, int *tdiff) ; 
BOOL	 timeDiffMonths (mytime_t t1, mytime_t t2, int *tdiff) ; 
BOOL	 timeDiffYears (mytime_t t1, mytime_t t2, int *tdiff) ;  /* always returns TRUE - as we always have years in a date/time */

/* compare two dates, returns boolean result of comparison depending on operator */
BOOL     timeComparison (int op, /* -1 for lessthan, 0 for equal, +1 for greaterthan */
			 mytime_t timeLeft, mytime_t timeRight);
/* see comments in timesubs.c for exact description of behaviour, 
   especially in cases where the level of detail specified in both dates varies */

char*    timeDiffShow (mytime_t t1, mytime_t t2) ;
char*	 timeShowFormat (mytime_t t, char *format, char *buf, int len) ;
char*    timeShowJava (mytime_t t) ;
mytime_t timeNow (void) ;
void     timeDiff (mytime_t t1, mytime_t t2, int *ydiff, int *mdiff,
                  int *ddiff, int *hdiff, int *mindiff, int *sdiff, 
                  int *minus) ;
int      monthLength (int year, int month, int minus) ;

#endif

AcePerl-1.92/acelib/Makefile0000644000175000017500000000733007121260301015210 0ustar  lsteinlsteintrue = 1
false = 0
RANLIB_NEEDED = true	# default overridable in $(ACEDB_MACHINE)_DEF
AR_OPTIONS = rlu	# default overridable in $(ACEDB_MACHINE)_DEF

RPCGEN_FLAGS = -I -K -1
# -I -K -1  good for alpha
# -b  -I -K -1  good for linux, probably solaris ?

# suppress auto SCCS extraction
.SCCS_GET:

#################################################################
########## Machine dependent compiler modification ##############
############# Are included from an external file ################
#### This is equivalent to, but more portable than $($(CC)) #####
### Edit these rules to adapt the makefile to a new machine #####
# Note that you can keep different DEF files for the same machine
# setting  various compiler  options
#################################################################
include wmake/$(ACEDB_MACHINE)_DEF

FREE_OBJS = freesubs.o freeout.o messubs.o memsubs.o arraysub.o \
	liste.o filsubs.o \
	heap.o timesubs.o bump.o randsubs.o call.o menu.o dict.o \
	helpsubs.o texthelp.o

###########################################################
##  Compiler and library options
## CC, LIBS, NAME are defined in $(ACEDB_MACHINE)_DEF
##

IDIR = -I. -I./wh
# Do not use -I/usr/include
# it prevents gcc from picking up its own includes
# (cc goes to /usr/include anyway)

## to undefine any rubbish
CCFLAGS =
GCFLAGS =

## Different platforms use CC or COMPILE.c
#  (USEROPTS - see comments at top of file)
#
CC =        $(COMPILER) $(USEROPTS) $(IDIR) -D$(NAME) -c
COMPILE.c = $(COMPILER) $(USEROPTS) $(IDIR) -D$(NAME) -c

###########################################################
## make targets.
##
##
.KEEP_STATE: 

# "all" should always be the first target so that it is the default make action.
all : libaceperl.a

clean:
	\rm -f *.o *.a core $(RPCGEN_PRODUCTS)

depend:
	makedepend $(IDIR) *.c

################## libraries #########################

libaceperl.a : $(FREE_OBJS) aceclientlib.o rpcace_clnt.o rpcace_xdr.o
	ar $(AR_OPTIONS) $@ $?
	if ( $(RANLIB_NEEDED) ) then ranlib $@; fi

libfree.a : $(FREE_OBJS)
	ar $(AR_OPTIONS) libfree.a $?
	if ( $(RANLIB_NEEDED) ) then ranlib libfree.a; fi

#########################################
#### public C interface: libace #########
#########################################

# 
# aceversion.c is recompiled & rearchived every time one of the
# other libace objects is recompiled. Hence aceversion.c enables
# us to record the link date of the library along with the ACEDB
# version.
# (this is not quite true at the moment because of the graphic/
# non-graphic split in libace, but this will go away)
#
aceversion.o: $(GENERIC_ACE_OBJS) $(GENERIC_ACE_NONGRAPH_OBJS) $(GENERIC_ACE_GRAPH_OBJS)

LIBACE_OBJS = $(GENERIC_ACE_OBJS) $(GENERIC_ACE_NONGRAPH_OBJS) aceversion.o

libace.a :  $(LIBACE_OBJS)
	ar $(AR_OPTIONS) libace.a $?
	if ( $(RANLIB_NEEDED) ) then ranlib libace.a; fi

######################################################
#### RPC server/client ACEDB programs ################
######################################################

RPCGEN_PRODUCTS = rpcace.h rpcace_xdr.c rpcace_clnt.c rpcace_svc.c

$(RPCGEN_PRODUCTS): rpcace.x
	rpcgen $(RPCGEN_FLAGS) rpcace.x

rpcace_sp.o: rpcace_sp.c rpcace_svc.c

aceclientlib.o: aceclientlib.c rpcace.h
	$(CC) -c $<

RPC_CLIENT_OBJS = aceclientlib.o rpcace_clnt.o rpcace_xdr.o
RPC_SERVER_OBJS = rpcace_sp.o  rpcace_xdr.o 
NET_CLIENT_OBJS = aceclientlib.o rpcace_clnt.o rpcace_xdr.o
RPC_X_CLIENT_OBJS = xclient.o aceclientlib.o rpcace_clnt.o rpcace_xdr.o

libacecl.a : aceclientlib.o rpcace_clnt.o rpcace_xdr.o
	ar $(AR_OPTIONS) libacecl.a $?
	if ( $(RANLIB_NEEDED) ) then ranlib libacecl.a; fi

###########################################################
########### end of the acedb truemake file ################
###########################################################
AcePerl-1.92/acelib/randsubs.c0000644000175000017500000000421707565000306015547 0ustar  lsteinlstein/*  File: randsubs.c
 *  Author: Jean Thierry-Mieg (mieg@mrc-lmb.cam.ac.uk)
 *  Copyright (C) J Thierry-Mieg and R Durbin, 1992
 *-------------------------------------------------------------------
 * This file is part of the ACEDB genome database package, written by
 * 	Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr
 *
 * Description:
 * Exported functions:
 * HISTORY:
 * Last edited: Dec  4 15:06 1998 (fw)
 * Created: Mon Jun 15 14:44:56 1992 (mieg)
 *-------------------------------------------------------------------
 */

 /* $Id: randsubs.c,v 1.1 2002/11/14 20:00:06 lstein Exp $ */

#ifdef ALPHA
int random(void);		/* in libc.a */
#endif /* ALPHA */

static int xrand = 18721 ;
static int yrand = 37264 ;    /* original value 67571 */
static int zrand = 28737 ;

/*******************************/

double randfloat (void)

 {double x ;

  xrand = 171*xrand % 30269;
  yrand = 172*yrand % 30307;
  zrand = 170*zrand % 30323;
  x = xrand/30269.0 + yrand/30307.0 + zrand/30323.0;
  return (x-(int)x);
 }

/*******************************/

#ifdef ALPHA
int randint (void)
{   
   return random() ;
}
#else
int randint (void)

 {xrand = 171*xrand % 30269;
  yrand = 172*yrand % 30307;
  zrand = 170*zrand % 30323;
  return (zrand) ;
 }
#endif
/*******************************/

double randgauss (void)

 {double sum ;
static double fac = 3.0/90899.0 ;

  xrand = 171*xrand % 30269;
  yrand = 172*yrand % 30307;
  zrand = 170*zrand % 30323;
  sum = xrand + yrand + zrand ;
  xrand = 171*xrand % 30269;
  yrand = 172*yrand % 30307;
  zrand = 170*zrand % 30323;
  sum += xrand + yrand + zrand ;
  xrand = 171*xrand % 30269;
  yrand = 172*yrand % 30307;
  zrand = 170*zrand % 30323;
  sum += xrand + yrand + zrand ;
  xrand = 171*xrand % 30269;
  yrand = 172*yrand % 30307;
  zrand = 170*zrand % 30323;
  sum += xrand + yrand + zrand ;
  return (sum*fac - 6.0) ;
 }

/*******************************/

void randsave (int *arr)

 {arr[0] = xrand ;
  arr[1] = yrand ;
  arr[2] = zrand ;
 }

/*********************************/

void randrestore (int *arr)

 {xrand = arr[0] ;
  yrand = arr[1] ;
  zrand = arr[2] ;
 }
AcePerl-1.92/acelib/texthelp.c0000644000175000017500000003410607565000306015563 0ustar  lsteinlstein/*  File: texthelp.c
 *  Author: Friedemann Wobus (fw@sanger.ac.uk)
 *          and contributions from Darren Platt (daz@sanger.ac.uk)
 *-------------------------------------------------------------------
 * This file is part of the ACEDB genome database package, written by
 * 	Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr
 *
 * Description:
     contains contains the code to display an HTML page as plain text
     Basic formatting is observed, but images and links are stripped.

 * Exported functions:
 **      helpPrint(char *helpFilename);
 * HISTORY:
 * Last edited: Dec  4 14:33 1998 (fw)
 * * Oct  8 16:01 1998 (fw): removed the declaration of 
			helpOn and help for #define MACINTOSH
 * * Aug 20 16:10 1998 (rd): removed refernces to old help-system
 * * Aug 18 17:17 1998 (fw): help-system split into 
		w1/helpsubs.c  (helpDir, HTML stuff etc).
		w1/texthelp.c  (non-graphical help for tace)
		w2/graphhelp.c (graphical help for xace,image etc.)
 * ----------------------------------------------------------------------
 * ---- major rework, these revision don't necessarily 
 * ---- affect code still left in this file
 * ----------------------------------------------------------------------
 * * May  2 01:07 1996 (rd): new implementation of 
                       helpMakeIndex() using filDirectory()
 * * May  2 18:24 1996 (mieg):
         fall back on oldhelp
         callMosaic if (http:)
         use freeout for server
         jaime's file name rotation
         remaining problem: help topic in tace should be case-insensitive
 * * May  1 18:24 1996 (fw): fixed freePage() to avoid mem leaks
 * * Apr 30 16:18 1996 (fw): fixed #ifdef NON_GRAPHICs for tace
 * * Apr 30 16:18 1996 (fw): added image dictionary
 * * Apr 29 12:37 1996 (fw): added handling of 
       lists
 * * Apr 25 16:27 1996 (fw): added  tag
 * * Apr 22 17:43 1996 (fw): changed help system to HTML browser
 * Created: Thu Feb 20 14:49:50 1992 (mieg)
 *-------------------------------------------------------------------
 */

/* $Id: texthelp.c,v 1.1 2002/11/14 20:00:06 lstein Exp $ */

#ifndef MACINTOSH
/********************************************************************/
#include "help_.h"
#include "freeout.h"
/********************************************************************/
static void htmlPagePrint (HtmlPage *page);
static void printTextSection (HtmlNode *node);

/********************************************************************/
static char buf[10000] ;	/* text-buffer for wordwrapping */

/********************************************************************/

static float xPos ;
static int indent ;
static int WINX ;


/* dumps out help-page without images and markups */
UTIL_FUNC_DEF BOOL helpPrint (char *helpFilename)
/* returns TRUE if a help page could successfully be displayed
   for the given subject, returns FALSE if no such page found */
{
  HtmlPage *page ;
  Array dirList;
  char *cp;
  int i,n,x;

 if ((page = htmlPageCreate (helpFilename)))
   {
     /* found a page */
     htmlPagePrint (page);
     
     htmlPageDestroy (page);

     return TRUE;
   }

  if (!helpFilename)
    freeOut ("Help subject not found\n");
  else
    freeOut ("Help subject is ambiguous\n");

  freeOut ("Try:\n  help\n");
      
  /* now show a list of possible files */
  if(!(dirList = filDirectoryCreate
       (helpGetDir(), HELP_FILE_EXTENSION, "r")) )
    {
      messout ("Can't open help directory %s\n"
	       "(%s)",
	       helpGetDir(), messSysErrorText()) ;
      return FALSE ;
    }
  
  for (i = 0, x = 0 ; i < arrayMax(dirList) ; i++)
    {
      cp = arr(dirList,i,char*) ;
      if (!cp || !*cp || !strlen(cp))
	continue ;
      if (helpFilename)
	{
	  if (strncasecmp(filGetFilename(helpFilename),cp,
			  strlen(filGetFilename(helpFilename))) != 0)
	    continue;
	}

      n = strlen(cp) ;
      if (n > 5 && !strcmp("."HELP_FILE_EXTENSION,cp + n - 5))
	*(cp + n - 5) = 0 ; 

      x += n + 1 ;
      if (x > 50) { x = n + 1 ; freeOut("\n") ;}
      freeOutf("%s  ", cp) ;
    }
  freeOut("\n") ;

  filDirectoryDestroy (dirList);

  return FALSE;
} /* helpPrint */


/************************************************************/
/* counter-part to graphWebBrowser(), which remote-controls 
   netscape using the -remote command line option. Useful
   for textual applications running in an X11 environment,
   where x-apps can be called from within the application,
   but the Xtoolkit (used to drive netscape via X-atoms)
   shouldn't be linked in, because it is a textual app. */
/************************************************************/
UTIL_FUNC_DEF BOOL  helpWebBrowser(char *link)
{
  /* currently impossible, because it is hard to find out whether
     a netscape process is already running.
     Stupidly enough 'netscape -remote...' doesn't exit
     with code 1, if it can't connect to an existing process
*/
  return FALSE;
} /* helpWebBrowser */





/************************************************************/
/******************                   ***********************/
/****************** static functions  ***********************/
/******************                   ***********************/
/************************************************************/


static void htmlPagePrint (HtmlPage *page)
{
  /* init screen-position parameters */

  WINX = 80 ;
  indent = 2 ;
  xPos = indent ;

  /* start recursivle printing nodes */
  printTextSection (page->root) ;

  return;
} /* htmlPagePrint */
/************************************************************/


static void newTextLine (void)
{
  int i ;
  
/*  if (xPos != indent)*/
    {
      freeOut("\n") ;
      for (i = 0; i < indent; ++i) freeOut (" ") ;
      xPos = indent ;
    }
} /* newLine */
/************************************************************/

static void blankTextLine (void)
{
  int i ;

  freeOut("\n") ;
  for (i = 0; i < indent; ++i) freeOut (" ") ;
  xPos = indent ;

  newTextLine () ;
} /* newLine */
/************************************************************/

static void printTextSection (HtmlNode *node)
/* part specific to the text-help system, which uses freeOut
   to print arsed HTML as plain text */
{
  int i, len ;
  char *cp, *start ;
  static BOOL 
    MODE_PREFORMAT=FALSE, 
    MODE_HREF=FALSE,
    MODE_HEADER=FALSE, 
    FOUND_NOBULLET_IN_LIST_NOINDENT=FALSE ;
  static int itemNumber ;
  static char *currentLink ;

  switch (node->type)
    {
    case HTML_SECTION:
      printTextSection (node->left) ;
      if (node->right) printTextSection (node->right) ;
      break ;
    case HTML_COMMENT:
      /* do nothing */
      break ;
    case HTML_DOC:
    case HTML_HEAD:
    case HTML_BODY:
      if (node->left) printTextSection (node->left) ;
      break ;
    case HTML_TITLE:
      for (i = 0; i < strlen(node->text)+4; ++i)
	freeOutf ("*") ;
      freeOutf ("\n* %s *\n", node->text) ;
      for (i = 0; i < strlen(node->text)+4; ++i)
	freeOutf ("*") ;
      blankTextLine() ;
      break ;
    case HTML_HEADER:
      {
	MODE_HEADER = TRUE ;

	indent = node->hlevel*2 ;

	blankTextLine () ;
	
	/* check, in case some bozo has done a thing like 
       */
	if (node->left) printTextSection (node->left) ; 

	freeOutf ("\n") ;
	for (i = 0; i < xPos; ++i)
	  {
	    if (i < indent) freeOutf (" ") ;
	    else  freeOutf ("*") ;
	  }

	blankTextLine () ;
	
	MODE_HEADER = FALSE ;
      }
      break ;

    case HTML_LIST:
      if (node->lstyle == HTML_LIST_BULLET || 
	  node->lstyle == HTML_LIST_NUMBER)
	indent += 2 ;
      else if (node->lstyle == HTML_LIST_NOINDENT)
	indent -= 2 ;
      newTextLine () ;

      itemNumber = 0 ;

      /* a list might not have a leftnode (a list item) */
      if (node->left) printTextSection (node->left) ;

      if (node->lstyle == HTML_LIST_BULLET || 
	  node->lstyle == HTML_LIST_NUMBER)
	indent -= 2 ;
      else if (node->lstyle == HTML_LIST_NOINDENT)
	indent += 2 ;
      if (node->lstyle == HTML_LIST_NOINDENT &&
	  FOUND_NOBULLET_IN_LIST_NOINDENT)
	{
	  indent -= 4 ;
	  FOUND_NOBULLET_IN_LIST_NOINDENT = FALSE ;
	}

      blankTextLine () ;
      break ;

    case HTML_LISTITEM:
      ++itemNumber ;
      if (node->left)
	{
	  if (node->lstyle == HTML_LIST_NOINDENT_NOBULLET)
	    {
	      /* if we are in a 
       list and went to indentation
		 because of a 
       item, a 
       item brings back
		 the old indent-level (noindent for 
      's) */
	      if (FOUND_NOBULLET_IN_LIST_NOINDENT)
		{
		  indent -= 6 ;
		  FOUND_NOBULLET_IN_LIST_NOINDENT = FALSE ;
		  newTextLine () ;
		  freeOutf ("  ") ;
		}
	    }
	  else
	    newTextLine () ;
	  if (node->lstyle == HTML_LIST_BULLET ||
	      node->lstyle == HTML_LIST_NOINDENT)
	    {
	      freeOutf ("* ") ;
	      indent += 2 ;
	      xPos  = indent ;
	    }
	  else if (node->lstyle == HTML_LIST_NUMBER)
	    {
	      freeOutf ("%d. ", itemNumber) ;
	      indent += strlen(messprintf ("%d. ", itemNumber)) ;
	      xPos  = indent ;
	    }
	  else if (node->lstyle == HTML_LIST_NOBULLET)
	    {
	      /* part of a 
       noindented list, but a 
      
		 item becomes indented, but no bullet */
	      /* if we come across the first NO_BULLET item, in
		 a LIST_NOINDENT, the LIST becomes indented */
	      if (!FOUND_NOBULLET_IN_LIST_NOINDENT)
		{
		  indent += 6 ;
		  xPos = indent ;
		  freeOutf ("      ") ;
		  fflush (stdout) ;

		  FOUND_NOBULLET_IN_LIST_NOINDENT = TRUE ;
		}
	    }
	  printTextSection (node->left) ;
	}
      if (node->lstyle == HTML_LIST_BULLET ||
	  node->lstyle == HTML_LIST_NOINDENT)
	{
	  indent -= 2 ;
	}
      else if (node->lstyle == HTML_LIST_NUMBER)
	{
	  indent -= strlen(messprintf ("%d. ", itemNumber)) ;
	}
      else if (node->lstyle == HTML_LIST_NOBULLET)
	{
	  if (!FOUND_NOBULLET_IN_LIST_NOINDENT)
	    indent -= 6 ;
	}
      
      if (node->right)
	{
	  printTextSection (node->right) ;
	}
      break ;

    case HTML_HREF:
      if (node->link)
	{
	  MODE_HREF = TRUE ;
	  currentLink = node->link ;
	}
      /* we have to check for leftnode, in case we have a thing
	 like . The HREF-node doesn't have a TEXT
	 node attached, and it would crash otherwise */
      if (node->left)printTextSection (node->left) ; 

      if (node->link)
	{
	  MODE_HREF = FALSE ;
	  currentLink = 0 ;
	}
      break ;
    case HTML_TEXT:
      cp = node->text ;
      if (!MODE_PREFORMAT)
	stripSpaces (node->text) ;
      /* for MODE_PREFORMAT keeps all controls chars */

      while (*cp)
	{
	  len = 0 ;
	  start = cp ;
	  
	  if (!MODE_PREFORMAT)
	    {
	      while (*cp && !isspace((int)*cp)) { ++(cp) ; ++len ; }
	      if (*cp) ++cp ;	/* skip whitespace */
	    }
	  else
	    {
	      while (*cp && *cp != '\n') { ++(cp) ; ++len ; }
	      if (*cp) 
		{
		  ++cp ;	/* skip RETURN */
		  ++len ;	/* so we copy the RETURN into buf */
		}
	    }

	  memset (buf, 0, 10000) ;
	  strncpy (buf, start, len) ;
	  buf[len] = 0 ;

	  /* linewrapping of words/lines longer than WINX */
	  if (strlen(buf) > WINX)
	    {
	      cp = start + (int)(WINX) ;
	      buf[(int)WINX] = 0 ;
	      len = (int)WINX ;
	    }
	  
	  /* word wrapping if not in preformatting mode */
	  if (!MODE_PREFORMAT)
	    {
	      if (xPos != indent)  /* not at start of line ... */
		{
		  xPos += 1 ;	   /* ... one space before the word */
		  freeOutf (" ") ;
		  fflush (stdout) ;
		}
	      if (xPos + len > WINX)
		{
		  newTextLine () ;
		}
	      freeOutf ("%s", buf) ;
	      xPos += strlen(buf) ; /* place xPos at the end of word */
	    }
	  else if (MODE_PREFORMAT)
	    {
	      int oldpos, stringpos, screenpos, ii ;
	      i = 0 ;

	      /* replace TABs with appropriate number of spaces */
	      while (buf[i])
		{
		  if (buf[i] == '\t')
		    {
		      /* oldpos is the position, that this TAB char
			 would go on the screen without TABifying
			 NOTE: xPos is always at least "indent" 
			 (to leave a left margin) */
		      oldpos = (xPos - indent) + i ;

		       /* screenpos is the position of the TAB char 
			  after inserting spaces
			  NOTE: the TAB itself will be
			  overwritten by one space */
		      screenpos = (((oldpos/8)+1)*8) - 1 ;

		       /* stringpos is where the TAB should go
			  in the string, where it'll turn into a space
			  at that position */
		      stringpos = screenpos - (xPos-indent) ;

		      /* shift all text from current position "i"
			 onwards */
		      for (ii = strlen(buf)-1; ii >= i ; --ii)
			buf[ii+(stringpos-i)] = buf[ii] ;

		      /* fill gap with spaces and also overwrite TAB
			 with a space */
		      for (ii = i; ii <= stringpos; ++ii)
			buf[ii] = ' ' ;

		      i = stringpos ;
		    }
		  ++i ;
		}

      /* don't use len, it might have changed when inserting spaces */
	      if (buf[strlen(buf)-1] == '\n')
		{
		  buf[strlen(buf)-1] = 0 ;
		  freeOutf ("%s", buf) ;
		  xPos += strlen(buf) ;
		  newTextLine ();	/* for the '\n' */
		}
	      else
		{
		  freeOutf ("%s", buf) ;
		  xPos += strlen(buf) ;
		}
	    }
	}
      break ;
    case HTML_GIFIMAGE:
      {
	freeOutf (" [IMAGE] ") ;
	xPos += 9 ;
      }
      break ;
    case HTML_NOIMAGE:
      break ;
    case HTML_RULER:
      {
	newTextLine () ;
	for (i = indent; i < WINX; ++i)
	  freeOutf ("-") ;
	xPos = WINX ;
	newTextLine () ;
      }
      break ;
    case HTML_PARAGRAPH:
      blankTextLine () ;
      break ;
    case HTML_LINEBREAK:
      newTextLine () ;
      break ;
    case HTML_BOLD_STYLE:
    case HTML_STRONG_STYLE:
      {
	if (node->left)	printTextSection (node->left) ;
      }
      break ;
    case HTML_ITALIC_STYLE:
      {
	if (node->left) printTextSection (node->left) ;
      }
      break ;
    case HTML_CODE_STYLE:
      {
	if (node->left)	printTextSection (node->left) ;
      }
      break ;
    case HTML_STARTBLOCKQUOTE:
      newTextLine () ;
      indent += 3 ;
      xPos = indent ;
      for (i = 0; i < indent; ++i) freeOutf (" ") ;
      fflush (stdout) ;
      break ;
    case HTML_ENDBLOCKQUOTE:
      indent -= 3 ;
      blankTextLine () ;
      break ;
    case HTML_STARTPREFORMAT:
      MODE_PREFORMAT = TRUE ;
      newTextLine () ;
      break ;
    case HTML_ENDPREFORMAT:
      MODE_PREFORMAT = FALSE ;
      break ;
    case HTML_UNKNOWN:
      break;			/* compiler happiness */
    }
} /* printTextSection */
/************************************************************/

#endif /* !def MACINTOSH */
 
 
 
 
AcePerl-1.92/acelib/wmake/0000755000175000017500000000000011106333223014653 5ustar  lsteinlsteinAcePerl-1.92/acelib/wmake/_DEF0000644000175000017500000000000007121260303015321 0ustar  lsteinlsteinAcePerl-1.92/acelib/wmake/IRIX_DEF0000644000175000017500000000202707565000306016037 0ustar  lsteinlstein# $Id: IRIX_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the SGI Silicon Graphics Irix5.2 ################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SGI 
COMPILER = cc -g -n32 DNO_LEFT_CASTING -DACEDB4
LINKER = cc -g

LIBS = -lm
RANLIB_NEEDED = false

.c.o:
	$(CC) $*.c

#################################################################
#################################################################
 
AcePerl-1.92/acelib/wmake/POSIX_4_DEF0000644000175000017500000000213107565000306016405 0ustar  lsteinlstein# $Id: POSIX_4_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### ported to Posix by Ken Letovski    ##############
############### wmake/POSIX_DEF    Feb-2-1993      ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
###########    for the PC-386, running POSIX   ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = POSIX
COMPILER = cc -DACEDB4
LINKER = cc

LIBS = -lm

#################################################################
#################################################################

AcePerl-1.92/acelib/wmake/LINUX_MAC_4_DEF0000644000175000017500000000231007565000306017061 0ustar  lsteinlstein# $Id: LINUX_MAC_4_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### ported to Linux by Ken Letovski    ##############
############### wmake/LINUX_DEF    Feb-2-1993      ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
###########    for the PC-386, running LINUX   ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = LINUX
COMPILER = gcc -g -fwritable-strings -DACEDB4 -I. -DLINUX_MAC
LINKER = gcc -g

LIBS = -lm
Xt_LIBS = -L/usr/X11R6/lib -lXaw -lXt -lXmu -lXext -lX11

#################################################################
#################################################################
 
 
 
 
AcePerl-1.92/acelib/wmake/LINUX_4_DEF0000644000175000017500000000234410612204510016376 0ustar  lsteinlstein# $Id: LINUX_4_DEF,v 1.2 2007/04/20 18:41:12 lstein Exp $ #

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### ported to Linux by Ken Letovski    ##############
############### wmake/LINUX_DEF    Feb-2-1993      ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
###########    for the PC-386, running LINUX   ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = LINUX
COMPILER = gcc -g -Wall -O2 -DACEDB4
LINKER = gcc -g
USEROPTS=-fPIC

LIBS = -lm
Xt_LIBS = -L/usr/X11R6/lib -lXaw -lXt -lXmu -lXext -lX11
LEX_LIBS = 

RPCGEN_FLAGS = -b -I -K -1

#################################################################
#################################################################
 
 
 
 
AcePerl-1.92/acelib/wmake/ALPHA_4_GCC_DEF0000644000175000017500000000215307565000306017010 0ustar  lsteinlstein# SCCS: $Id: ALPHA_4_GCC_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
####### for the DEC-Alpha running Digital UNIX V4.0 #############
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = ALPHA
COMPILER = gcc -g -DACEDB4 -ansi -pedantic -Wall -Wnested-externs -ieee_with_inexact

LINKER = gcc -g

# On DEC the library does not need to be ranlib'd
RANLIB_NEEDED = false

LIBS = -lm 

#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/SOLARIS_4_NEW_DEF0000644000175000017500000000230707565000306017335 0ustar  lsteinlstein# $Id: SOLARIS_4_NEW_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $ 

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/NEW_SUN_CC_DEF  July-15-1993 ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the Solaris OS                 ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SOLARIS
COMPILER = gcc -g -I/usr/openwin/include -DNO_LEFT_CASTING -DACEDB4 -DNEW_MODELS -I.
LINKER = gcc -g

# -DWCS causes a problem, class versus Xlib.h
LIBS = -lm -lsocket -lnsl
RANLIB_NEEDED = false
AR_OPTIONS = ru

#################################################################
#################################################################

 
AcePerl-1.92/acelib/wmake/SGI_DEF0000644000175000017500000000213007565000306015701 0ustar  lsteinlstein# $Id: SGI_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the SGI Silicon Graphics Generic ################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

# Note:
# the native cc is recommended over gcc on Silicon Graphics
#
NAME = SGI 
COMPILER = cc -g -DNO_LEFT_CASTING -DACEDB4
LINKER = cc -g

LIBS = -lm
RANLIB_NEEDED = false

.c.o:
	$(CC) $*.c

#################################################################
#################################################################
 
AcePerl-1.92/acelib/wmake/LINUX_DEF0000644000175000017500000000234210612204510016151 0ustar  lsteinlstein# $Id: LINUX_DEF,v 1.2 2007/04/20 18:41:12 lstein Exp $ #

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### ported to Linux by Ken Letovski    ##############
############### wmake/LINUX_DEF    Feb-2-1993      ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
###########    for the PC-386, running LINUX   ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = LINUX
COMPILER = gcc -g -Wall -O2 -DACEDB4
LINKER = gcc -g
USEROPTS=-fPIC

LIBS = -lm
Xt_LIBS = -L/usr/X11R6/lib -lXaw -lXt -lXmu -lXext -lX11
LEX_LIBS = 

RPCGEN_FLAGS = -b -I -K -1

#################################################################
#################################################################
 
 
 
 
AcePerl-1.92/acelib/wmake/POSIX_4_GCC_DEF0000644000175000017500000000216107565000306017064 0ustar  lsteinlstein# $Id: POSIX_4_GCC_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### ported to Posix by Ken Letovski    ##############
############### wmake/POSIX_DEF    Feb-2-1993      ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
###########    for the PC-386, running POSIX   ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = POSIX
COMPILER = gcc -fwritable-strings -DACEDB4
LINKER = gcc

LIBS = -lm

#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/LINUX_LIBC5_4_DEF0000644000175000017500000000235007565000306017263 0ustar  lsteinlstein# $Id: LINUX_LIBC5_4_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $ #

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### ported to Linux by Ken Letovski    ##############
############### wmake/LINUX_DEF    Feb-2-1993      ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
###########    for the PC-386, running LINUX   ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = LINUX
COMPILER = gcc -g -fwritable-strings -DACEDB4 -I.
LINKER = gcc -g

LIBS = -lm
Xt_LIBS = -L/usr/X11R6/lib -lXaw -lXt -lXmu -lXext -lX11
LEX_LIBS = 

RPCGEN_FLAGS = -b -I -K -1

#################################################################
#################################################################
 
 
 
 
AcePerl-1.92/acelib/wmake/ALPHA_4_NEW_DEF0000644000175000017500000000210607565000306017043 0ustar  lsteinlstein# $Id: ALPHA_4_NEW_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
########### wmake/DEC_ALPHA_DEF    March-18-1993       ##########
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
####### for the DEC-Alpha 3000 model 500 running Unix ###########
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = ALPHA
COMPILER = cc -g -std1 -DACEDB4 -DNEW_MODELS
LINKER = cc

LIBS = -lm 

.c.o:
	$(CC)  $*.c

#################################################################
#################################################################

AcePerl-1.92/acelib/wmake/IBM_4_DEF0000644000175000017500000000217607565000306016123 0ustar  lsteinlstein#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/IBM_DEF    Jan-12-1992       ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
###########  for the IBM work stations         ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
########################################################################
# $Id: IBM_4_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

NAME = IBM

COMPILER = xlc -DACEDB4 -D_ALL_SOURCE
LINKER = xlc

LIBS = -lm 

.c.o:
	$(CC) -c $*.c

#  -D_ALL_SOURCE: flag needed by xlc compiler in /usr/include
#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/SOLARIS_DEF0000644000175000017500000000245107121260303016372 0ustar  lsteinlstein# @(#)SOLARIS_4_NEW_DEF	1.1  4/11/95 

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/SOLARIS_4_OPT  April-15-1995 ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the Solaris OS                 ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SOLARIS
COMPILER = cc -O2 -I/usr/openwin/include -DNO_LEFT_CASTING -DACEDB4
LINKER = cc -L/usr/openwin/lib -R/usr/openwin/lib

# -DWCS causes a problem, class versus Xlib.h
LIBS = -lm  -lnsl -lsocket -lmalloc
RANLIB_NEEDED = false
AR_OPTIONS = ru
RPCGEN_FLAGS = -b -I -K -1

# -DWCS causes a problem, class versus Xlib.h
# nsl is the rpc library 


#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/HPUX_DEF0000644000175000017500000000217307565000306016052 0ustar  lsteinlstein# $Id: HPUX_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $


#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
########### wmake/DEC_ALPHA_DEF    March-18-1993       ##########
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
####### for the DEC-Alpha 3000 model 500 running Unix ###########
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = HP
COMPILER = gcc -g -DNO_LEFT_CASTING -DACEDB4 -I/usr/include/X11R5 -I/usr/local/include/MIT/X11R5/include
LINKER = gcc -g -L/usr/lib/X11R5

LIBS = -lm 

#################################################################
#################################################################
 
AcePerl-1.92/acelib/wmake/ALPHA_G3_DEF0000644000175000017500000000207007565000306016440 0ustar  lsteinlstein# $Id: ALPHA_G3_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $ #

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
########### wmake/DEC_ALPHA_DEF    March-18-1993       ##########
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
####### for the DEC-Alpha 3000 model 500 running Unix ###########
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = ALPHA
COMPILER = gcc -g -DACEDB3
LINKER = gcc -g

LIBS = -lm 

.c.o:
	$(CC) -c $*.c

#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/SOLARIS_4_DEF0000644000175000017500000000225007565000306016621 0ustar  lsteinlstein#  $Id: SOLARIS_4_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the Solaris OS                 ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SOLARIS
COMPILER = gcc -g -DNO_LEFT_CASTING -O2 -Wall -I/usr/openwin/include -DACEDB4
LINKER = gcc -g

# -DWCS causes a problem, class versus Xlib.h
LIBS = -lm -lsocket -lnsl
RANLIB_NEEDED = false
AR_OPTIONS = ru
RPCGEN_FLAGS = -b -I -K -1

LEX_LIBS = -ll -lw
#################################################################
#################################################################

 
AcePerl-1.92/acelib/wmake/SGI_4_DEF0000644000175000017500000000213207565000306016126 0ustar  lsteinlstein# $Id: SGI_4_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the SGI Silicon Graphics Generic ################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

# Note:
# the native cc is recommended over gcc on Silicon Graphics
#
NAME = SGI 
COMPILER = cc -g -DNO_LEFT_CASTING -DACEDB4
LINKER = cc -g

LIBS = -lm
RANLIB_NEEDED = false

.c.o:
	$(CC) $*.c

#################################################################
#################################################################
 
AcePerl-1.92/acelib/wmake/SUNOS_DEF0000644000175000017500000000303107565000306016167 0ustar  lsteinlstein#################################################################
#                                                               #
#  $Id: SUNOS_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $
#                                                               #
############### acedb: R.Durbin and J.Thierry-Mieg ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for SUN stations with SunOS 4.1.x ###################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SUN
#COMPILER = gcc -g -O2 -Wreturn-type -Wimplicit -Wunused -Wcomment \
#	-fwritable-strings -DACEDB4 -I/usr/openwin/include
##COMPILER = gcc -g -O2 -Wreturn-type -Wimplicit -Wunused -Wcomment \
##	-fwritable-strings -DACEDB4 -I/usr/openwin.old/include


## NOMEMMOVE will define memmove on SunOS (for staden package)
COMPILER = gcc -g -O2 -Wall -fwritable-strings -DNOMEMMOVE -DACEDB4

LINKER = gcc -g -static 

#LIBS = -lm -L/usr/lib -L/usr/openwin.old/lib -L/usr/X11R6.3/lib
LIBS = -lm -L/usr/lib


#################################################################
#################################################################
 
AcePerl-1.92/acelib/wmake/SOLARIS_4_OPT_DEF0000644000175000017500000000245207121260303017340 0ustar  lsteinlstein# @(#)SOLARIS_4_NEW_DEF	1.1  4/11/95 

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/SOLARIS_4_OPT  April-15-1995 ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the Solaris OS                 ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SOLARIS
COMPILER = cc -xO4 -I/usr/openwin/include -DNO_LEFT_CASTING -DACEDB4
LINKER = cc -L/usr/openwin/lib -R/usr/openwin/lib

# -DWCS causes a problem, class versus Xlib.h
LIBS = -lm  -lnsl -lsocket -lmalloc
RANLIB_NEEDED = false
AR_OPTIONS = ru
RPCGEN_FLAGS = -b -I -K -1

# -DWCS causes a problem, class versus Xlib.h
# nsl is the rpc library 


#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/INTEL_SOLARIS_4_OPT_DEF0000644000175000017500000000246207324653356020317 0ustar  lsteinlstein# @(#)INTEL_SOLARIS_4_DEF	1.1  4/11/95 

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/SOLARIS_4_OPT  April-15-1995 ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the Solaris OS                 ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = INTEL_SOLARIS
COMPILER = cc -xO4 -I/usr/openwin/include -DNO_LEFT_CASTING -DACEDB4
LINKER = cc -L/usr/openwin/lib -R/usr/openwin/lib

# -DWCS causes a problem, class versus Xlib.h
LIBS = -lm  -lnsl -lsocket -lmalloc
RANLIB_NEEDED = false
AR_OPTIONS = ru
RPCGEN_FLAGS = -b -I -K -1

# -DWCS causes a problem, class versus Xlib.h
# nsl is the rpc library 


#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/ALPHA_4_OSFV3_DEF0000644000175000017500000000212307565000306017251 0ustar  lsteinlstein# $Id: ALPHA_4_OSFV3_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
########### wmake/ALPHA_4_OSFV3_DEF    fw Oct-08-1998  ##########
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
####### for the DEC-Alpha running OSF1 Version 3.2    ###########
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = ALPHA
COMPILER = cc -g -std1 -ieee_with_inexact -DACEDB4
LINKER = cc -g

LIBS = -lm 

.c.o:
	$(CC)  $*.c

#################################################################
#################################################################

 
AcePerl-1.92/acelib/wmake/DEC_OSF_DEF0000644000175000017500000000227507565000306016373 0ustar  lsteinlstein# $Id: DEC_OSF_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
########### wmake/DEC_ALPHA_DEF    March-18-1993       ##########
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
####### for the DEC-Alpha 3000 model 500 running Unix ###########
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = ALPHA
COMPILER = cc -O -Olimit 3000 -std1 -DACEDB4 -ieee_with_inexact

# rd 970131 - I am told that -O does the most optimisation possible
# there may be levels above -O2

LINKER = cc

LIBS = -lm 

.c.o:
	$(CC)  $*.c

#################################################################
#################################################################

 
AcePerl-1.92/acelib/wmake/SUN_4_NEW_DEF0000644000175000017500000000216707565000306016672 0ustar  lsteinlstein#  $Id: SUN_4_NEW_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/SUN_DEF    Jan-12-1992       ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the SUN3/80 and sparc stations ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SUN
COMPILER = gcc -g -Wreturn-type -Wimplicit -Wunused -Wcomment \
	-fwritable-strings -DACEDB4 -DNEW_MODELS
LINKER = gcc -g -static

LIBS = -lm


#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/ALPHA_4_OPT_DEF0000644000175000017500000000230107565000306017051 0ustar  lsteinlstein# $Id: ALPHA_4_OPT_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
########### wmake/DEC_ALPHA_DEF    March-18-1993       ##########
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
####### for the DEC-Alpha 3000 model 500 running Unix ###########
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = ALPHA
COMPILER = cc -O -Olimit 3000 -std1 -DACEDB4 -ieee_with_inexact

# rd 970131 - I am told that -O does the most optimisation possible
# there may be levels above -O2

LINKER = cc

LIBS = -lm 

.c.o:
	$(CC)  $*.c

#################################################################
#################################################################

 
AcePerl-1.92/acelib/wmake/SUN_4_DEF0000644000175000017500000000303107565000306016150 0ustar  lsteinlstein#################################################################
#                                                               #
#  $Id: SUN_4_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $
#                                                               #
############### acedb: R.Durbin and J.Thierry-Mieg ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for SUN stations with SunOS 4.1.x ###################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SUN
#COMPILER = gcc -g -O2 -Wreturn-type -Wimplicit -Wunused -Wcomment \
#	-fwritable-strings -DACEDB4 -I/usr/openwin/include
##COMPILER = gcc -g -O2 -Wreturn-type -Wimplicit -Wunused -Wcomment \
##	-fwritable-strings -DACEDB4 -I/usr/openwin.old/include


## NOMEMMOVE will define memmove on SunOS (for staden package)
COMPILER = gcc -g -O2 -Wall -fwritable-strings -DNOMEMMOVE -DACEDB4

LINKER = gcc -g -static 

#LIBS = -lm -L/usr/lib -L/usr/openwin.old/lib -L/usr/X11R6.3/lib
LIBS = -lm -L/usr/lib


#################################################################
#################################################################
 
AcePerl-1.92/acelib/wmake/HP_4_GCC_DEF0000644000175000017500000000217707565000306016500 0ustar  lsteinlstein# $Id: HP_4_GCC_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $


#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
########### wmake/DEC_ALPHA_DEF    March-18-1993       ##########
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
####### for the DEC-Alpha 3000 model 500 running Unix ###########
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = HP
COMPILER = gcc -g -DNO_LEFT_CASTING -DACEDB4 -I/usr/include/X11R5 -I/usr/local/include/MIT/X11R5/include
LINKER = gcc -g -L/usr/lib/X11R5

LIBS = -lm 

#################################################################
#################################################################
 
AcePerl-1.92/acelib/wmake/SGI_4_GCC_DEF0000644000175000017500000000204307565000306016603 0ustar  lsteinlstein# $Id: SGI_4_GCC_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $
 
#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the SGI Silicon Graphics & gcc ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SGI 
COMPILER = gcc -g -DNO_LEFT_CASTING -Wall -DACEDB4
LINKER = gcc -g

LIBS = -lm 
RANLIB_NEEDED = false

.c.o:
	$(CC) -c $*.c

#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/SGI_4_PURE_DEF0000644000175000017500000000233407565000306016765 0ustar  lsteinlstein# $Id: SGI_4_PURE_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the Silicon Graphics using purify  ##############
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

# Note:
# the native cc is recommended over gcc on Silicon Graphics
#
NAME = SGI 
COMPILER = cc -g -DNO_LEFT_CASTING -DACEDB4
LINKER = purify -chain-length="10" cc -g

#different c++ compiler for purify compiling
CCC = g++
CCCLINK = purify g++
CCCFLAGS = -g3 -Wall

LIBS = -lm 
RANLIB_NEEDED = false

.c.o:
	$(CC) $*.c

#################################################################
#################################################################
 
AcePerl-1.92/acelib/wmake/ALPHA_4_DEF0000644000175000017500000000222607565000306016335 0ustar  lsteinlstein# $Id: ALPHA_4_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
########### wmake/DEC_ALPHA_DEF    March-18-1993       ##########
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
####### for the DEC-Alpha 3000 model 500 running Unix ###########
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = ALPHA
COMPILER = cc -g -std1 -ieee_with_inexact -DACEDB4
LINKER = cc -g

# On DEC the library does not need to be ranlib'd
RANLIB_NEEDED = false

LIBS = -lm 

.c.o:
	$(CC)  $*.c

#################################################################
#################################################################

 
AcePerl-1.92/acelib/wmake/SGI_4_NEW_DEF0000644000175000017500000000247207565000306016646 0ustar  lsteinlstein# $Id: SGI_4_NEW_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/SGI_DEF    Jan-12-1992       ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the SGI Silicon Graphics       ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

## -cckr may be needed for the new SGI compiler 3.10
## -cckr removed -srk 16/5/94

NAME = SGI 
COMPILER = cc -Wf,-XNh2000 -g -DNO_LEFT_CASTING -DACEDB4 -DNEW_MODELS -I.
LINKER = cc -g

LIBS = -lm  -lsun
RANLIB_NEEDED = false

# -lsun is used by the rpc system for ace client/server
# -lc_s is the shared c library on silicon

.c.o:
	$(CC) -c $*.c

#################################################################
#################################################################
 
AcePerl-1.92/acelib/wmake/SGI_4_IRIX5_DEF0000644000175000017500000000203207565000306017045 0ustar  lsteinlstein# $Id: SGI_4_IRIX5_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the SGI Silicon Graphics Irix5.2 ################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SGI 
COMPILER = cc -g -DNO_LEFT_CASTING -DACEDB4
LINKER = cc -g

LIBS = -lm
RANLIB_NEEDED = false

.c.o:
	$(CC) $*.c

#################################################################
#################################################################
 
AcePerl-1.92/acelib/wmake/IRIX4_4_DEF0000644000175000017500000000254707565000306016355 0ustar  lsteinlstein# $Id: IRIX4_4_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/SGI_DEF    Jan-12-1992       ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the SGI Silicon Graphics       ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

## -cckr may be needed for the new SGI compiler 3.10
## -cckr removed -srk 16/5/94

NAME = SGI 
COMPILER = cc -g -DNO_LEFT_CASTING -DACEDB4 -Wf,-XNl4096
# -Wf,-XNl4096 needed to compile big string constant in graphxt.c
LINKER = cc -g

LIBS = -lm  -lsun
RANLIB_NEEDED = false

# -lsun is used by the rpc system for ace client/server
# -lc_s is the shared c library on silicon

.c.o:
	$(CC) -c $*.c

#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/SOLARIS_7_gcc_DEF0000644000175000017500000000247207121260303017437 0ustar  lsteinlstein# @(#)SOLARIS_7_gcc_DEF	1.1  4/11/95 

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/SOLARIS_7_gcc_DEF            ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the Solaris OS                 ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SOLARIS
COMPILER = gcc -O4 -fwritable-strings -I/usr/openwin/include -DACEDB4 -DHASVSPRINTF
LINKER = gcc -L/usr/openwin/lib -R/usr/openwin/lib

# -DWCS causes a problem, class versus Xlib.h
LIBS = -lm  -lnsl -lsocket -lmalloc
RANLIB_NEEDED = false
AR_OPTIONS = ru
RPCGEN_FLAGS = -b -I -K -1

# -DWCS causes a problem, class versus Xlib.h
# nsl is the rpc library 


#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/SOLARIS_GCC_DEF0000644000175000017500000000245307121260303017050 0ustar  lsteinlstein# @(#)SOLARIS_4_NEW_DEF	1.1  4/11/95 

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/SOLARIS_4_OPT  April-15-1995 ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the Solaris OS                 ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SOLARIS
COMPILER = gcc -O2 -I/usr/openwin/include -DNO_LEFT_CASTING -DACEDB4
LINKER = gcc -L/usr/openwin/lib -R/usr/openwin/lib

# -DWCS causes a problem, class versus Xlib.h
LIBS = -lm  -lnsl -lsocket -lmalloc
RANLIB_NEEDED = false
AR_OPTIONS = ru
RPCGEN_FLAGS = -b -I -K -1

# -DWCS causes a problem, class versus Xlib.h
# nsl is the rpc library 


#################################################################
#################################################################
AcePerl-1.92/acelib/wmake/ALPHA_CHRONO_4_DEF0000644000175000017500000000210507565000306017401 0ustar  lsteinlstein# $Id: ALPHA_CHRONO_4_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
########### wmake/DEC_ALPHA_DEF    March-18-1993       ##########
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
####### for the DEC-Alpha 3000 model 500 running Unix ###########
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = ALPHA
COMPILER = cc -g -std1 -DACEDB4 -DCHRONO
LINKER = cc

LIBS = -lm 

.c.o:
	$(CC)  $*.c

#################################################################
#################################################################

AcePerl-1.92/acelib/wmake/SOLARIS_4_RELEASE_DEF0000644000175000017500000000245107565000306017764 0ustar  lsteinlstein#  $Id: SOLARIS_4_RELEASE_DEF,v 1.1 2002/11/14 20:00:06 lstein Exp $

#################################################################
############### acedb: R.Durbin and J.Thierry-Mieg ##############
############### wmake/NEW_SUN_CC_DEF  July-15-1993 ##############
#################################################################

#################################################################
########## Machine dependant compiler modification ##############
########### for the Solaris OS                 ##################
#################################################################
########### This file is included by wmake/truemake #############
######  Edit this file to adapt the ACeDB to a new machine ######
#####   following the explanations given in wmake/truemake  #####
#################################################################

NAME = SOLARIS
COMPILER = gcc -g -O2 -I/usr/openwin/include -DNO_LEFT_CASTING -DACEDB4 -I.
LINKER = gcc -g -Xlinker -R -Xlinker /usr/openwin/lib -L/usr/openwin/lib

# -DWCS causes a problem, class versus Xlib.h
LIBS = -lm -lsocket -lnsl
RANLIB_NEEDED = false
AR_OPTIONS = ru
RPCGEN_FLAGS = -b -I -K -1

LEX_LIBS = -ll -lw
#################################################################
#################################################################

 
AcePerl-1.92/acelib/filsubs.c0000644000175000017500000006333307570224030015377 0ustar  lsteinlstein/*  File: filsubs.c
 *  Author: Jean Thierry-Mieg (mieg@mrc-lmb.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-lmb.cam.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr
 *
 * Description:
 *                   cross platform file system routines
 *              
 * Exported functions:
 * HISTORY:
 * Last edited: Jan  5 16:36 1999 (fw)
 * * Dec  8 10:20 1998 (fw): new function filAge to determine time since
 *              last modification of file
 * * Oct 22 16:17 1998 (edgrif): Replace unsafe strtok with strstr.
 * * Oct 15 11:47 1998 (fw): include messSysErrorText in some messges
 * * Sep 30 09:37 1998 (edgrif): Replaced my strdup with acedb strnew.
 * * Sep  9 14:07 1998 (edgrif): Add filGetFilename routine that will 
 *               return the filename given a pathname 
 *              (NOT the same as the UNIX basename).
 * * DON'T KNOW WHO DID THE BELOW..assume Richard Bruskiewich (edgrif)
 *	-	fix root path detection for default drives (in WIN32)
 * * Oct  8 23:34 1996 (rd)
 *              filDirectory() returns a sorted Array of character 
 *              strings of the names of files, with specified ending 
 *              and spec's, listed in a given directory "dirName";
 *              If !dirName or directory is inaccessible, 
 *              the function returns 0
 * * Jun  6 17:58 1996 (rd)
 * * Mar 24 02:42 1995 (mieg)
 * * Feb 13 16:11 1993 (rd): allow "" endName, and call getwd if !*dname
 * * Sep 14 15:57 1992 (mieg): sorted alphabetically
 * * Sep  4 13:10 1992 (mieg): fixed NULL used improperly when 0 is meant
 * * Jul 20 09:35 1992 (aochi): Add directory names to query file chooser
 * * Jan 11 01:59 1992 (mieg): If file has no ending i suppress the point
 * * Nov 29 19:15 1991 (mieg): If file had no ending, we were losing the
                               last character in dirDraw()
 * Created: Fri Nov 29 19:15:34 1991 (mieg)
 *-------------------------------------------------------------------
 */

/* $Id: filsubs.c,v 1.2 2002/11/24 19:27:20 lstein Exp $	 */

#include "regular.h"
#include "mytime.h"
#include "call.h"		/* for callScript (to mail stuff) */

/********************************************************************/

#include "mydirent.h"

#if !defined(WIN32)
/*           UNIX             */
#include 
#define HOME_DIR_ENVP "HOME"

#define ABSOLUTE_PATH(path) *path == SUBDIR_DELIMITER

#else  /* Utility macros for WIN32 only */

#include  
#include 	   /* for getwcd() and _getdrive() */

/* simple, single letter logical drives assumed here */
static const char *DRIVES = "abcdefghijklmnopqrstuvwxyz";
#define DRIVE_NO(drv) ((drv)-'a'+1)
#define GET_CURRENT_DRIVE *( DRIVES + _getdrive() - 1 )

#define HOME_DIR_ENVP "HOMEPATH"

#include  /* for isalpha() */
#define ABSOLUTE_PATH(path) \
           ( isalpha( (int)*path ) ) && \
           (*(path+1) == DRIVE_DELIMITER) && \
           (*(path+2) == SUBDIR_DELIMITER)
#endif /* WIN32 */

/********************************************************************/

static Stack dirPath = 0 ;

UTIL_FUNC_DEF void filAddDir (char *s)	/* add to dirPath */
{
  char *home ;

  if (!dirPath)
    dirPath = stackCreate (128) ;

  /* if the user directory is specified */
  if (*s == '~' &&
		(home = getenv (HOME_DIR_ENVP))) /* substitute */
    {
#if defined(WIN32) /* in WIN32, need to prefix homepath with home drive*/
      char *drive;
      drive = getenv ("HOMEDRIVE") ;
	  pushText(dirPath, drive) ;
	  catText(dirPath, home) ;
#else
      pushText (dirPath, home) ;
#endif
      catText (dirPath, ++s) ;
    }
  else
    pushText (dirPath, s) ;

  catText (dirPath, SUBDIR_DELIMITER_STR) ;

  return;
} /* filAddDir */

/*********************************************/

UTIL_FUNC_DEF void filAddPath (char *cp)
{
  char *cq = cp ;

  while (TRUE)
    { 
      while (*cq && *cq != PATH_DELIMITER)
	++cq ;
      if (*cq == PATH_DELIMITER)
	{
	  *cq = 0 ;
	  filAddDir (cp) ;
	  cp = ++cq ;
	}
      else
	{ 
	  filAddDir (cp) ;
	  break ;
	}
    }

  return;
} /* filAddPath */


/*****************************************************************************/
/* This function returns the filename part of a given path,                  */
/*                                                                           */
/*   Given   "/some/load/of/directories/filename"  returns  "filename"       */
/*                                                                           */
/* The function returns NULL for the following errors:                       */
/*                                                                           */
/* 1) supplying a NULL ptr as the path                                       */
/* 2) supplying "" as the path                                               */
/* 3) supplying a path that ends in "/"                                      */
/*                                                                           */
/* NOTE, this function is _NOT_ the same as the UNIX basename command or the */
/* XPG4_UNIX basename() function which do different things.                  */
/*                                                                           */
/* The function makes a copy of the supplied path on which to work, this     */
/* copy is thrown away each time the function is called.                     */
/*                                                                           */
/*****************************************************************************/

UTIL_FUNC_DEF char *filGetFilename(char *path)
{
  static char *path_copy = NULL ;
  const char *path_delim = SUBDIR_DELIMITER_STR ;
  char *result = NULL, *tmp ;
    
  if (path != NULL)
    {
      if (strcmp((path + strlen(path) - 1), path_delim) != 0) /* Last char = "/" ?? */
	{
	  if (path_copy != NULL) messfree(path_copy) ;
	  
	  path_copy = strnew(path, 0) ;
	  
	  tmp = path ;
	  while (tmp != NULL)
	    {
	      result = tmp ;
	      
	      tmp = strstr(tmp, path_delim) ;
	      if (tmp != NULL) tmp++ ;
	    }
	}
    }
  
  return(result) ;
} /* filGetFilename */


/*****************************************************************************/
/* This function returns the file-extension part of a given path/filename,   */
/*                                                                           */
/*   Given   "/some/load/of/directories/filename.ext"  returns  "ext"        */
/*                                                                           */
/* The function returns NULL for the following errors:                       */
/*                                                                           */
/* 1) supplying a NULL ptr as the path                                       */
/* 2) supplying a path with no filename                                      */
/*                                                                           */
/* The function returns "" for a filename that has no extension              */
/*                                                                           */
/* The function makes a copy of the supplied path on which to work, this     */
/* copy is thrown away each time the function is called.                     */
/*                                                                           */
/*****************************************************************************/
UTIL_FUNC_DEF char *filGetExtension(char *path)
{
  static char *path_copy = NULL ;
  char *extension = NULL, *cp ;
    
  if (path == NULL)
    return NULL;

  if (strlen(path) == 0)
    return NULL;

  if (path_copy != NULL) messfree(path_copy) ;
  path_copy = messalloc ((strlen(path)+1) * sizeof(char));
  strcpy (path_copy, path);

  cp = path_copy + (strlen(path_copy) - 1);
  while (cp > path_copy &&
	 *cp != SUBDIR_DELIMITER &&
	 *cp != '.')
    --cp;

  extension = cp+1;
    
  return(extension) ;
} /* filGetExtension */


/**********************************************************************/
/* This function takes a directory name and does the following:
   1. Returns the name if it is "complete" 
      (an absolute path on a given platform)
   2. On WIN32 platforms, for onto rooted paths	lacking a 
      drive specification, returns the directory name prefixed with 
      the default drive letter 
   3. Otherwise, assumes that the directory name resides within the 
      current working directory and thus, returns it prefixes the
      directory name with the working directory path */
/**********************************************************************/
UTIL_FUNC_DEF char *filGetFullPath(char *dir)
{
  static char *path_copy = NULL;
  char *pwd ;
  char dirbuf[MAXPATHLEN] ;

  /* Return dir if absolute path already */
  if (ABSOLUTE_PATH(dir))
    { 
      if (path_copy) 
	messfree (path_copy);
      path_copy = (char*) messalloc (strlen(dir) + 1) ;
      strcpy (path_copy, dir) ;
      return path_copy ;
    }

#if defined(WIN32)
  /* else if dir is a Win32 rooted path, then add current drive to rooted paths */
  else if ( *dir == SUBDIR_DELIMITER )
    { 
      char drive[3] = { GET_CURRENT_DRIVE, DRIVE_DELIMITER, '\0' } ;
      
      if (path_copy)
	messfree (path_copy);

      path_copy = (char*) messalloc (strlen(dir) + strlen(drive) + 1) ;
      strcpy (path_copy, drive) ;
      strcat (path_copy, dir) ;

      return path_copy ;
    }
#endif

  /* else if I can, then prefix "dir" with working directory path... */
  else if ((pwd = getwd (dirbuf)))
    { 
      if (path_copy)
	messfree (path_copy);

      path_copy = (char*) messalloc (strlen(pwd) + strlen(dir) + 2) ;

      strcpy (path_copy, pwd) ;
      strcat (path_copy, SUBDIR_DELIMITER_STR) ;
      strcat (path_copy, dir) ;

      return path_copy ;
    }
  else
    return 0 ;  /* signals error that the path was not found */
} /* filGetFullPath */

/*******************************/

static BOOL filCheck (char *name, char *spec)
	/* allow 'd' as second value of spec for a directory */
{
  char *cp ;
  BOOL result ;
  struct stat status ;

  if (!spec) /* so filName returns full file name (for error messages) */
    return TRUE ;
				/* directory check */
  if (spec[1] == 'd'  &&
      (stat (name, &status) || !(status.st_mode & S_IFDIR)))
    return 0 ;

  switch (*spec)
    {
    case 'r':
      return !(access (name, R_OK)) ;
    case 'w':
    case 'a':
      if (!access (name, W_OK))	/* requires file exists */
	return TRUE ;
				/* test directory writable */
      cp = name + strlen (name) ;
      while (cp > name)
	if (*--cp == SUBDIR_DELIMITER) break ;
      if (cp == name)
	return !(access (".", W_OK)) ;
      else
	{ *cp = 0 ;
	  result = !(access (name, W_OK)) ;
	  *cp = SUBDIR_DELIMITER ;
	  return result ;
	}
    case 'x':
      return !(access (name, X_OK)) ;
    default:
      messcrash ("Unknown spec %s passed to filName", spec) ;
    }
  return FALSE ;
}

/************************************************/

static char *filDoName (char *name, char *ending, char *spec, BOOL strict)
{
  static Stack part = 0, full = 0 ;
  char *dir, *result ;
#if defined(WIN32)
  char *cp, buf2[2] ;
  static char driveStr[3] = { 'C', DRIVE_DELIMITER, '\0' },
			  *pDriveStr = driveStr ; 
#endif

  if (!name)
    messcrash ("filName received a null name") ;

  if (!part)
    { part = stackCreate (128) ;
      full = stackCreate (MAXPATHLEN) ;
    }
    
  stackClear (part) ;

#if defined(WIN32)
  /* convert '/' => '\\' in path string */
  cp = name ; buf2[1] = 0 ;
  while (*cp)
    {
      if (*cp == '/') 
	catText (part, "\\") ;
      else
	{ buf2[0] = *cp; catText (part, buf2) ; }
      cp++ ;
    }
#else
  catText (part, name) ;
#endif
  if (ending && *ending)
    { catText (part, ".") ;
      catText (part, ending) ;
    }
	/* NB filName is reentrant in the sense that it can be called 
	   on strings it generates, because they first get copied into 
	   part, and then the new name is constructed in full.
	*/
  if (ABSOLUTE_PATH(name))
    {
      stackClear (full) ;
      catText (full, stackText (part, 0)) ;
      result = stackText (full, 0) ;
      if (filCheck (result, spec))
	return result ;
      else
	return 0 ;
    }
  
#if defined(WIN32)
/* Check if path name is a root path
   hence on the default logical drive */
  if( name[0] == SUBDIR_DELIMITER )
    {
      stackClear (full) ;
      driveStr[0] = GET_CURRENT_DRIVE ;
      catText (full, pDriveStr ) ;
      catText (full, stackText (part, 0)) ;
      result = stackText (full, 0) ;
      if (filCheck (result, spec))
	return result ;
      else
	return 0 ;
    }
#endif
  
  if (!dirPath)			/* add cwd as default to search */
    filAddDir (getwd (stackText (full, 0))) ;
  stackCursor (dirPath, 0) ;
  while ((dir = stackNextText (dirPath)))
    { 
      stackClear (full) ;
      catText (full, dir) ;
      catText (full, stackText (part, 0)) ;
      result = stackText (full, 0) ;
      if (filCheck (result, spec))
	return result ;
      if (strict)
	break ;
    }
  return 0 ;
} /* filDoName */

/************************************************************/

UTIL_FUNC_DEF char *filName (char *name, char *ending, char *spec)
{ return filDoName(name, ending, spec, FALSE) ; }

/************************************************************/

UTIL_FUNC_DEF char *filStrictName (char *name, char *ending, char *spec)
{ return filDoName(name, ending, spec, TRUE) ; }

/************************************************************/

UTIL_FUNC_DEF BOOL filremove (char *name, char *ending) 
				/* TRUE if file is deleted. -HJC*/
{
  char *s = filName (name, ending, "r") ;
  if (s)
    return unlink(s) ? FALSE : TRUE ;
  else
    return FALSE ;
} /* filremove */

/************************************************************/

UTIL_FUNC_DEF FILE *filopen (char *name, char *ending, char *spec)
{
  char *s = filName (name, ending, spec) ;
  FILE *result = 0 ;
   
  if (!s)
    {
      if (spec[0] == 'r')
	messerror ("Failed to open for reading: %s (%s)",
		   filName (name, ending,0),
		   messSysErrorText()) ;
      else if (spec[0] == 'w')
	messerror ("Failed to open for writing: %s (%s)",
		   filName (name, ending,0),
		   messSysErrorText()) ;
      else if (spec[0] == 'a')
	messerror ("Failed to open for appending: %s (%s)",
		   filName (name, ending,0),
		   messSysErrorText()) ;
      else
	messcrash ("filopen() received invalid filespec %s",
		   spec ? spec : "(null)");
    }
  else if (!(result = fopen (s, spec)))
    {
      messerror ("Failed to open %s (%s)",
		 s, messSysErrorText()) ;
    }
  return result ;
} /* filopen */

/********************* temporary file stuff *****************/

static Associator tmpFiles = 0 ;

UTIL_FUNC_DEF FILE *filtmpopen (char **nameptr, char *spec)
{
  if (!nameptr)
    messcrash ("filtmpopen requires a non-null nameptr") ;

  if (!strcmp (spec, "r"))
    return filopen (*nameptr, 0, spec) ;

#if defined(SUN) || defined(SOLARIS)
  if (!(*nameptr = tempnam ("/var/tmp", "ACEDB")))
#else
  if (!(*nameptr = tempnam ("/tmp", "ACEDB")))
#endif
    { 
      messerror ("failed to create temporary file (%s)",
		 messSysErrorText()) ;
      return 0 ;
    }
  if (!tmpFiles)
    tmpFiles = assCreate () ;
  assInsert (tmpFiles, *nameptr, *nameptr) ;

  return filopen (*nameptr, 0, spec) ;
} /* filtmpopen */

/************************************************************/

UTIL_FUNC_DEF BOOL filtmpremove (char *name)	/* delete and free()  */
{ BOOL result = filremove (name, 0) ;

  free (name) ;	/* NB free since allocated by tempnam */
  assRemove (tmpFiles, name) ;
  return result ;
}

/************************************************************/

UTIL_FUNC_DEF void filtmpcleanup (void)
{ char *name = 0 ;
 
  if (tmpFiles)
    while (assNext (tmpFiles, &name, 0))
      { filremove (name, 0) ;
	free (name) ;
      }
}

/************* filqueryopen() ****************/

static QueryOpenRoutine queryOpenFunc = 0 ;

UTIL_FUNC_DEF QueryOpenRoutine filQueryOpenRegister (QueryOpenRoutine new)
{ QueryOpenRoutine old = queryOpenFunc ; queryOpenFunc = new ; return old ; }

UTIL_FUNC_DEF FILE *filqueryopen (char *dname, char *fname, char *end, char *spec, char *title)
{
  Stack s ;
  FILE*	fil = 0 ;
  int i ;
				/* use registered routine if available */
  if (queryOpenFunc)
    return (*queryOpenFunc)(dname, fname, end, spec, title) ;

  /* otherwise do here and use messprompt() */
  s = stackCreate(50);

  if (dname && *dname)
    { pushText(s, dname) ; catText(s,"/") ; }
  if (fname)
    catText(s,fname) ; 
  if (end && *end)
    { catText(s,".") ; catText(s,end) ; }

 lao:
  if (!messPrompt("File name please", stackText(s,0), "w")) 
    { stackDestroy(s) ;
      return 0 ;
    }
  i = stackMark(s) ;
  pushText(s, freepath()) ;	/* freepath needed by WIN32 */
  if (spec[0] == 'w' && 
      (fil = fopen (stackText(s,i), "r")))
    { if ( fil != stdin && fil != stdout && fil != stderr)
	fclose (fil) ; 
      fil = 0 ;
      if (messQuery (messprintf ("Overwrite %s?",
				 stackText(s,i))))
	{ 
	  if ((fil = fopen (stackText(s,i), spec)))
	    goto bravo ;
	  else
	    messout ("Sorry, can't open file %s for writing",
		     stackText (s,i)) ;
	}
      goto lao ;
    }
  else if (!(fil = fopen (stackText(s,i), spec))) 
    messout ("Sorry, can't open file %s",
	     stackText(s,i)) ;
bravo:
  stackDestroy(s) ;
  return fil ;
} /* filqueryopen */

/*********************************************/

static Associator mailFile = 0, mailAddress = 0 ;

UTIL_FUNC_DEF void filclose (FILE *fil)
{
  char *address ;
  char *filename ;

  if (!fil || fil == stdin || fil == stdout || fil == stderr)
    return ;
  fclose (fil) ;
  if (mailFile && assFind (mailFile, fil, &filename))
    { if (assFind (mailAddress, fil, &address))
	callScript ("mail", messprintf ("%s %s", address, filename)) ;
      else
	messerror ("Have lost the address for mailfile %s", filename) ;
      assRemove (mailFile, fil) ;
      assRemove (mailAddress, fil) ;
      unlink (filename) ;
      free (filename) ;
    }
} /* filclose */

/***********************************/

UTIL_FUNC_DEF FILE *filmail (char *address)	/* requires filclose() */
{
  char *filename ;
  FILE *fil ;

  if (!mailFile)
    { mailFile = assCreate () ;
      mailAddress = assCreate () ;
    }
  if (!(fil = filtmpopen (&filename, "w")))
    { messout ("failed to open temporary mail file %s", filename) ;
      return 0 ;
    }
  assInsert (mailFile, fil, filename) ;
  assInsert (mailAddress, fil, address) ;
  return fil ;
} /* filmail */

/******************* directory stuff *************************/

static int dirOrder(void *a, void *b)
{
  char *cp1 = *(char **)a, *cp2 = *(char**)b;
  return strcmp(cp1, cp2) ;
} /* dirOrder */

/* returns an Array of strings representing the filename in the
   given directory according to the spec. "r" will list all files,
   and "rd" will list all directories.
   The behaviour of the "w" spec is undefined.
   The array has to be destroyed using filDirectoryDestroy,
   because the memory of the strings needs to be reclaimed as well. */

UTIL_FUNC_DEF Array filDirectoryCreate (char *dirName,
					char *ending, 
					char *spec)
{
  Array a ;
#if !defined(WIN32) && !defined(DARWIN)
  DIR	*dirp ;
  char	*dName, *dName_copy, entryPathName[MAXPATHLEN], *leaf ;
  int	dLen, endLen ;
  MYDIRENT *dent ;

  if (!dirName || !(dirp = opendir (dirName)))
    return 0 ;

  if (ending)
    endLen = strlen (ending) ;
  else
    endLen = 0 ;

  strcpy (entryPathName, dirName) ;
  strcat (entryPathName, "/") ;
  leaf = entryPathName + strlen(dirName) + 1 ;

  a = arrayCreate (16, char*) ;
  while ((dent = readdir (dirp)))           
    { dName = dent->d_name ;
      dLen = strlen (dName) ;
      if (endLen && (dLen <= endLen ||
		     dName[dLen-endLen-1] != '.'  ||
		     strcmp (&dName[dLen-endLen],ending)))
	continue ;

      strcpy (leaf, dName) ;
      if (!filCheck (entryPathName, spec))
	continue ;

      if (ending && dName[dLen - endLen - 1] == '.') /* remove ending */
	dName[dLen - endLen - 1] = 0 ;

      /* the memory of these strings is freed my 
	 the messfree()'s in filDirectoryDestroy() */
      dName_copy = messalloc(strlen(dName)+1) ;
      strcpy (dName_copy, dName);
      array(a, arrayMax(a), char*) = dName_copy;
    }
  
  closedir (dirp) ;
  
  /************* reorder ********************/
    
  arraySort(a, dirOrder) ;
  return a ;
#else   /* defined(WIN32) */
  return 0 ;
#endif	/* defined(WIN32) */
} /* filDirectoryCreate */

/*************************************************************/

UTIL_FUNC_DEF void filDirectoryDestroy (Array filDirArray)
{
#ifndef WIN32
  int i;
  char *cp;

  for (i = 0; i < arrayMax(filDirArray); ++i)
    {
      cp = arr(filDirArray, i, char*);

      messfree (cp);
    }
  arrayDestroy (filDirArray);
#endif /* !WIN32 */
  return;
} /* filDirectoryDestroy */

/************************************************************/
/* determines the age of a file, according to its last modification date.

   returns TRUE if the age could determined and the int-pointers
   (if non-NULL will be filled with the numbers).

   returns FALSE if the file doesn't exist, is not readable,
   or the age could not be detrmined. */
/************************************************************/
BOOL filAge (char *name, char *end,
	     int *diffYears, int *diffMonths, int *diffDays,
	     int *diffHours, int *diffMins, int *diffSecs)
{
  struct stat status;
  mytime_t time_now, time_modified;
  char time_modified_str[25];
	  
  /* get the last-modification time of the file,
     we parse the time into two acedb-style time structs
     in order to compare them using the timediff functions */
  
  if (!(filName (name, end, "r")))
    return FALSE;

  if (stat (filName (name, end, "r"), &status) == -1)
    return FALSE;

  {
    time_t t = status.st_mtime;
    struct tm *ts;

    /* convert the time_t time into a tm-struct time */
    ts = localtime(&t);		

    /* get a string with that time in it */
    strftime (time_modified_str, 25, "%Y-%m-%d_%H:%M:%S", ts) ;

    time_now =      timeNow();
    time_modified = timeParse(time_modified_str);

    if (diffYears)
      timeDiffYears (time_modified, time_now, diffYears);

    if (diffMonths)
      timeDiffMonths (time_modified, time_now, diffMonths);

    if (diffDays)
      timeDiffDays (time_modified, time_now, diffDays);

    if (diffHours)
      timeDiffHours (time_modified, time_now, diffHours);

    if (diffMins)
      timeDiffMins (time_modified, time_now, diffMins);

    if (diffSecs)
      timeDiffSecs (time_modified, time_now, diffSecs);
  }
  return TRUE;
} /* filAge */



/************************************************************/
/********** Some WIN32-specific filsub-like code ************/
/************************************************************/

#if defined(WIN32)

/************************************************************
 *	Converts MSDOS-like pathnames to POSIX-like ones.   *
 *  Warning: This function is not reentrant, to avoid	    *
 *  the complexities of heap memory allocation and release  *
 ************************************************************/
UTIL_FUNC_DEF char *DosToPosix(char *path)
{
  static char newFilName[MAXPATHLEN] ;
  char cwdpath[MAXPATHLEN], *cwd ;
  int i , drive ;

  if( !path || !*path ) return NULL ;

	/* POSIX with drive letters starts with "//" */
  newFilName[0] = SUBDIR_DELIMITER ;
  newFilName[1] = SUBDIR_DELIMITER ;

ReScan:
  i = 2 ;
	/* Drive letter as "A:\" format converted to "A/" format */
  if( strlen(path) >= 2  && 
     (isalpha( (int)*path ) ) && 
     (*(path+1) == DRIVE_DELIMITER) )
    {
      newFilName[i++] = drive = tolower(*path) ;
      path += 2 ; /* skip over drive letter... */
		/* If a root delimiter is present, then path from root (skip delimiter) */
      if( *path == SUBDIR_DELIMITER )
	path++ ;
      else /* else, a relative path on specified drive (append to current directory) */
	{	 /*  If a non-NULL current working directory on specified drive is found */
	  if( (cwd = _getdcwd(DRIVE_NO(drive),cwdpath,MAXPATHLEN - 2)) != NULL )
	    {	/* Then append relative path to current working directory*/
	      if( strlen(cwd)+strlen(path)-1 > MAXPATHLEN )
		messcrash("DosToPosix(): Path buffer overflow?") ;
	      /* If current working directory is not just a root directory pathname*/
	      if( *(cwd+3) ) /* i.e. non-null fourth character?*/
		strcat(cwd, SUBDIR_DELIMITER_STR) ; /* then tack on a SUBDIR_DELIMITER*/
	      strcat(cwd, path) ;
	      path = cwd ;  /* Reset path to new total path*/
	      goto ReScan ; /* Need to rescan because cwd is of DOS format?*/
	    } /* else, assume path from root*/
	}
    }
  else
    if( *path == SUBDIR_DELIMITER	/* If root directory specified only, with no drive letter? */
       && *path++								/* always TRUE thus skips over delimiter... */ )
      newFilName[i++] = GET_CURRENT_DRIVE ;	/* Then assume current drive at root directory*/

    else {	/* Else, no drive letter, no root delimiter => relative path not at root */
      if( (cwd = getwd(cwdpath)) != NULL )	/* If a non-NULL current working */
	{										/* directory on default drive is found */
	  if( strlen(cwd)+strlen(path)-1 > MAXPATHLEN ) /* Append relative path to cwd */
	    messcrash("DosToPosix(): Path buffer overflow?") ;
	  
	  if( *(cwd+3) )	/* If cwd is not just a root directory */
	    strcat(cwd, SUBDIR_DELIMITER_STR) ; /* then tack on a SUBDIR_DELIMITER */
	  strcat(cwd, path) ;
	  path = cwd ;  /* Reset path to new total path*/
	  goto ReScan ; /* Need to rescan because cwd is of DOS format?*/
	}
      else /* just use the current drive*/
	newFilName[i++] = GET_CURRENT_DRIVE ;
    }
  newFilName[i++] = SUBDIR_DELIMITER ;
  
  while(*path) /* Until '\0' encountered */
    {
      /* Path delimiter '\' format */
      if( (*path == SUBDIR_DELIMITER) )
	newFilName[i++] = SUBDIR_DELIMITER ; /* replace ...*/
      else
	newFilName[i++] = *path ; /* else, just copy letter */
      ++path ;	/* ... then skip over */
    }
  newFilName[i] = '\0' ;
  return newFilName ;
}

#endif /* #defined(WIN32) */

/*************** end of file ****************/
AcePerl-1.92/acelib/aceclientlib.c0000644000175000017500000003705107565000306016346 0ustar  lsteinlstein/*  File: aceclientlib.c
 *  Author: Jean Thierry-Mieg (mieg@kaa.cnrs-mop.fr)
 *  Copyright (C) J Thierry-Mieg and R Durbin, 1992
 *-------------------------------------------------------------------
 * This file is part of the ACEDB genome database package, written by
 * 	Richard Durbin (MRC LMB, UK) rd@mrc-lmb.cam.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr
 *
 * Description:
 * I started from a sample code generated by rpcgen on Solaris
 * and a first version by Peter Kocab.
 * Does not require any ACEDB library code.
 * 
 * Exported functions:
	 openServer()
	 closeServer()
	 askServer()
	 askServerBinary()
 * HISTORY:
 * Last edited: Sep 10 19:48 1997 (rd)
 * Created: Wed Nov 25 20:02:45 1992 (mieg)
 *-------------------------------------------------------------------
 */

/* $Id: aceclientlib.c,v 1.1 2002/11/14 20:00:06 lstein Exp $ */

#include "mystdlib.h"
#define __malloc_h  
#include 
#include 
#include "rpcace.h"
#include "aceclient.h"
#include "regular.h"

BOOL accessDebug = FALSE ;

#include 		/* for alarm stuff */
#include 		/* for pause() */
#include 		/* for setitimer() etc. */


static void wakeUp (int x) 
{ 
  static int sig = 0 ; 
  sig = x ;     
  signal (SIGALRM, wakeUp) ; /* reregister, otherwise you exit on SGI and LINUX */
}

static FILE *magicFileOpen (char *name)
{
  FILE *f ;

  f = fopen (name, "r") ;
  if (f) 
    { if (accessDebug) 
	printf ("//   found %s immediately\n", name) ;
      return f ;
    }

  /* test if directory readable by trying to open the file "." in
     the directory.  filcheck() and access() won't work in setuid()
     situations.
  */
  { char *dirName, *cp ;

    dirName = strnew (name, 0) ;
    for (cp = dirName ; *cp ; ++cp) ;
    while (cp > dirName && *cp != '/') --cp ;
    *++cp = '.' ;
    *++cp = 0 ;
    if (!(f = fopen(dirName, "r")))
      { if (accessDebug) 
	  printf ("//   directory %s not readable\n", dirName) ;
	return 0 ;
      }
    fclose (f) ;
  }

  { int i ;
    struct itimerval tval ;
    
    signal (SIGALRM, wakeUp) ;
    tval.it_interval.tv_sec = 0 ;
    tval.it_interval.tv_usec = 5000 ; /* 5ms reload */
    tval.it_value.tv_sec = 0 ;
    tval.it_value.tv_usec = 1000 ; /* 1ms initial */
    setitimer (ITIMER_REAL, &tval, 0) ;

    for (i = 0 ; i < 1000 ; ++i) /* 5 seconds */
      { pause () ;		/* wait until SIGALRM handled */
	f = fopen (name, "r") ;
	if (f) 
	  { if (accessDebug) 
	      printf ("//   found %s after %d msecs\n", name, 5*i+1) ;
	    tval.it_interval.tv_usec = tval.it_value.tv_usec = 0 ;
	    setitimer (ITIMER_REAL, &tval, 0) ;
	    return f ;
	  }
      }

    if (accessDebug)
      printf ("//   failed to find %s after %d msecs\n", name, 5*i+1) ;
    tval.it_interval.tv_usec = tval.it_value.tv_usec = 0 ;
    setitimer (ITIMER_REAL, &tval, 0) ;
  }

  return 0 ;
}

static int getMagic (int magic1, char *nm)
{ int magic = 0, magic2 = 0, magic3 = 0 ;
  FILE *f ;
  int level ;
  char *cp ;

  if (magic1 < 0) magic1 = -magic1 ; /* old system */
  if (!nm || !*nm) return 0 ;
  freeinit() ;
  level = freesettext(nm,0) ;
  if (!freecard(level))
    goto fin ;

  cp = freeword () ;
  if (!cp)
    { messerror ("Can't obtain write pass name from server") ;
      goto fin ;
    }

  if (accessDebug)
    printf ("// Write pass file: %s\n", cp) ;  
  if (strcmp(cp, "NON_WRITABLE"))
    { f = magicFileOpen (cp) ;
      if (f)
	{ if (fscanf(f, "%d", &magic3) != 1)
	    messerror ("failed to read file") ;
	  fclose(f) ;
	}
    }

  if ((cp = freeword ()) && 
      !magic3)		/* must be able to read if can write */
    { if (accessDebug)
	printf ("// Read pass file: %s\n", cp) ;  
      if (strcmp(cp, "PUBLIC") && strcmp(cp,"RESTRICTED"))
	{ f = magicFileOpen (cp) ;
	  if (!f)
	    { messout ("// Access to this database is restricted, sorry (can't open pass file)\n") ;
	      goto fin ;
	    }  
	  if (fscanf(f, "%d", &magic2) != 1)
	    messerror ("failed to read file") ;
	  fclose(f) ;
	}
    }

  magic = magic1 ;
  if (magic2)
    magic  = magic1 * magic2 % 73256171 ;
  if (magic3)
    magic = magic1 * magic3 % 43532334 ;

fin:
  freeclose(level) ;

#ifdef DEEP_DEBUG
    printf ("// magic1=%d, magic2=%d, magic3=%d, magic=%d\n", 
	     magic1, magic2, magic3, magic) ;
#endif

  return magic ;
}

/*************************************************************
Open RPC connection to server
INPUT
 char *host    hostname running server 
 int  timeOut  maximum peroid to wait for answer

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

  if (!clnt) return((ace_handle *)NULL);

/* authenticate */
  question.clientId = 0;
  question.magic = 0;
  question.reponse.reponse_len = 0;
  question.reponse.reponse_val = "";
  question.question = "";
  question.aceError = 0;
  question.kBytes = 0;
  question.encore = 0;

#ifdef JUNK
  int first = 1 ;
  /* kludge: on first connection to a daemon
    the  conection is lost, so i try to connect twice,
    once with a short timeOut, then the real try

    at least on a dec alpha, the first connection keeps hanging and the
  inetd daemon keeps restrating the server for ever

    the advantage of this kludge is that the first client connection no 
    longer fails, and it is otherwise harmless since the restarting
    server happenned before i introduced this kludge
    */
  if (first)
    { first = 0 ;
      tv.tv_sec = 5 ;
      tv.tv_usec = 0;
      clnt_control(clnt, CLSET_TIMEOUT, (char *)&tv);

      reponse = ace_server_1(&question, clnt);
      if (!reponse) /* i ll try a second time */
	{ clnt_destroy(clnt); goto lao ; }
    }
#endif

  tv.tv_sec = timeOut;
  tv.tv_usec = 0;
  clnt_control(clnt, CLSET_TIMEOUT, (char *)&tv);
  
  if (!reponse) /* hopefully first connection worked */
    reponse = ace_server_1(&question, clnt);
  if (!reponse) return ((ace_handle *)NULL);
  
  clientId = reponse->ace_reponse_u.res_data.clientId;
  magic1 = reponse->ace_reponse_u.res_data.magic;
  if (!clientId) {
    xdr_free((xdrproc_t )xdr_ace_reponse, (char *)reponse); 
    memset (reponse,0, sizeof(ace_reponse)) ;
    clnt_destroy(clnt);
    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;
    question.kBytes = 0;
    question.encore = 0;
    reponse = ace_server_1(&question, clnt);
    if (!reponse) {
      clnt_destroy(clnt);
      return 0 ;
    }
    n = reponse->ace_reponse_u.res_data.clientId;
  } 
  else
    n = clientId + 1 ; /* so we fail */
  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;
  }
  xdr_free((xdrproc_t )xdr_ace_reponse, (char *)reponse);
  memset (reponse,0, sizeof(ace_reponse)) ;
  if (n != clientId) {
  /* authentication failed */
    clnt_destroy(clnt);
    return 0 ;
  }
/* create mem for handle */
  if ((handle = (ace_handle *)malloc(sizeof(ace_handle))) == NULL) {
     question.clientId = clientId ;
     question.magic = magic3 ;
     question.reponse.reponse_len = 0;
     question.reponse.reponse_val = "";
     question.question = "Quit";
     question.aceError = 0;
     question.kBytes = 0;
     question.encore = 0;
     reponse = ace_server_1(&question, clnt);
     xdr_free((xdrproc_t )xdr_ace_reponse, (char *)reponse);
     memset (reponse,0, sizeof(ace_reponse)) ;
     clnt_destroy(clnt);
     return 0 ;
  }
  handle->clientId = clientId;
  handle->magic = magic3;
  handle->clnt = clnt;

  return handle ;
}

/*************************************************************
notify server of intent to close connection
close connection
free structures

INPUT 
 ace_handle *  pointer to structure containing open connection
               and client identification information
OUTPUT
none
*/

void closeServer(ace_handle *handle) {
ace_data question;
ace_reponse *reponse = 0;

  if (handle) {
    if ( (int *)handle && (CLIENT *)handle->clnt) { 
 /* JC not sure whether I should/need check (int *)handle */
      question.clientId = handle->clientId ;
      question.magic = handle->magic ;
      question.reponse.reponse_len = 0;
      question.reponse.reponse_val = "";
      question.question = "Quit";
      question.aceError = 0;
      question.kBytes = 0;
      question.encore = 0;
      reponse = ace_server_1(&question, handle->clnt);
      if (reponse)
         { xdr_free((xdrproc_t )xdr_ace_reponse, (char *)reponse);
	 memset (reponse,0, sizeof(ace_reponse)) ;
	 }
      clnt_destroy((CLIENT *)handle->clnt);
    }
    free((char *)handle);
  }
}

/*************************************************************
transfer request to server, and wait for binary answer
INPUT
 char * request  string containing request
 unsigned char ** answer  ptr to char ptr, that has to be filled with answer
 ace_handle *    pointer to structure containing open connection
                 and client identification information
 int chunkSize desired size (in kBytes) of returned data-block
            This is only a hint. The server can return more.
            The server splits on ace boundaries
            a chunkSize of 0 indicates a request for unbuffered answers

OUTPUT
 unsigned char ** answer  ptr to char ptr. Pointing to allocated memory containing 
                 answer string. This memory will be filled with the 
                 unmodified data handled as binary bytes.
 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 

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)) 
    {
      /* encore request */
      question.encore = WANT_ENCORE;
      question.question = ""; 
    } 
  else if (!strncasecmp(request,"noencore",8)) 
    {
      /* encore request */
      question.encore = DROP_ENCORE;
      question.question = ""; 
    } 
  else if (!strncasecmp(request,"quit",4)) 
    { /* ignore quit request. Must go through closeServer routine */
      *answerLength = 0;
      *answerPtr = NULL;
      return 0;
    } 
  else
    { question.encore = 0;
      question.question = request;
    }
  
  if (*encorep == 3)
    question.encore = -3 ;
  reponse = ace_server_1(&question, handle->clnt);

  /* validity checking of reponse */
  /* no data was received, return error */
  if (!reponse) 
    return EIO ; 
  
  /* store server returned error status. Give this to the client */
  /* JC answer could contain more info on error, so
     continue normal handling of the answer */
  aceError =  reponse->ace_reponse_u.res_data.aceError;
  
  /* no answer was received, return NULL answer 
     leave checking for NULL reponse to upper layer 
  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;imagic == &LISTEMAGIC)
    {
      arrayDestroy(liste->a) ;
      liste->magic = 0 ;
    }
    */
}

Liste listeCreate (STORE_HANDLE hh)
{
  Liste liste = (Liste)  halloc(sizeof(struct listeStruct), hh) ;
  
  liste->magic = &LISTEMAGIC ;
  liste->i = 1 ;
  liste->a = arrayHandleCreate (32, void*, hh) ;
  blockSetFinalise(liste,listeFinalize) ;
  array (liste->a,0,void*) = 0 ; /* avoid zero */
  return liste ;
}

void listeRemove (Liste liste, void *vp, int i) 
{
  Array a = liste->a ;
  void *wp = array(a, i, void*) ;

  if (vp != wp) messcrash ("Confusion in listeRemove") ;
  array (a,i,void*) = 0 ;
  if (i < liste->i)
    liste->i = i ;
}
  
int listeAdd (Liste liste, void *vp) 
{
  Array a = liste->a ;
  int i = liste->i ;
  void **vpp = arrayp(a, i, void*) ;
  int n = arrayMax(a) ;  /* comes after arrayp of above line ! */
  while (*vpp && i++ < n) vpp++ ;
  array (a,i,void*) = vp ;
  return i ;
}
  
int listeFind (Liste liste, void *vp) 
{
  Array a = liste->a ;
  int i = arrayMax (liste->a) ;
  void **vpp = arrayp(a, i - 1, void*) + 1 ;
  
  while (vpp--, i--)
    if (vp == *vpp) return i ;
  return 0 ;
}
  
/******************** end of file **********************/

 
 
AcePerl-1.92/acelib/helpsubs.c0000644000175000017500000012123607121260302015544 0ustar  lsteinlstein/*  File: helpsubs.c
 *  Author: Fred Wobus (fw@sanger.ac.uk)
 *  Copyright (C) J Thierry-Mieg and R Durbin, 1998
 *-------------------------------------------------------------------
 * This file is part of the ACEDB genome database package, written by
 * 	Richard Durbin (MRC LMB, UK) rd@sanger.ac.uk, and
 *	Jean Thierry-Mieg (CRBM du CNRS, France) mieg@kaa.cnrs-mop.fr
 *
 * SCCS: %W% %G%
 * Description: controls the help system, provides HTML parsing
 * Exported functions:
 * HISTORY:
 * Last edited: Dec  4 14:30 1998 (fw)
 * * Oct 12 12:27 1998 (fw): checkSubject now case-insensitive
 * * Oct  8 17:23 1998 (fw): removed warning, in case that 
    an open-list tag (e.g. 
         was directly followed by a close-list
    tag (e.g. 
      ). The warning tried to enforce that 
    every type of list only has a certain type of items.
 * * Oct  8 11:36 1998 (fw): helpSubjectGetFilename takes over logic 
           from readHelpfile to locate the file containing the
	   help for a particular subject
 * Created: Tue Aug 18 16:11:07 1998 (fw)
 *-------------------------------------------------------------------
 */

#include "help_.h"

/************************************************************/
static char     *makeHtmlIndex (STORE_HANDLE handle);
static char     *makeHtmlImagePage (char *link, STORE_HANDLE handle);
static HtmlNode *parseHtmlText (char *text, STORE_HANDLE handle);
static BOOL      parseSection  (char **cp, HtmlNode **resultnode, 
				STORE_HANDLE handle);
/************************************************************/


/************ directory where help files are stored *********/
static char helpDir[MAXPATHLEN] = "" ;


/************************************************************/
/* function to register the helpOnRoutine
   This can be called at any stage (before the first helpOn,
   or later on, it will affect the system next time helpOn
   is called. */
/************************************************************/
static QueryRoutine helpOnRoutine = 0;
UTIL_FUNC_DEF QueryRoutine helpOnRegister (QueryRoutine func)
/* call with func = 0x0 just to check whether 
   anything has been registered yet */
{
  QueryRoutine old = helpOnRoutine ; 

  if (func) 
    helpOnRoutine = func ; 

  return old ;
}



/************************************************************/
/* Sets the helpDir;  */
/************************************************************/
UTIL_FUNC_DEF char *helpSetDir (char *dirname)
{
  if (dirname)
    {
      strcpy (helpDir, dirname);

      if (filName (dirname,0,"rd"))
	return (char*)&helpDir[0];
      else
	return (char*)0;
    }
  else
    {      
      strcpy (helpDir, filGetFullPath ("whelp"));
      
      if (filName (helpDir, 0, "rd"))
	return (char*)&helpDir[0];
    }

  return (char*)0;
} /* helpGetDir */



/************************************************************/
/* return the current helpDirectory or 
   initialise if not previously set */
UTIL_FUNC_DEF char *helpGetDir (void)
{
  if (!*helpDir)
    return (helpSetDir(0)) ;

  return (char*)&helpDir[0];
} /* helpGetDir */



/************************************************************/
/* pop up help on the given subject, depending on the registered
   display function, that will be textual, in the built-in
   simple HTML browser or even launch an external browser
   to display the help document */
/************************************************************/
UTIL_FUNC_DEF BOOL helpOn (char *subject)
{
  char *helpFilename;

  if (!helpGetDir() || !filName(helpGetDir(), "", "rd"))
    {
      messout ("Sorry, No help available ! "
	       "Could not open the HTML help directory "
	       "%s\n"
	       "(%s)",
	       helpGetDir(),
	       messSysErrorText());
      
      return FALSE;
    }
  
  helpFilename = helpSubjectGetFilename(subject);
  /* may be NULL if file could not be found,
     the registered helpOnRoutine has to cope
     with this case and may decide to display an 
     index instead */
  
  if (helpOnRoutine)
    return ((*helpOnRoutine)(helpFilename));


  return (helpPrint (helpFilename)); /* textual help as default */
} /* helpOn */
/************************************************************/


UTIL_FUNC_DEF char *helpSubjectGetFilename (char *subject)
/* this function attempts to find the file name corresponding
   to a particular help-subject.
   It will attempt to find a matching file according to
   the current settings of helpDir and HELP_FILE_EXTENSION.
   
   the subject '?' will just return ? again. This is a special
   code within the help system to tell the help display
   function that the user required some kind of help.
   Usually the helpOnRegister'd function would display a
   dynamically created index of the help-directory.

   this function can be even cleverer by doing keyword searches
   on  and <H1> strings in files that might be relevant
   of no obvious match is found.
*/
{
  static char filename_array[MAXPATHLEN] = "";
  char *filename = &filename_array[0];
  char *subject_copy;
  Array dirList;

  if (subject == NULL) 
    return NULL;

  if (strlen(subject) == 0) 
    return NULL;

  if (strcmp(subject, "?") == 0)
    {
      /* return ? to signal that the calling 
	 function needs to display a dynamically
	 created index or show some kind of help. 
       */
      /* if the construct
	 page = htmlPageCreate(helpGetFilename(subject_requested));
	 is used, the resulting page will therefor be a marked up
	 directory listing of helpsubjects
       */
      strcpy (filename, "?");
      return filename;
    }

  subject_copy = strnew (subject, 0);

  strcpy (filename, "");	/* intialise, if this is
				   non-empty at the end of the loop,
				   we found a matching helpfile */
  while (TRUE)
    {
      /* simple attempt to locate file - path/helpDir/subject.html */
      sprintf(filename, "%s%s%s.%s", 
	      filGetFullPath(helpGetDir()),
	      SUBDIR_DELIMITER_STR,
	      subject_copy, HELP_FILE_EXTENSION);

      if (filName(filename, 0, "r"))
	break;

      /* advanced attempt, try to find a matching file from
	 the list of available ones by scanning the directory
	 contents of the helpdirectory */
      if ((dirList = filDirectoryCreate
	   (helpGetDir(), HELP_FILE_EXTENSION, "r")) )
	{
	  int i;
	  int matches;
	  char *s;
	  
	  /* first look for an exact case-insensitive match */
	  strcpy (filename, "");
	  for (i = 0 ; i < arrayMax(dirList) ; i++)
	    {
	      s = arr(dirList,i,char*);
	      
	      if (strcasecmp (s, subject_copy) == 0)
		{
		  sprintf(filename, "%s%s%s.%s", 
			  filGetFullPath(helpGetDir()),
			  SUBDIR_DELIMITER_STR,
			  s, HELP_FILE_EXTENSION);
		  if (filName(filename, 0, "r"))
		    break;	/* exit for-loop */

		  strcpy (filename, "");
		}
	    }

	  if (strlen(filename) > 0)
	    break;		/* exit while(true) loop */

	  /* count the number of filenames starting with the
	     given subject string */
	  matches = 0;
	  for (i = 0 ; i < arrayMax(dirList) ; i++)
	    {
	      s = arr(dirList,i,char*);
	      
	      if (strncasecmp (s, subject_copy, 
			       strlen(subject_copy)) == 0)
		{
		  sprintf(filename, "%s%s%s.%s", 
			  filGetFullPath(helpGetDir()),
			  SUBDIR_DELIMITER_STR,
			  s, HELP_FILE_EXTENSION);
		  ++matches;
		}
	    }

	  if (matches == 0)
	    {
	      strcpy (filename, ""); /* not found */
	    }
	  else if (matches == 1)
	    {
	      /* the one exact match (already in filename string)
		 is the complete filename */
	      if (filName(filename, 0, "r"))
		break;		/* exit while(true) loop */
	    }
	  else if (matches > 1)
	    {
	      /* construct a filename that we know won't work.
		 But it may be used by the help display
		 function to give a meaningful message
		 to say that this subject is ambiguos.
		 The returned filename is then considered
		 a template, similar to 'ls subject*'
		 so the help-display function may give a list 
		 of possible matching subjects. */

	      sprintf(filename, "%s%s%s", 
		      filGetFullPath(helpGetDir()),
		      SUBDIR_DELIMITER_STR, subject_copy);
	      break;
	    }

	  filDirectoryDestroy (dirList);

	} /* endif dirList */

      /* file didn't exist, whichever way we tried so far,
	 so we try to chop off the last bit of the subject name.
	 In case trySubject was "Tree_Clone_Inside", we now
	 go through the look again with "Tree_Clone" and re-try. */

      if (strchr (subject_copy, '_'))
	{
	  int j;

	  j = strlen (subject_copy);
	  while (subject_copy[j--] != '_') ; /* find the last _ char */
	  subject_copy[j + 1] = '\0';
	}
      else
	{
	  /* If we run out of trailing components, then we exit
	   * anyway.
	   */
	  strcpy (filename, "");
	  break;		/* exit while(true)loop */
	}
    } /* end-while(true) */

  messfree (subject_copy);


  if (strcmp(filename, "") != 0)
    return filename;		/* success */

  if ((strcasecmp(subject, "index") == 0) ||
      (strcasecmp(subject, "home") == 0) ||
      (strcasecmp(subject, "toc") == 0))
    {
      /* we asked for some kind of index-page but couldn't find it,
	 so we can always try to return the question mark '?'
	 which will ask the calling function to display a
	 dynamically created index of help-subjects. */

      strcpy (filename, "?");
      return filename;
    }


  return NULL;			/* failure - no file found */
} /* helpSubjectGetFilename */


/************************************************************/
/* helpPackage utility to find out the filename of a given
   link reference. Absolute filenames are returned unchanged,
   but relative filenames are expanded to be the full path
   of the helpfile. Can be used for html/gif files referred to
   by the HREF of anchor tags or the SRC or IMG tags */

/* NOTE: the pointer returned is a static copy, which is
   re-used everytime it is called. If the calling function
   wants to mess about with the returned string, a copy
   has to be made.
   NULL is returned if the resulting file can't be opened.
   the calling function can inspect the result of
   messSysErrorText(), the report the resaon for failure */
/************************************************************/
UTIL_FUNC_DEF char *helpLinkGetFilename (char *link)
{
  static char link_path_array[MAXPATHLEN] = "";
  char *link_path = &link_path_array[0];

  if (link[0] == SUBDIR_DELIMITER) /* absolute path (UNIX) */
    {
      strcpy (link_path, link);
    }
  else				/* relative path */
    {
      strcpy (link_path, helpGetDir());
      strcat (link_path, SUBDIR_DELIMITER_STR);
      strcat (link_path, link);
    }

  if (filName(link_path, "", "r"))
    return link_path;

  return NULL;
} /* helpLinkGetFilename */


/************************************************************/
/******************                   ***********************/
/************** private helpPackage functions ***************/
/******************                   ***********************/
/************************************************************/


HtmlPage *htmlPageCreate (char *helpFilename)
/* complemeted by htmlPageDestroy */
{
  FILE *fil;
  HtmlPage *page = 0;

  if (!helpFilename)		/* we could get a NULL filename */
    return 0;                   /* here, which might come from
				   helpSubjectGetFilename() that couldn't
				   find a file matching the subject */

  /* create a page with a marked up directory listing */
  if (strcmp(helpFilename, "?") == 0)
    {
      page = messalloc (sizeof(HtmlPage));
      page->handle = handleCreate();
      page->htmlText = makeHtmlIndex(page->handle);
      if (!(page->root = parseHtmlText(page->htmlText, page->handle)))
	htmlPageDestroy(page);

      return page;
    }

  if (!(filName(helpFilename, "", "r")))
    return 0;			/* prevent error caused 
				   by unsucsessful filopen */


  /* create a page inlining the image */
  if (strcasecmp (helpFilename + (strlen(helpFilename)-4), ".gif") == 0)
    {
      page = messalloc (sizeof(HtmlPage));
      page->handle = handleCreate();
      page->htmlText = makeHtmlImagePage(helpFilename, page->handle);
      if (!(page->root = parseHtmlText(page->htmlText, page->handle)))
	htmlPageDestroy(page);

      return page;
    }


  /* assume HTML page */
  if ((fil = filopen(helpFilename, "", "r")))
    {
      page = htmlPageCreateFromFile (fil);
      filclose (fil);
    }

  return page;
} /* htmlPageCreate */
/************************************************************/

HtmlPage *htmlPageCreateFromFile (FILE *fil)
{
  HtmlPage *page;
  int fileSize;

  if (!fil)
    return (HtmlPage*)0;

  /* determine filesize */
  rewind (fil);
  fseek (fil, 0, SEEK_END);
  fileSize = ftell (fil);
  rewind (fil);
      
  if (fileSize == 0)
    return (HtmlPage*)0;
    
  /* if we have a positive fileSize, we are pretty much
     guaranteed, that we'll get some HTML text and a parsetree */

  page = messalloc (sizeof(HtmlPage));

  page->handle = handleCreate();

  /* grab the contents of the file */
  page->htmlText = halloc ((fileSize + 1) * sizeof(char), page->handle);
  fread (page->htmlText, sizeof (char), fileSize, fil);
  page->htmlText[fileSize] = '\0'; /* add string terminator */
      
  /* get parsetree */
  page->root = parseHtmlText(page->htmlText, page->handle);

  return page;
} /* htmlPageCreateFromFile */
/************************************************************/

void htmlPageDestroy (HtmlPage *page)
{
  if (!page) return;

  /* clear all memory used during parsing of the page */
  handleDestroy (page->handle);

  /* clear the memory taken up by the structure itself */
  messfree (page);

  return;
} /* htmlPageDestroy */
/************************************************************/

void stripSpaces (char *cp)
/* utility to get rid of multiple spaces from a string */
/* we use it on node->text, where the text isn't within <PRE> tags */
{
  char *s ;
  int i ;

   /* strip unwanted white spaces from the text */
  for (i = 0; i < strlen(cp); ++i)
    if (isspace ((int)cp[i])) cp[i] = ' ' ;

  while ((s = strstr (cp, "  ")))
    {
      s[1] = 0 ;
      strcat (cp, s+2) ;
    }
 
  if (cp[strlen(cp)-1] == ' ')
    cp[strlen(cp)-1] = '\0' ;

  return ;
} /* stripSpaces */



/************************************************************/
/******************                   ***********************/
/****************** static functions  ***********************/
/******************                   ***********************/
/************************************************************/




/************************************************************/
/* as the helpviewer supports inlined images, it is easy
   to display image, even when they're not inlined as in
   <A HREF=image.gif>click here for image</A>.
   We just return a container page, that inlines the image */
/************************************************************/
static char *makeHtmlImagePage (char *link, STORE_HANDLE handle)
{
  char *text;
  int len;

  len = 0;
  len = 7+6+strlen(filGetFilename(link))+8+10+strlen(link)+2;

  text = halloc((len+1)*sizeof(char), handle);

  sprintf (text,
	   "<TITLE>Image %s"
	   "", filGetFilename(link), link);

  text[len] = 0;

  return text;
} /* makeHtmlImagePage */



/************************************************************/
/* reads the directory of helpDir and constructs an HTML-page
   containing a 
        -list of all HTML-files in helpDir */
/************************************************************/
static char *makeHtmlIndex (STORE_HANDLE handle)
{
  char *cp, *text, *s ;
  int i, len ;
  Array dirList;

  if(!(dirList = filDirectoryCreate
       (helpGetDir(), HELP_FILE_EXTENSION, "r")) )
    {
      messout ("Can't open help directory %s\n"
	       "(%s)",
	       helpDir, messSysErrorText()) ;

      return 0 ;
    }

  len = 0 ;

  /* determine the length of the text to be returned */
  len += 39+15+5+6 ;			/* for header */
  for (i = 0 ; i < arrayMax(dirList) ; i++)
    {
      s = arr(dirList,i,char*) ;
      len += strlen(s)*2 + strlen(HELP_FILE_EXTENSION) + 19;
      /* this is the length of each line as written 
	 to the string by sprintf(cp,"
      • ...") below */
    }

  text = (char*)halloc ((len+1) * sizeof(char), handle) ;
  cp = text ;

  sprintf (cp,
	   "Index of Help Directory\n"
	   "
        Index
        \n"
	   "
          \n") ;
  cp += 39+15+5 ;

  for (i = 0 ; i < arrayMax(dirList) ; i++)
    {
      s = arr(dirList, i, char*) ;
      sprintf (cp, "
        • %s\n",
	       s, HELP_FILE_EXTENSION, s) ;
      cp += strlen(s)*2 + strlen(HELP_FILE_EXTENSION) + 19;
    }
  sprintf (cp, "
        \n") ;
  text[len] = 0 ;

  filDirectoryDestroy (dirList) ;

  return text ;
} /* makeHtmlIndex */
/************************************************************/




/*************************************************************
 *****************  HTML Parsing package *********************
 *** currently very crude parser, will fall over any bad  ****
 *** whether Mosaic, Netscape or MSIE can deal with or not. **
 ************************************************************/
 

static HtmlNode *parseHtmlText(char *text, STORE_HANDLE handle)
/* return root node of html parse-tree, 
   generated from the HTML source text */
{
  char *cp = text;
  HtmlNode *node;
  
  if (!text) return 0;

  /* start recursion */
  parseSection (&cp, &node, handle) ;

  return node;			/* return root-node */
} /* parseHtmlText */
/************************************************************/

static void skipSpaces (char **cp)
{
  while (**cp && isspace((int)**cp)) { ++(*cp) ; }
} /* skipSpaces */

/************************************************************/

static void replaceEscapeCodes (char *cp)
{
  char *s ;

/*
   quotation mark                       "  --> "    "   --> "
   ampersand                            &  --> &    &    --> &
   less-than sign                       <  --> <    <     --> <
   greater-than sign                    >  --> >    >     --> >
*/
  
  s = cp ;

  while (*s)
    {
      if (strncasecmp (s, """, 5) == 0)
	{
	  s[0] = '"' ; s[1] = 0 ;
	  strcat (s+1, s+5) ;
	}
      else if (strncasecmp (s, "&", 5) == 0)
	{
	  s[0] = '&' ; s[1] = 0 ;
	  strcat (s+1, s+5) ;
	}
      else if (strncasecmp (s, "<", 5) == 0)
	{
	  s[0] = '<' ; s[1] = 0 ;
	  strcat (s+1, s+5) ;
	}
      else if (strncasecmp (s, ">", 5) == 0)
	{
	  s[0] = '>' ; s[1] = 0 ;
	  strcat (s+1, s+5) ;
	}
      else if (strncasecmp (s, """, 6) == 0)
	{
	  s[0] = '"' ; s[1] = 0 ;
	  strcat (s+1, s+6) ;
	}
      else if (strncasecmp (s, "&", 5) == 0)
	{
	  s[0] = '&' ; s[1] = 0 ;
	  strcat (s+1, s+5) ;
	}
      else if (strncasecmp (s, "<", 4) == 0)
	{
	  s[0] = '<' ; s[1] = 0 ;
	  strcat (s+1, s+4) ;
	}
      else if (strncasecmp (s, ">", 4) == 0)
	{
	  s[0] = '>' ; s[1] = 0 ;
	  strcat (s+1, s+4) ;
	}
      else if (strncasecmp (s, " ", 4) == 0)
	{
	  s[0] = ' ' ; s[1] = 0 ;
	  strcat (s+1, s+6) ;
	}

      ++s ;
    }
 
  return ;
} /* replaceEscapeCodes */
/************************************************************/

static HtmlNode *makeNode (HtmlNodeType type, STORE_HANDLE handle)
/* allocate a node and initialise the type */
{
  HtmlNode *newnode ;

  newnode = (HtmlNode*)halloc (sizeof(HtmlNode), handle) ;
  newnode->type = type ;

  return (newnode) ;
} /* makeNode */
/************************************************************/

static BOOL parseHtml (char **cp, HtmlNode **resultnode, STORE_HANDLE handle)
{
  HtmlNode *node, *leftnode ;

  *cp += 6 ;			/* skip  */

  skipSpaces (cp) ;

  node = makeNode (HTML_DOC, handle) ;

  if (!(parseSection (cp, &leftnode, handle)))
    {
      printf ("Warning : text inside  not valid !!\n") ;
    }

  skipSpaces (cp) ;

  if (strncasecmp (*cp, "", 7) == 0)
    {
      *cp += 7 ;
    }
  else
    {
      printf ("Warning :  tag not closed by  !!\n") ;
    }
  
  node->left = leftnode ;
  node->right = 0 ;

  *resultnode = node ;

  return TRUE ;
} /* parseHtml */
/************************************************************/

static BOOL parseHead (char **cp, HtmlNode **resultnode, STORE_HANDLE handle)
{
  HtmlNode *node, *leftnode ;

  *cp += 6 ;			/* skip  */

  skipSpaces (cp) ;

  node = makeNode (HTML_HEAD, handle) ;

  if (!(parseSection (cp, &leftnode, handle)))
    {
      printf ("Warning : HTML inside  not valid !!\n") ;
    }

  skipSpaces (cp) ;

  if (strncasecmp (*cp, "", 7) == 0)
    {
      *cp += 7 ;
    }
  else
    {
      printf ("Warning :  tag not closed by  !!\n") ;
    }
  
  node->left = leftnode ;
  node->right = 0 ;

  *resultnode = node ;

  return TRUE ;
} /* parseHead */
/************************************************************/

static BOOL parseBody (char **cp, HtmlNode **resultnode, STORE_HANDLE handle)
{
  HtmlNode *node, *leftnode ;

  *cp += 6 ;			/* skip  */

  skipSpaces (cp) ;

  node = makeNode (HTML_BODY, handle) ;

  if (!(parseSection (cp, &leftnode, handle)))
    {
      printf ("Warning : HTML inside  not valid !!\n") ;
    }

  skipSpaces (cp) ;

  if (strncasecmp (*cp, "", 7) == 0)
    {
      *cp += 7 ;
    }
  else
    {
      printf ("Warning :  tag not closed by  !!\n") ;
    }
  
  node->left = leftnode ;
  node->right = 0 ;

  *resultnode = node ;

  return TRUE ;
} /* parseBody */
/************************************************************/

static BOOL parseComment (char **cp, HtmlNode **resultnode, STORE_HANDLE handle)
{
  HtmlNode *node ;
  int len ;
  char *start ;

  *cp += 4 ;			/* skip