[Bio] / FigWebServices / das.cgi Repository:
ViewVC logotype

Annotation of /FigWebServices/das.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (view) (download)

1 : olson 1.15 #
2 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
3 :     # for Interpretations of Genomes. All Rights Reserved.
4 :     #
5 :     # This file is part of the SEED Toolkit.
6 :     #
7 :     # The SEED Toolkit is free software. You can redistribute
8 :     # it and/or modify it under the terms of the SEED Toolkit
9 :     # Public License.
10 :     #
11 :     # You should have received a copy of the SEED Toolkit Public License
12 :     # along with this program; if not write to the University of Chicago
13 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
14 :     # Genomes at veronika@thefig.info or download a copy from
15 :     # http://www.theseed.org/LICENSE.TXT.
16 :     #
17 :    
18 : olson 1.2
19 : olson 1.6 use CGI;
20 : olson 1.7 use SproutFIG;
21 : disz 1.1 use FIG;
22 : olson 1.2
23 : olson 1.10 # use Time::Hires;
24 : olson 1.2
25 : disz 1.1 # : das.PLS,v 1.30 2003/12/29 22:41:01 lstein Exp can probably be a reference server too
26 :    
27 :     use strict;
28 :     use File::Basename 'basename';
29 :     use CGI qw/header path_info param url request_method/;
30 :     use Carp;
31 :     use vars qw($DB $DSN $HEADER %ERRCODES $CONFIG $CFG %STYLESHEETS $VERSION $CONF_DIR);
32 :    
33 :     ###################################################################
34 :     # Non-modperl users should change this constant if needed
35 :     #
36 :     $CONF_DIR = '/Users/disz/das.conf';
37 :     #
38 :     ###################################################################
39 :    
40 :     # minimal DAS annotation/reference server
41 :     BEGIN {
42 :     if ($ENV{MOD_PERL}) {
43 :     eval "use Apache::DBI";
44 :     eval "use Apache";
45 :     $CONF_DIR = Apache->server_root_relative(Apache->request->dir_config('DasConfigFile'))
46 :     if Apache->request->dir_config('DasConfigFile');
47 :     }
48 :     }
49 :    
50 :     my $VERSION = 'DAS/1.50';
51 :     use constant CAPABILITIES => join '; ',qw(error-segment/1.0 unknown-segment/1.0 unknown-feature/1.0
52 :     feature-by-id/1.0 group-by-id/1.0 component/1.0 supercomponent/1.0
53 :     dna/1.0 features/1.0 stylesheet/1.0 types/1.0
54 :     entry_points/1.0 dsn/1.0 sequence/1.0
55 :     );
56 :    
57 :     (my $BASENAME = url(-absolute=>1)) =~ s!http://[^/]+/!!;
58 :     %ERRCODES = (
59 :     200 => 'OK',
60 :     400 => 'Bad command',
61 :     401 => 'Bad data source',
62 :     402 => 'Bad command arguments',
63 :     403 => 'Bad reference object',
64 :     404 => 'Bad stylesheet',
65 :     405 => 'Coordinate error',
66 :     500 => 'Internal server error (oops)',
67 :     501 => 'Unimplemented feature',
68 :     );
69 :     read_configuration(\$CONFIG,$CONF_DIR);
70 :     $HEADER = 0;
71 :    
72 : olson 1.2
73 :     #
74 :     # Detect path
75 :     #
76 :    
77 :     my($dsn, $operation);
78 :    
79 : disz 1.5 if (path_info() =~ m,/das/([^/]+)/*([^/]*),)
80 : olson 1.2 {
81 :     $dsn = $1;
82 :     $operation = $2;
83 :     }
84 :     else
85 :     {
86 :     error_header("Invalid URL " . path_info(), 50);
87 :     exit(0);
88 :     }
89 :    
90 :     # my ($junk,$dsn,$operation) = split '/',path_info();
91 : disz 1.1 $DSN = $dsn;
92 :     #print $dsn;
93 :     #$CFG = $CONFIG->{$dsn};
94 :    
95 : olson 1.2
96 :     warn "DAS: dsn=$dsn operation=$operation\n";
97 :     warn " ", path_info(), "\n";
98 :     for my $k (param())
99 :     {
100 : olson 1.6 my @v = param($k);
101 :     warn "$k: @v\n";
102 : olson 1.2 }
103 :    
104 : olson 1.11 my $fig;
105 :     my $use_sprout = 1;
106 : olson 1.7
107 :     $use_sprout = $ENV{USE_SPROUT} if defined $ENV{USE_SPROUT};
108 :     if ($use_sprout)
109 :     {
110 : olson 1.11 $fig = new SproutFIG($FIG_Config::sproutDB, $FIG_Config::sproutData);
111 :     if (!$fig)
112 :     {
113 :     error_header('Could not create SproutFIG from $FIG_Config::sproutDB $FIG_Config::sproutData ', 500);
114 :     exit 0;
115 :     }
116 :     }
117 :     else
118 :     {
119 :     $fig = new FIG();
120 :     if (!$fig)
121 :     {
122 :     error_header('Could not open FIG ', 500);
123 :     exit 0;
124 :     }
125 : olson 1.7 }
126 :    
127 : olson 1.2
128 :     #
129 :     # Load the FIG/DAS configuration file.
130 :     #
131 :    
132 :     our $das = $fig->init_das(get_url(), $dsn);
133 :     #
134 :     # Process requests.
135 :     #
136 :    
137 : disz 1.1 do { error_header('invalid request',400); exit 0 } unless $DSN;
138 :     do { list_dsns($fig); exit 0 } if $dsn eq 'dsn' or $operation eq 'dsn';
139 :     #do { error_header('invalid data source, use the dsn command to get list',401); exit 0 } unless $CFG;
140 :    
141 :     do { entry_points($fig, $dsn); exit 0 } if $operation eq 'entry_points';
142 :     do { types(); exit 0 } if $operation eq 'types';
143 :     do { features($fig, $dsn); exit 0 } if $operation eq 'features';
144 :     do { stylesheet(); exit 0 } if $operation eq 'stylesheet';
145 :     DO { dna($fig, $dsn); exit 0 } if $operation eq 'dna';
146 :    
147 :     error_header('invalid request',400);
148 :     exit 0;
149 :    
150 :     # -----------------------------------------------------------------
151 :     sub list_dsns {
152 : olson 1.2 my $j = ' 'x3;
153 :     my ($fig) = @_;
154 :     ok_header();
155 :     print qq(<?xml version="1.0" standalone="yes"?>\n<!DOCTYPE DASDSN SYSTEM "http://www.biodas.org/dtd/dasdsn.dtd">\n);
156 :     print "<DASDSN>\n";
157 :    
158 :     #for my $dsn (sort keys %$CONFIG) {
159 :     foreach ($fig->genomes("complete")) {
160 :     my $dsn = $_;
161 :     my $genus_species = $fig->genus_species($dsn);
162 :     $genus_species =~ s/</ /;
163 :     $genus_species =~ s/>/ /;
164 :     my $dsn_new = $dsn;
165 : overbeek 1.14 my $url = &FIG::cgi_url(-relative => 1);
166 : disz 1.1
167 : olson 1.2 print "$j<DSN>\n";
168 :     print qq($j$j<SOURCE id="$dsn">$dsn</SOURCE>\n);
169 : disz 1.5 print qq($j$j<MAPMASTER>$url/das.cgi/das/$dsn</MAPMASTER>\n);
170 : olson 1.2 print qq($j$j<DESCRIPTION>$genus_species</DESCRIPTION>\n);
171 :     print "$j</DSN>\n";
172 :     last;
173 :     }
174 :     print "</DASDSN>\n";
175 : disz 1.1 }
176 :    
177 :     # -----------------------------------------------------------------
178 :     sub dna {
179 : olson 1.2 my ($fig, $dsn) = @_;
180 :     my $segments = get_segments();
181 :    
182 :     ok_header();
183 :     print qq(<?xml version="1.0" standalone="yes"?>\n);
184 :     print qq(<!DOCTYPE DASDNA SYSTEM "http://www.wormbase.org/dtd/dasdna.dtd">\n);
185 :     print qq(<DASDNA>\n);
186 :     for my $segment (@$segments) {
187 : olson 1.7 my ($seg_id,$refclass,$start,$stop) = @$segment;
188 :    
189 :     my $reference = $seg_id;
190 :     $reference =~ s/--/:/g;
191 :    
192 : olson 1.2 my $len = $stop - $start + 1;
193 : olson 1.7 my $loc;
194 :     if ($use_sprout)
195 :     {
196 :     $loc = "${reference}_$start+$len";
197 :     }
198 :     else
199 :     {
200 :     $loc = "${reference}_${start}_${stop}";
201 :     }
202 :    
203 :     my $dna = $fig->dna_seq($dsn, $loc);
204 : disz 1.1
205 : olson 1.2 print <<END
206 : disz 1.1 <SEQUENCE id="$reference" start="$start" stop="$stop" version="1.0">
207 :     <DNA length="$len">
208 :     $dna
209 :     </DNA>
210 :     </SEQUENCE>
211 :     END
212 :     }
213 : olson 1.2 print qq(</DASDNA>\n);
214 : disz 1.1 }
215 :    
216 :     # -----------------------------------------------------------------
217 :     sub entry_points {
218 :     my ($fig, $dsn) = @_;
219 :     my $url = get_url();
220 :     ok_header();
221 :     print <<END;
222 :     <?xml version="1.0" standalone="no"?>
223 :     <!DOCTYPE DASEP SYSTEM "http://www.biodas.org/dtd/dasep.dtd">\n
224 :     <DASEP>
225 :     <ENTRY_POINTS href="$url" version="1.0">
226 :     END
227 :     ;
228 :    
229 :     # foreach ($fig->pegs_of("$dsn")) {
230 :     # my $name = $_;
231 :     # my $loc = $fig->feature_location($_);
232 :     # if ($loc =~ /.*_\d+_(\d+)_(\d+)/) {
233 :     # my $st = $1;
234 :     # my $en = $2;
235 :     # my $orientation = "+";
236 :     # if ($2 < $1) {
237 :     # $orientation = "-";
238 :     # $st = $2;
239 :     # $en = $1;
240 :     # }
241 :     # my $length = $en - $st;
242 :     foreach ($fig->all_contigs("$dsn")) {
243 :     my $name = $_;
244 : olson 1.7 $name =~ s,:,--,g;
245 : disz 1.1 my $length = $fig->contig_ln($dsn, $_);
246 :     my $st = 1;
247 :     my $en = $length;
248 :     my $orientation = "+";
249 :     print qq(<SEGMENT id="$name" size="$length" start="$st" stop="$en" orientation="$orientation" subparts="no">$name</SEGMENT>\n);
250 :     }
251 :     print "</ENTRY_POINTS>\n</DASEP>\n";
252 :     }
253 :    
254 :     # -----------------------------------------------------------------
255 :     # get the features for the segment indicated
256 :     sub features {
257 : olson 1.4 my ($fig, $dsn) = @_;
258 :     my @segments = get_segments();
259 :     my @types = param('type');
260 :     my $url = get_url();
261 :    
262 : olson 1.12 my @feature_ids = param('feature_id');
263 :    
264 : olson 1.4 ok_header();
265 : disz 1.1
266 : olson 1.4 print $das->features_header();
267 : disz 1.1
268 : olson 1.4 my $version = "1.0";
269 : olson 1.7
270 :     my %types;
271 :     map { $types{$_}++ } @types;
272 :     @types = keys(%types);
273 : olson 1.12 my $feat_list = $das->features(\@segments, \@types, \@feature_ids);
274 : disz 1.1
275 : olson 1.4 print join("\n", @$feat_list);
276 : disz 1.1
277 : olson 1.4 print $das->features_footer();
278 : disz 1.1 }
279 :    
280 :     sub dump_segment {
281 :     my $seq = shift;
282 :     my $filter = shift;
283 :     my $toplevel = shift;
284 :    
285 :     my $r = $seq->refseq;
286 :     my $s = $seq->start;
287 :     my $e = $seq->stop;
288 :     ($s,$e) = ($e,$s) if $s > $e;
289 :    
290 :     my $version = seq2version($r);
291 :     if ($toplevel) {
292 :     print qq(<SEGMENT id="$r" start="$s" stop="$e" version="$version" />\n);
293 :     return;
294 :     }
295 :     print qq(<SEGMENT id="$r" start="$s" stop="$e" version="$version">\n);
296 :    
297 :     my $iterator = $seq->features(-types=>$filter,-merge=>0,-iterator=>1);
298 :     while (my $f = $iterator->next_seq) {
299 :     my $type = $f->type;
300 :     next if $CFG->{EXCLUDE} && $CFG->{EXCLUDE}{lc $type};
301 :     next if $CFG->{INCLUDE} && !$CFG->{INCLUDE}{lc $type};
302 :    
303 :     my $flabel = $f->info || $f->type;
304 :     my $source = $f->source;
305 :     my $method = $f->method;
306 :     my $start = $f->start;
307 :     my $end = $f->stop;
308 :     my $score = $f->score;
309 :     my $orientation = $f->strand;
310 :     my $phase = $f->phase;
311 :     my $group = $f->group;
312 :     my $gclass = $group->class if $group;
313 :     my $id = $f->id;
314 :     my $fid = $id;
315 :    
316 :     $phase ||= 0;
317 :     $orientation ||= 0;
318 :     $score = '-' unless defined $score;
319 :     $orientation = $orientation >= 0 ? '+' : '-';
320 :    
321 :     my $category = transmute($type);
322 :     ($start,$end) = ($end,$start) if $start > $end;
323 :    
324 :     # group stuff
325 :     my $groupid = "$gclass:$group";
326 :     my @notes;
327 :     my $info = $f->info;
328 :     my ($group_info,$link,$gtype);
329 :    
330 :     if (ref($info)) {
331 :     my $class = $info->class;
332 :     $fid = "$class:$info/$id";
333 :     $id = $info;
334 :     my $url = 'none';
335 :     foreach( 'default', lc($class), lc($type) ) {
336 :     $url = $CFG->{LINKS}{$_} if defined $CFG->{LINKS}{$_};
337 :     }
338 :     if($url ne 'none') {
339 :     $url =~ s/\$name/$info/g;
340 :     $url =~ s/\$class/$class/g;
341 :     $url =~ s/\$type/$type/g;
342 :     $link = qq(<LINK href="$url">$info</LINK>);
343 :     $gtype = qq( type="$class")
344 :     }
345 :     } else {
346 :     $groupid = $group;
347 :     $group_info = join "\n",map {qq(<NOTE>$_</NOTE>)} @notes;
348 :     }
349 :    
350 :     my ($target,$target_info);
351 :     if (($target = $f->target) && $target->can('start')) {
352 :     my $start = $target->start;
353 :     my $stop = $target->stop;
354 :     $target_info = qq(<TARGET id="$target" start="$start" stop="$stop" />);
355 :     }
356 :    
357 :     if ($category eq 'component') {
358 :     my $strt = 1;
359 :     my $stp = $end - $start + 1;
360 :     $target_info = qq(<TARGET id="$id" start="$strt" stop="$stp" />);
361 :     }
362 :    
363 :     my $map;
364 :    
365 :     if ($CFG->{STRUCTURAL}{subparts}{$type} || $CFG->{STRUCTURAL}{superparts}{$type}) {
366 :     $map = qq( reference="yes")
367 :     } else {
368 :     $map = qq()
369 :     }
370 :     $map .= qq( subparts="yes") if $CFG->{STRUCTURAL}{subparts}{$type};
371 :     $map .= qq( superparts="yes") if $CFG->{STRUCTURAL}{superparts}{$type};
372 :    
373 :     print <<END;
374 :     <FEATURE id="$fid" label="$flabel">
375 :     <TYPE id="$type" category="$category"$map>$type</TYPE>
376 :     <METHOD id="$method">$method</METHOD>
377 :     <START>$start</START>
378 :     <END>$end</END>
379 :     <SCORE>$score</SCORE>
380 :     <ORIENTATION>$orientation</ORIENTATION>
381 :     <PHASE>$phase</PHASE>
382 :     END
383 :     ;
384 :     print qq( $link\n) if $link;
385 :     print qq( $target_info\n) if $target_info;
386 :    
387 :     if ($info) {
388 :     $gtype ||= '';
389 :     $groupid ||= '';
390 :     if ($group_info) {
391 :     print qq( <GROUP id="$groupid"$gtype>\n);
392 :     print qq( $group_info\n) if $group_info;
393 :     print qq( </GROUP>\n);
394 :     } else {
395 :     print qq( <GROUP id="$groupid"$gtype />\n);
396 :     }
397 :     }
398 :     print <<END;
399 :     </FEATURE>
400 :     END
401 :     ;
402 :     }
403 :    
404 :     print qq(</SEGMENT>\n);
405 :     }
406 :    
407 :     sub error_segment {
408 :     my ($reference,$start,$stop) = @_;
409 :     my $tag = $CFG->{DSN}{authorative} ? 'ERRORSEGMENT' : 'UNKNOWNSEGMENT';
410 :     my $attributes;
411 :     $attributes .= qq( start="$start") if defined $start;
412 :     $attributes .= qq( stop="$stop") if defined $stop;
413 :     print qq( <$tag id="$reference"$attributes />\n);
414 :     }
415 :    
416 :     sub error_id {
417 :     my $id = shift;
418 :     print qq( <UNKNOWNFEATURE id="$id" />\n);
419 :     }
420 :    
421 :     sub dump_components {
422 :     my ($reference,$refclass,$reqstart,$reqend) = @_;
423 :     my @seq = grep {lc($_->abs_ref) eq lc($reference)} get_segment_obj($reference,$refclass,$reqstart,$reqend);
424 :    
425 :     error_segment($reference,$reqstart,$reqend) unless @seq;
426 :    
427 :     for my $seq (@seq) {
428 :     $seq->absolute(1);
429 :     my $refseq = $seq->refseq;
430 :     my $start = defined $reqstart ? $reqstart : $seq->start;
431 :     my $stop = defined $reqend ? $reqend : $seq->end;
432 :    
433 :     my $component_type = 'superparts';
434 :    
435 :     my @types = keys %{$CFG->{COMPONENTS}{$component_type}} or return;
436 :     my @parts = $seq->contained_features(-type=>\@types,-merge=>0);
437 :     @parts = grep { $_->name ne $refseq } @parts;
438 :     return unless @parts;
439 :    
440 :     my $version = seq2version($refseq);
441 :     print qq(<SEGMENT id="$refseq" start="$start" stop="$stop" version="$version">\n);
442 :    
443 :     for my $part (@parts) {
444 :    
445 :     my $length = $part->length;
446 :     my ($start,$end,$tstart,$tend,$targetid);
447 :    
448 :     ($start,$end) = ($part->start,$part->stop);
449 :     if (my $target = $part->target) {
450 :     ($tstart,$tend) = ($target->start,$target->end);
451 :     } else {
452 :     ($tstart,$tend) = (1,$length);
453 :     }
454 :     $targetid = $part->target;
455 :    
456 :     my $orientation = $part->strand >= 0 ? '+1' : '-1';
457 :     my $type = $part->type;
458 :     my $method = $type->method;
459 :     my $description = qq(category="component" reference="yes");
460 :     $description .= qq( subparts="yes") if $CFG->{COMPONENTS}{subparts}{$type};
461 :     $description .= qq( superparts="yes") if $CFG->{COMPONENTS}{superparts}{$type};
462 :     my $id = $part->info;
463 :    
464 :     if ($tstart > $tend) {
465 :     $orientation = '-1';
466 :     ($tstart,$tend) = ($tend,$tstart);
467 :     }
468 :    
469 :     # avoid giving out information on nonrequested parts
470 :     if (defined($reqstart) && defined($reqend)) {
471 :     next unless $start <= $reqend && $end >= $reqstart;
472 :     }
473 :    
474 :     my $part_id = $part->name;
475 :     print <<END
476 :     <FEATURE id="$id" label="$part_id">
477 :     <TYPE id="$type" $description>$part_id</TYPE>
478 :     <METHOD id="$method">$method</METHOD>
479 :     <START>$start</START>
480 :     <END>$end</END>
481 :     <SCORE>-</SCORE>
482 :     <ORIENTATION>$orientation</ORIENTATION>
483 :     <PHASE>-</PHASE>
484 :     <TARGET id="$targetid" start="$tstart" stop="$tend">$part_id</TARGET>
485 :     </FEATURE>
486 :     END
487 :     ;
488 :     }
489 :     print qq(</SEGMENT>\n);
490 :     }
491 :     }
492 :    
493 :     sub dump_supercomponents {
494 :     my ($reference,$refclass,$reqstart,$reqend) = @_;
495 :     my @seq = get_segment_obj($reference,$refclass,$reqstart,$reqend);
496 :    
497 :     error_segment($reference,$reqstart,$reqend) unless @seq;
498 :    
499 :     for my $seq (@seq) {
500 :    
501 :     $seq->absolute(1);
502 :    
503 :     my @types = keys %{$CFG->{COMPONENTS}{'subparts'}};
504 :     my @parts = $seq->features(-type=>['Supercomponent'],-merge=>0);
505 :    
506 :     for my $part (@parts) {
507 :     my $target = $part->target or next;
508 :    
509 :     $target->can('start') or next;
510 :    
511 :     my $start = defined $reqstart ? $reqstart : $part->start;
512 :     my $stop = defined $reqend ? $reqend : $part->end;
513 :    
514 :     my ($tstart,$tstop) = ($target->start,$target->stop);
515 :     my $version = seq2version($part->name);
516 :    
517 :     print qq(<SEGMENT id="$reference" start="$start" stop="$stop" version="1.0">\n);
518 :     my $end;
519 :     ($start,$end) = ($part->start,$part->end);
520 :    
521 :     my $orientation = '+1';
522 :     my $type = $part->type;
523 :     my $method = $part->method;
524 :    
525 :     $type =~ s/Super//i;
526 :     $type = ucfirst $type;
527 :    
528 :     my $description = qq(category="supercomponent" reference="yes");
529 :     $description .= qq( subparts="yes") if $CFG->{COMPONENTS}{subparts}{$type};
530 :     $description .= qq( superparts="yes") if $CFG->{COMPONENTS}{superparts}{$type};
531 :     my $id = $target;
532 :     my $targetid = $target;
533 :    
534 :     # avoid giving out information on nonrequested parts
535 :     if (defined($reqstart) && defined($reqend)) {
536 :     next unless $start <= $reqend && $end >= $reqstart;
537 :     }
538 :     # flip start and end coordinates of target on negative strands
539 :     ($tstart,$tstop) = ($tstop,$tstart) if $part->strand < 0;
540 :    
541 :     print <<END
542 :     <FEATURE id="$id" label="$id">
543 :     <TYPE id="$type" $description>$part</TYPE>
544 :     <METHOD id="$method">$method</METHOD>
545 :     <START>$start</START>
546 :     <END>$end</END>
547 :     <SCORE>-</SCORE>
548 :     <ORIENTATION>$orientation</ORIENTATION>
549 :     <PHASE>-</PHASE>
550 :     <TARGET id="$id" start="$tstart" stop="$tstop">$id</TARGET>
551 :     </FEATURE>
552 :     END
553 :     ;
554 :     print qq(</SEGMENT>\n);
555 :     }
556 :     }
557 :     }
558 :    
559 :     sub types {
560 :     return all_types();
561 :     return all_types() unless param('ref') or param('segment');
562 :    
563 :     my $summary = param('summary');
564 :     my $url = get_url();
565 :     my @filter = param('type');
566 :    
567 :     my @segments = get_segments() or return;
568 :    
569 :     ok_header();
570 :    
571 :     print <<END;
572 :     <?xml version="1.0" standalone="yes"?>
573 :     <!DOCTYPE DASTYPES SYSTEM "http://www.biodas.org/dtd/dastypes.dtd">
574 :     <DASTYPES>
575 :     <GFF version="1.2" summary="yes" href="$url">
576 :     END
577 :     ;
578 :    
579 :     foreach (@segments) {
580 :     my ($reference,$class,$start,$stop) = @$_;
581 :     next unless $reference;
582 :     my ($seq) = get_segment_obj($reference,$class,$start,$stop) or next;
583 :     unless ($seq) { #empty section
584 :     my $version = seq2version($reference);
585 :     print qq(<SEGMENT id="$reference" start="$start" stop="$stop" version="$version">\n);
586 :     print qq(</SEGMENT>\n);
587 :     next;
588 :     }
589 :    
590 :     my $s = $seq->start;
591 :     my $e = $seq->stop;
592 :    
593 :     # use absolute coordinates -- people expect it
594 :     my $name = $seq->refseq;
595 :    
596 :     my $version = seq2version($name);
597 :     print qq(<SEGMENT id="$name" start="$s" stop="$e" version="$version">\n);
598 :    
599 :     my @args = (-enumerate=>1);
600 :     push @args,(-types=>\@filter) if @filter;
601 :     my %histogram = $seq->types(@args);
602 :     foreach (keys %histogram) {
603 :     next if $CFG->{EXCLUDE} && $CFG->{EXCLUDE}{$_};
604 :     next if $CFG->{INCLUDE} && !$CFG->{INCLUDE}{$_};
605 :     my ($method,$source) = split ':';
606 :     my $count = $histogram{$_};
607 :     my $category = transmute($_);
608 :     print qq(\t<TYPE id="$_" category="$category" method="$method" source="$source">$count</TYPE>\n);
609 :     }
610 :     print qq(</SEGMENT>\n);
611 :     }
612 :     print <<END;
613 :     </GFF>
614 :     </DASTYPES>
615 :     END
616 :     }
617 :    
618 :     # list of all the types
619 :     sub all_types {
620 : olson 1.2 my $url = get_url();
621 :     ok_header();
622 :    
623 :     print $das->types_header();
624 : olson 1.4
625 :     print $das->all_types();
626 :    
627 :     print $das->types_footer();
628 : disz 1.1 }
629 :    
630 :     # Big time kludge -- just outputs the prebuilt stylesheet in this
631 :     # directory. Used primarily for testing.
632 :     sub stylesheet {
633 :     my $stylesheet = read_stylesheet($DSN);
634 :     unless ($stylesheet) {
635 :     error_header('no stylesheet',404);
636 :     exit 0;
637 :     }
638 :    
639 :     ok_header();
640 :     print <<END;
641 :     <?xml version="1.0" standalone="yes"?>
642 :     <!DOCTYPE DASSTYLE SYSTEM "http://www.biodas.org/dtd/dasstyle.dtd">
643 :     <DASSTYLE>
644 :     <STYLESHEET version="1.0">
645 :     END
646 :     ;
647 :     for my $cat (keys %$stylesheet) {
648 :     print qq( <CATEGORY id="$cat">\n);
649 :    
650 :     for my $type (keys %{$stylesheet->{$cat}}) {
651 :     print qq( <TYPE id="$type">\n);
652 :    
653 :     for my $mag (keys %{$stylesheet->{$cat}{$type}}) {
654 :    
655 :     for my $glyph (keys %{$stylesheet->{$cat}{$type}{$mag}}) {
656 :     my $zoom = $mag ? qq( zoom="$mag") : '';
657 :     print qq( <GLYPH$zoom>\n);
658 :     print qq( <\U$glyph\E>\n);
659 :     for my $attribute (keys %{$stylesheet->{$cat}{$type}{$mag}{$glyph}}) {
660 :     next if $attribute eq 'glyph';
661 :     print qq( <\U$attribute\E>$stylesheet->{$cat}{$type}{$mag}{$glyph}{$attribute}<\U/$attribute\E>\n) unless $attribute eq 'glyph';
662 :     }
663 :     print qq( </\U$glyph\E>\n);
664 :     print qq( </GLYPH>\n);
665 :     }
666 :    
667 :     }
668 :    
669 :     print qq( </TYPE>\n);
670 :     }
671 :    
672 :     print qq( </CATEGORY>\n);
673 :     }
674 :    
675 :     print <<END;
676 :     </STYLESHEET>
677 :     </DASSTYLE>
678 :     END
679 :     ;
680 :     }
681 :    
682 :     # calculate type and category from acedb type and method
683 :     sub transmute {
684 :     my $type = shift;
685 :    
686 :     # look in $TYPE2CATEGORY first to see if we have an exact match
687 :     my $category = $CFG->{TYPE2CATEGRY}{$type};
688 :     return $category if $category;
689 :    
690 :     # otherwise do a fuzzy match using the values of %{$CFG->{TYPEOBJECTS}}
691 :     for my $typeobj (values %{$CFG->{TYPEOBJECTS}}) {
692 :    
693 :     if ($typeobj->match($type)) {
694 :     $category = $CFG->{TYPE2CATEGORY}{$typeobj}; # fetch category for this object
695 :     $CFG->{TYPE2CATEGORY}{$type} = $category; # remember this match for later
696 :     return $category;
697 :     }
698 :     }
699 :     return 'miscellaneous'; # no success
700 :     }
701 :    
702 :     # -----------------------------------------------------------------
703 :     sub get_url {
704 :     my $url = url(-path=>1, -query=>1);
705 :     $url =~ tr/&/\;/;
706 :     return $url;
707 :     }
708 :    
709 :     sub seq2version {
710 :     my $seqname = shift;
711 :     return $seqname =~ /\.(\d+)$/ ? $1 : '1.0';
712 :     }
713 :    
714 :     # -----------------------------------------------------------------
715 :     sub error_header {
716 :     my ($message,$code) = @_;
717 :     $code ||= 500;
718 :     print header(-type =>'text/plain',
719 :     -X_DAS_Version => $VERSION,
720 :     -X_DAS_Status => $code,
721 :     -X_DAS_Capabilities => CAPABILITIES,
722 :     ) unless $HEADER++;
723 :     return if request_method() eq 'HEAD';
724 :     print $message;
725 :     }
726 :    
727 :     sub ok_header {
728 :     print header(-type =>'text/plain',
729 :     -X_DAS_Version => $VERSION,
730 :     -X_DAS_Status => "200",
731 :     -X_DAS_Capabilities => CAPABILITIES,
732 :     ) unless $HEADER++;
733 :     }
734 :    
735 :     # phony dtd
736 :     sub dtd {
737 :     ok_header();
738 :     print <<DTD;
739 :     <!-- phony dtd for debugging parsers -->
740 :     DTD
741 :     }
742 :    
743 :     # -----------------------------------------------------------------
744 :     sub get_segments {
745 :     # extended segment argument
746 :     my @segments;
747 :     foreach (param('segment')) {
748 :     my ($ref,$start,$stop) = /^(\S+?)(?::(\d+),(\d+))?$/;
749 :     push @segments,[$ref,$start,$stop];
750 :     }
751 :     push @segments,[scalar param('ref'),scalar param('start'),scalar param('stop')] if param('ref');
752 :     return unless @segments;
753 :    
754 :     foreach (@segments){
755 :     my ($reference,$start,$stop) = @$_;
756 :     my $class = param('entry_type') || 'Sequence';
757 :     my $name = $reference;
758 :    
759 :     if ($reference =~ /^(\w+):(\S+)$/) {
760 :     $class = $1;
761 :     $name = $2;
762 :     }
763 :     my @values = ($name,$class,$start,$stop);
764 :     $_ = \@values;
765 :     }
766 :    
767 :     return wantarray ? @segments : \@segments;
768 :     }
769 :    
770 :     # -----------------------------------------------------------------
771 :     sub get_feature_obj {
772 :     my $id = shift;
773 :     if ($id =~ m!^(.+)/(\d+)$!) {
774 :     return $DB->fetch_feature_by_id($2);
775 :     } elsif ($id =~ /^(\w+):(\S+)$/) {
776 :     return $DB->segments($1 => $2);
777 :     } else {
778 :     return $DB->segments($id);
779 :     }
780 :     }
781 :    
782 :     # -----------------------------------------------------------------
783 :     sub get_segment_obj {
784 :     my ($reference,$class,$start,$stop,$as_feature) = @_;
785 :     my @args = (-name=>$reference);
786 :     push @args,(-class=>$class) if defined $class;
787 :     push @args,(-start=>$start) if defined $start;
788 :     push @args,(-stop=>$stop) if defined $stop;
789 :    
790 :    
791 :     # the "feature" flag is used when we are looking for supercomponents
792 :     # and we want to fetch the segment as a feature object so as to find its parent
793 :     if ($as_feature) {
794 :     my @segments = $DB->fetch_feature(@args);
795 :     warn $DB->error unless @segments;
796 :     @segments;
797 :     }
798 :    
799 :     else {
800 :     my @segments = $DB->segment(@args);
801 :     warn $DB->error unless @segments ;
802 :     my @s = grep {$_->abs_ref eq $reference} @segments;
803 :     return @s if @s;
804 :     return @segments;
805 :     }
806 :     }
807 :    
808 :    
809 :     # -----------------------------------------------------------------
810 :     sub make_categories {
811 :     my @filter;
812 :     for my $category (@_) {
813 :     my $c = lc $category;
814 :     push @filter,@{$CFG->{CATEGORIES}{$c}} if $CFG->{CATEGORIES}{$c};
815 :     push @filter,$category unless $CFG->{CATEGORIES}{$c};
816 :     }
817 :     return @filter;
818 :     }
819 :    
820 :     ##################################################################################################
821 :     # configuration file reading code
822 :     ##################################################################################################
823 :    
824 :     sub read_configuration {
825 :     my $conf_ref = shift;
826 :     my $conf_dir = shift;
827 :    
828 : olson 1.9 my $config = $$conf_ref ||= {};
829 :    
830 :     my @conf_files;
831 : disz 1.1
832 : olson 1.9 if (-d $conf_dir)
833 :     {
834 :     opendir(D,$conf_dir) or &das_die( "Couldn't open $conf_dir: $!", "Couldn't open Config directory" );
835 : disz 1.1
836 : olson 1.9 @conf_files = map { "$conf_dir/$_" }readdir(D);
837 :     close D;
838 :     }
839 : disz 1.1
840 :     # try to work around a bug in Apache/mod_perl which takes effect when
841 :     # using glibc 2.2.1
842 :     unless (@conf_files) {
843 :     @conf_files = glob("$conf_dir/*.conf");
844 :     }
845 :    
846 :     foreach (@conf_files) {
847 :     next unless /\.conf$/;
848 :     my $basename = basename($_,'.conf');
849 :     next if $config->{$basename} && $config->{$basename}{mtime} >= (stat($_))[9];
850 :    
851 :     my $conf = read_configfile($_) or next;
852 :     $config->{$basename} = $conf;
853 :     }
854 :     }
855 :    
856 :     sub read_configfile {
857 :     my $file = shift;
858 :     my (%c,$current_section,$current_tag);
859 :    
860 :     open (F,$file) or &das_die( "Can't open configuration file $file: $!", "Can't open configuration file" );
861 :     while (<F>) {
862 :     chomp;
863 :     next if /^\#/; # ignore comments
864 :    
865 :     if (/^\s*\[([^\]]+)\]/) { # beginning of a configuration section
866 :     $current_section = lc($1);
867 :     next;
868 :     }
869 :    
870 :     if (/^([-+\w:]+)\s*=\s*(.+)/ && $current_section) { # key value pair within a configuration section
871 :     my $tag = lc $1;
872 :     my $value = $2;
873 :     $c{$current_section}{$tag} = $2;
874 :     $current_tag = $tag;
875 :     next;
876 :     }
877 :    
878 :     if (/^\s+(.+)/ && $current_tag) { # continuation line
879 :     my $value = $1;
880 :     $c{$current_section}{$current_tag} .= ' ' . $value;
881 :     next;
882 :     }
883 :    
884 :     if (/^(\S.+)/ && $current_section) { # valueless tag
885 :     $c{$current_section}{$1}++;
886 :     next;
887 :     }
888 :     }
889 :     close F;
890 :    
891 :     # Now rearrange and error-check the sections
892 :     my %config;
893 :    
894 :     my $dsn = $c{'data source'};
895 :     unless ($dsn) {
896 :     warn "No [data source] section in configuration file\n";
897 :     return;
898 :     }
899 :     $config{DSN}{description} = $dsn->{description} or &das_die( "No description field in [data source] section" );
900 :     $config{DSN}{adaptor} = $dsn->{adaptor} || 'dbi::mysqlopt';
901 :     $config{DSN}{authoritative} = $dsn->{authoritative};
902 :     $config{DSN}{fasta} = $dsn->{fasta_files};
903 :     $config{DSN}{user} = $dsn->{user};
904 :     $config{DSN}{passwd} = $dsn->{passwd};
905 :     $config{DSN}{database} = $dsn->{database} or &das_die( "No database field in [data source] section" );
906 :     $config{DSN}{mapmaster} = $dsn->{mapmaster} or &das_die( "No mapmaster field in [data source] section" );
907 :    
908 :     # get the type and category information
909 :     my $types = $c{categories} or &das_die( "No [categories] section in configuration file" );
910 :     for my $category (keys %{$types}) {
911 :     my @types = split /\s+/,$types->{$category};
912 :    
913 :     # from category to list of types
914 :     $config{CATEGORIES}{$category} = \@types;
915 :    
916 :     # from types to list of categories
917 :     for my $typename (@types) {
918 :     #my $typeobj = Bio::DB::GFF::Typename->new($typename);
919 :     #$config{TYPE2CATEGORY}{$typeobj} = $category;
920 :     #$config{TYPEOBJECTS}{$typeobj} = $typeobj;
921 :     }
922 :     }
923 :     # hard-code Component and Supercomponent
924 :     foreach ('Component','Supercomponent') {
925 :     #my $typeobj = Bio::DB::GFF::Typename->new($_);
926 :     #$config{TYPE2CATEGORY}{$typeobj} = 'structural';
927 :     #$config{TYPEOBJECTS}{$typeobj} = $typeobj;
928 :     }
929 :    
930 :     # entry points to fetch
931 :     $c{components}{entry_points} ||= 'entry_point';
932 :     $config{ENTRY_POINTS} = [ split /\s+/,$c{components}{entry_points}];
933 :    
934 :     # included features
935 :     $config{INCLUDE} = { map {$_=>1}
936 :     split /\s+/,$c{filter}{include} } if $c{filter}{include} =~ /\S/;
937 :    
938 :     # excluded features
939 :     $config{EXCLUDE} = { map {$_=>1}
940 :     split /\s+/,$c{filter}{exclude} } if $c{filter}{exclude} =~ /\S/;
941 :    
942 :     # structural information
943 :     $config{COMPONENTS}{subparts} = { map {("Component:$_" =>1)} split /\s+/,$c{components}{has_subparts} };
944 :     $config{COMPONENTS}{superparts} = { map {("Supercomponent:$_"=>1)} split /\s+/,$c{components}{has_superparts} };
945 :    
946 :     # links
947 :     $config{LINKS} = $c{links};
948 :    
949 :     return \%config;
950 :     }
951 :    
952 :     #################################### style sheet reading ####################
953 :     sub read_stylesheet {
954 :     my $dsn = shift;
955 :     foreach my $f ( $dsn, 'default' ) {
956 :     unless( exists $STYLESHEETS{$f}) {
957 :     $STYLESHEETS{$f} = eval { parse_stylesheet("$CONF_DIR/$f.style"); };
958 :     }
959 :     return $STYLESHEETS{$f} if $STYLESHEETS{$f};
960 :     }
961 :     return undef;
962 :     }
963 :    
964 :     sub parse_stylesheet {
965 :     my $file = shift;
966 :     open F,$file or die "Can't open stylesheet $file";
967 :    
968 :     my (%c,$current_section,$current_magnification,$current_tag);
969 :     while (<F>) {
970 :     chomp;
971 :     next if /^\#/; # ignore comments
972 :    
973 :     if (/^\s*\[([^\]]+)\]/) { # beginning of a configuration section
974 :     $current_section = $1;
975 :     $current_magnification = ($current_section =~ s/^(.+):(low|high|med)$/$1/i) ? $2 : '';
976 :     next;
977 :     }
978 :    
979 :     if (/^([-+\w:]+)\s*=\s*(.+)/ && $current_section) { # key value pair within a configuration section
980 :     my $tag = $1;
981 :     my $value = $2;
982 :     $c{$current_section}{$current_magnification}{$tag} = $2;
983 :     $current_tag = $tag;
984 :     next;
985 :     }
986 :    
987 :     if (/^\s+(.+)/ && $current_tag) { # continuation line
988 :     my $value = $1;
989 :     $c{$current_section}{$current_tag} .= ' ' . $value;
990 :     next;
991 :     }
992 :    
993 :     }
994 :     close F;
995 :    
996 :     # reorganize according to the category structure
997 :     my %style;
998 :     my $default_glyph = $c{default}{''}{glyph};
999 :     my @categories = keys( %{$CFG->{CATEGORIES}} );
1000 :     for my $cat (@categories) {
1001 :     my @types = @{$CFG->{CATEGORIES}{$cat}};
1002 :     for my $type (@types,$cat) {
1003 :     # $type = lc($type);
1004 :     next unless $c{$type};
1005 :     my $t = $type eq $cat ? 'default' : $type;
1006 :    
1007 :     for my $mag (keys %{$c{$type}}) {
1008 :     my $glyph = $c{$type}{$mag}{glyph} || $default_glyph || 'box';
1009 :    
1010 :     for my $att (keys %{$c{$type}{$mag}}) {
1011 :     $style{$cat}{$t}{$mag}{$glyph}{$att} = $c{$type}{$mag}{$att};
1012 :     }
1013 :    
1014 :     }
1015 :     }
1016 :     }
1017 :    
1018 :     return \%style;
1019 :     }
1020 :    
1021 :     sub das_die { my $message = shift; my $message2 = shift;
1022 :     warn $message;
1023 :     do { error_header("Configuration error: ".($message2||$message),500); exit 0 }
1024 :     }
1025 :    

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3