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

View of /FigWebServices/das.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (download) (annotate)
Mon Dec 5 19:12:12 2005 UTC (13 years, 11 months ago) by olson
Branch: MAIN
CVS Tags: mgrast_dev_08112011, rast_rel_2009_05_18, mgrast_dev_08022011, rast_rel_2014_0912, rast_rel_2008_06_18, myrast_rel40, rast_rel_2008_06_16, mgrast_dev_05262011, rast_rel_2008_12_18, mgrast_dev_04082011, rast_rel_2008_07_21, rast_rel_2010_0928, rast_2008_0924, mgrast_version_3_2, mgrast_dev_12152011, rast_rel_2008_04_23, mgrast_dev_06072011, rast_rel_2008_09_30, rast_rel_2009_0925, rast_rel_2010_0526, rast_rel_2014_0729, mgrast_dev_02212011, rast_rel_2010_1206, caBIG-05Apr06-00, mgrast_release_3_0, mgrast_dev_03252011, rast_rel_2010_0118, mgrast_rel_2008_0924, mgrast_rel_2008_1110_v2, rast_rel_2009_02_05, rast_rel_2011_0119, mgrast_rel_2008_0625, mgrast_release_3_0_4, mgrast_release_3_0_2, mgrast_release_3_0_3, mgrast_release_3_0_1, mgrast_dev_03312011, mgrast_release_3_1_2, mgrast_release_3_1_1, mgrast_release_3_1_0, mgrast_dev_04132011, rast_rel_2008_10_09, mgrast_dev_04012011, rast_release_2008_09_29, mgrast_rel_2008_0806, mgrast_rel_2008_0923, mgrast_rel_2008_0919, rast_rel_2009_07_09, rast_rel_2010_0827, mgrast_rel_2008_1110, myrast_33, rast_rel_2011_0928, rast_rel_2008_09_29, mgrast_rel_2008_0917, rast_rel_2008_10_29, mgrast_dev_04052011, mgrast_dev_02222011, caBIG-13Feb06-00, rast_rel_2009_03_26, mgrast_dev_10262011, rast_rel_2008_11_24, rast_rel_2008_08_07, HEAD
Changes since 1.14: +17 -0 lines
add license words

#
# Copyright (c) 2003-2006 University of Chicago and Fellowship
# for Interpretations of Genomes. All Rights Reserved.
#
# This file is part of the SEED Toolkit.
# 
# The SEED Toolkit is free software. You can redistribute
# it and/or modify it under the terms of the SEED Toolkit
# Public License. 
#
# You should have received a copy of the SEED Toolkit Public License
# along with this program; if not write to the University of Chicago
# at info@ci.uchicago.edu or the Fellowship for Interpretation of
# Genomes at veronika@thefig.info or download a copy from
# http://www.theseed.org/LICENSE.TXT.
#


use CGI;
use SproutFIG;
use FIG;

# use Time::Hires;

# : das.PLS,v 1.30 2003/12/29 22:41:01 lstein Exp  can probably be a reference server too

use strict;
use File::Basename 'basename';
use CGI qw/header path_info param url request_method/;
use Carp;
use vars qw($DB $DSN $HEADER %ERRCODES $CONFIG $CFG %STYLESHEETS $VERSION $CONF_DIR);

###################################################################
# Non-modperl users should change this constant if needed
#
$CONF_DIR = '/Users/disz/das.conf';
#
###################################################################

# minimal DAS annotation/reference server
BEGIN {
  if ($ENV{MOD_PERL}) {
    eval "use Apache::DBI";
    eval "use Apache";
    $CONF_DIR = Apache->server_root_relative(Apache->request->dir_config('DasConfigFile'))
      if Apache->request->dir_config('DasConfigFile');
  }
}

my $VERSION = 'DAS/1.50';
use constant CAPABILITIES => join '; ',qw(error-segment/1.0 unknown-segment/1.0 unknown-feature/1.0
					  feature-by-id/1.0 group-by-id/1.0 component/1.0 supercomponent/1.0
                                          dna/1.0 features/1.0 stylesheet/1.0 types/1.0
                                          entry_points/1.0 dsn/1.0 sequence/1.0
                                          );

(my $BASENAME = url(-absolute=>1)) =~ s!http://[^/]+/!!;
%ERRCODES = (
	     200 => 'OK',
	     400 => 'Bad command',
	     401 => 'Bad data source',
	     402 => 'Bad command arguments',
	     403 => 'Bad reference object',
	     404 => 'Bad stylesheet',
	     405 => 'Coordinate error',
	     500 => 'Internal server error (oops)',
	     501 => 'Unimplemented feature',
	     );
read_configuration(\$CONFIG,$CONF_DIR);
$HEADER = 0;


#
# Detect path
#

my($dsn, $operation);

if (path_info() =~ m,/das/([^/]+)/*([^/]*),)
{
    $dsn = $1;
    $operation = $2;
}
else
{
    error_header("Invalid URL " . path_info(), 50);
    exit(0);
}

# my ($junk,$dsn,$operation) = split '/',path_info();
$DSN = $dsn;
#print $dsn;
#$CFG = $CONFIG->{$dsn};


warn "DAS: dsn=$dsn operation=$operation\n";
warn "     ", path_info(), "\n";
for my $k (param())
{
    my @v = param($k);
    warn "$k: @v\n";
}

my $fig;
my $use_sprout = 1;

$use_sprout = $ENV{USE_SPROUT} if defined $ENV{USE_SPROUT};
if ($use_sprout)
{
    $fig = new SproutFIG($FIG_Config::sproutDB, $FIG_Config::sproutData);
    if (!$fig)
    {
	error_header('Could not create SproutFIG from $FIG_Config::sproutDB $FIG_Config::sproutData ', 500);
	exit 0;
    }
}
else
{
    $fig = new FIG();
    if (!$fig)
    {
	error_header('Could not open FIG ', 500);
	exit 0;
    }
}


#
# Load the FIG/DAS configuration file.
#

our $das = $fig->init_das(get_url(), $dsn);
#
# Process requests.
#

do { error_header('invalid request',400); exit 0 } unless $DSN;
do { list_dsns($fig);   exit 0 } if $dsn eq 'dsn' or $operation eq 'dsn';
#do { error_header('invalid data source, use the dsn command to get list',401); exit 0 } unless $CFG;

do { entry_points($fig, $dsn); exit 0 }      if $operation eq 'entry_points';
do { types();        exit 0 }      if $operation eq 'types';
do { features($fig, $dsn);     exit 0 }      if $operation eq 'features';
do { stylesheet();   exit 0 }      if $operation eq 'stylesheet';
DO { dna($fig, $dsn);          exit 0 }      if $operation eq 'dna';

error_header('invalid request',400);
exit 0;

# -----------------------------------------------------------------
sub list_dsns {
    my $j = ' 'x3;
    my ($fig) = @_;
    ok_header();
    print qq(<?xml version="1.0" standalone="yes"?>\n<!DOCTYPE DASDSN SYSTEM "http://www.biodas.org/dtd/dasdsn.dtd">\n);
    print "<DASDSN>\n";
    
    #for my $dsn (sort keys %$CONFIG) {
    foreach ($fig->genomes("complete")) {
	my $dsn = $_;
	my $genus_species = $fig->genus_species($dsn);
	$genus_species =~ s/</ /;
	$genus_species =~ s/>/ /;
	my $dsn_new = $dsn;
	my $url = &FIG::cgi_url(-relative => 1);
	
	print "$j<DSN>\n";
	print qq($j$j<SOURCE id="$dsn">$dsn</SOURCE>\n);
	print qq($j$j<MAPMASTER>$url/das.cgi/das/$dsn</MAPMASTER>\n);
	print qq($j$j<DESCRIPTION>$genus_species</DESCRIPTION>\n);
	print "$j</DSN>\n";
	last;
    }
    print "</DASDSN>\n";
}

# -----------------------------------------------------------------
sub dna {
    my ($fig, $dsn) = @_;
    my $segments = get_segments();
    
    ok_header();
    print qq(<?xml version="1.0" standalone="yes"?>\n);
    print qq(<!DOCTYPE DASDNA SYSTEM "http://www.wormbase.org/dtd/dasdna.dtd">\n);
    print qq(<DASDNA>\n);
    for my $segment (@$segments) {
	my ($seg_id,$refclass,$start,$stop) = @$segment;

	my $reference = $seg_id;
	$reference =~ s/--/:/g;

	my $len = $stop - $start + 1;
	my $loc;
	if ($use_sprout)
	{
	    $loc = "${reference}_$start+$len";
	}
	else
	{
	    $loc = "${reference}_${start}_${stop}";
	}

	my $dna = $fig->dna_seq($dsn, $loc);

	print <<END
<SEQUENCE id="$reference" start="$start" stop="$stop" version="1.0">
<DNA length="$len">
$dna
</DNA>
</SEQUENCE>
END
    }
    print qq(</DASDNA>\n);
}

# -----------------------------------------------------------------
sub entry_points {
  my ($fig, $dsn) = @_;
  my $url = get_url();
  ok_header();
  print <<END;
<?xml version="1.0" standalone="no"?>
<!DOCTYPE DASEP SYSTEM "http://www.biodas.org/dtd/dasep.dtd">\n
<DASEP>
<ENTRY_POINTS href="$url" version="1.0">
END
;

#	foreach ($fig->pegs_of("$dsn")) {
#		my $name = $_;
#		my $loc = $fig->feature_location($_);
#		if ($loc =~ /.*_\d+_(\d+)_(\d+)/) {
#			my $st = $1;
#			my $en = $2;
#			my $orientation = "+";
#			if ($2 < $1) {
#				$orientation = "-";
#				$st = $2;
#				$en = $1;
#			}
#			my $length = $en - $st;
	foreach ($fig->all_contigs("$dsn")) {
		my $name = $_;
		$name =~ s,:,--,g;
		my $length = $fig->contig_ln($dsn, $_);
		my $st = 1;
		my $en = $length;
		my $orientation = "+";	
		print qq(<SEGMENT id="$name" size="$length" start="$st" stop="$en" orientation="$orientation" subparts="no">$name</SEGMENT>\n);
	}
  print "</ENTRY_POINTS>\n</DASEP>\n";
}

# -----------------------------------------------------------------
# get the features for the segment indicated
sub features {
    my ($fig, $dsn) = @_;
    my @segments = get_segments();
    my @types = param('type');
    my $url      = get_url();

    my @feature_ids = param('feature_id');

    ok_header();

    print $das->features_header();

    my $version = "1.0";

    my %types;
    map { $types{$_}++ } @types;
    @types = keys(%types);
    my $feat_list = $das->features(\@segments, \@types, \@feature_ids);

    print join("\n", @$feat_list);

    print $das->features_footer();
}

sub dump_segment {
  my $seq          = shift;
  my $filter       = shift;
  my $toplevel     = shift;

  my $r = $seq->refseq;
  my $s = $seq->start;
  my $e = $seq->stop;
  ($s,$e) = ($e,$s) if $s > $e;

  my $version = seq2version($r);
  if ($toplevel) {
    print qq(<SEGMENT id="$r" start="$s" stop="$e" version="$version" />\n);
    return;
  }
  print qq(<SEGMENT id="$r" start="$s" stop="$e" version="$version">\n);

  my $iterator = $seq->features(-types=>$filter,-merge=>0,-iterator=>1);
  while (my $f = $iterator->next_seq) {
    my $type        = $f->type;
    next if $CFG->{EXCLUDE} && $CFG->{EXCLUDE}{lc $type};
    next if $CFG->{INCLUDE} && !$CFG->{INCLUDE}{lc $type};

    my $flabel      = $f->info || $f->type;
    my $source      = $f->source;
    my $method      = $f->method;
    my $start       = $f->start;
    my $end         = $f->stop;
    my $score       = $f->score;
    my $orientation = $f->strand;
    my $phase       = $f->phase;
    my $group       = $f->group;
    my $gclass      = $group->class if $group;
    my $id          = $f->id;
    my $fid         = $id;
	
    $phase       ||= 0;
    $orientation ||= 0;
    $score       = '-' unless defined $score;
    $orientation = $orientation >= 0 ? '+' : '-';

    my $category = transmute($type);
    ($start,$end) = ($end,$start) if $start > $end;

    # group stuff
    my $groupid       = "$gclass:$group";
    my @notes;
    my $info       = $f->info;
    my ($group_info,$link,$gtype);

    if (ref($info)) {
      my $class = $info->class;
      $fid = "$class:$info/$id";
      $id = $info;
      my $url = 'none';
      foreach( 'default', lc($class), lc($type) ) {
        $url = $CFG->{LINKS}{$_} if defined $CFG->{LINKS}{$_};
      }
      if($url ne 'none') {
	$url =~ s/\$name/$info/g;
	$url =~ s/\$class/$class/g;
	$url =~ s/\$type/$type/g;
	$link = qq(<LINK href="$url">$info</LINK>);
	$gtype = qq( type="$class")
      }
    } else {
      $groupid       = $group;
      $group_info = join "\n",map {qq(<NOTE>$_</NOTE>)} @notes;
    }

    my ($target,$target_info);
    if (($target = $f->target) && $target->can('start')) {
      my $start = $target->start;
      my $stop  = $target->stop;
      $target_info = qq(<TARGET id="$target" start="$start" stop="$stop" />);
    }
	
    if ($category eq 'component') {
      my $strt = 1;
      my $stp  = $end - $start + 1;
      $target_info = qq(<TARGET id="$id" start="$strt" stop="$stp" />);
    }

    my $map;

    if ($CFG->{STRUCTURAL}{subparts}{$type} || $CFG->{STRUCTURAL}{superparts}{$type})  {
      $map = qq( reference="yes")
    } else {
      $map = qq() 
    }
    $map .= qq( subparts="yes")   if $CFG->{STRUCTURAL}{subparts}{$type};
    $map .= qq( superparts="yes") if $CFG->{STRUCTURAL}{superparts}{$type};

    print <<END;
   <FEATURE id="$fid" label="$flabel">
      <TYPE id="$type" category="$category"$map>$type</TYPE>
      <METHOD id="$method">$method</METHOD>
      <START>$start</START>
      <END>$end</END>
      <SCORE>$score</SCORE>
      <ORIENTATION>$orientation</ORIENTATION>
      <PHASE>$phase</PHASE>
END
;
    print qq(      $link\n) if $link;
    print qq(      $target_info\n) if $target_info;

    if ($info) {
	$gtype ||= '';
	$groupid   ||= '';
      if ($group_info) {
	print qq(      <GROUP id="$groupid"$gtype>\n);
	print qq(        $group_info\n)  if $group_info;
	print qq(      </GROUP>\n);
      } else {
	print qq(      <GROUP id="$groupid"$gtype />\n);
      }
    }
    print <<END;
   </FEATURE>
END
    ;
  }

  print qq(</SEGMENT>\n);
}

sub error_segment {
  my ($reference,$start,$stop) = @_;
  my $tag = $CFG->{DSN}{authorative} ? 'ERRORSEGMENT' : 'UNKNOWNSEGMENT';
  my $attributes;
  $attributes .= qq( start="$start") if defined $start;
  $attributes .= qq( stop="$stop")   if defined $stop;
  print qq(    <$tag id="$reference"$attributes />\n);
}

sub error_id {
  my $id = shift;
  print qq(    <UNKNOWNFEATURE id="$id" />\n);
}

sub dump_components {
  my ($reference,$refclass,$reqstart,$reqend) = @_;
  my @seq = grep {lc($_->abs_ref) eq lc($reference)} get_segment_obj($reference,$refclass,$reqstart,$reqend);

  error_segment($reference,$reqstart,$reqend) unless @seq;

  for my $seq (@seq) {
    $seq->absolute(1);
    my $refseq = $seq->refseq;
    my $start = defined $reqstart ? $reqstart : $seq->start;
    my $stop  = defined $reqend   ? $reqend   : $seq->end;

    my $component_type = 'superparts';

    my @types = keys %{$CFG->{COMPONENTS}{$component_type}} or return;
    my @parts = $seq->contained_features(-type=>\@types,-merge=>0);
    @parts    = grep { $_->name ne $refseq } @parts;
    return unless @parts;

    my $version = seq2version($refseq);
    print qq(<SEGMENT id="$refseq" start="$start" stop="$stop" version="$version">\n);

    for my $part (@parts) {

      my $length = $part->length;
      my ($start,$end,$tstart,$tend,$targetid);

      ($start,$end)   =  ($part->start,$part->stop);
      if (my $target = $part->target) {
	($tstart,$tend) =  ($target->start,$target->end);
      } else {
	($tstart,$tend) = (1,$length);
      }
      $targetid = $part->target;

      my $orientation = $part->strand >= 0 ? '+1' : '-1';
      my $type   = $part->type;
      my $method = $type->method;
      my $description = qq(category="component" reference="yes");
      $description .= qq( subparts="yes")   if $CFG->{COMPONENTS}{subparts}{$type};
      $description .= qq( superparts="yes") if $CFG->{COMPONENTS}{superparts}{$type};
      my $id = $part->info;

      if ($tstart > $tend) {
	$orientation = '-1';
	($tstart,$tend) = ($tend,$tstart);
      }

      # avoid giving out information on nonrequested parts
      if (defined($reqstart) && defined($reqend)) {
	next unless $start <= $reqend && $end >= $reqstart;
      }

      my $part_id = $part->name;
    print <<END
   <FEATURE id="$id" label="$part_id">
      <TYPE id="$type" $description>$part_id</TYPE>
      <METHOD id="$method">$method</METHOD>
      <START>$start</START>
      <END>$end</END>
      <SCORE>-</SCORE>
      <ORIENTATION>$orientation</ORIENTATION>
      <PHASE>-</PHASE>
      <TARGET id="$targetid" start="$tstart" stop="$tend">$part_id</TARGET>
   </FEATURE>
END
  ;
    }
    print qq(</SEGMENT>\n);
  }
}

sub dump_supercomponents {
  my ($reference,$refclass,$reqstart,$reqend) = @_;
  my @seq = get_segment_obj($reference,$refclass,$reqstart,$reqend);

  error_segment($reference,$reqstart,$reqend) unless @seq;

  for my $seq (@seq) {

    $seq->absolute(1);

    my @types = keys %{$CFG->{COMPONENTS}{'subparts'}};
    my @parts = $seq->features(-type=>['Supercomponent'],-merge=>0);

    for my $part (@parts) {
      my $target          = $part->target or next;

      $target->can('start') or next;

      my $start = defined $reqstart ? $reqstart : $part->start;
      my $stop   = defined $reqend   ? $reqend  : $part->end;

      my ($tstart,$tstop) = ($target->start,$target->stop);
      my $version = seq2version($part->name);

      print qq(<SEGMENT id="$reference" start="$start" stop="$stop" version="1.0">\n);
      my $end;
      ($start,$end) =  ($part->start,$part->end);

      my $orientation = '+1';
      my $type   = $part->type;
      my $method = $part->method;

      $type =~ s/Super//i;
      $type = ucfirst $type;

      my $description = qq(category="supercomponent" reference="yes");
      $description .= qq( subparts="yes")   if $CFG->{COMPONENTS}{subparts}{$type};
      $description .= qq( superparts="yes") if $CFG->{COMPONENTS}{superparts}{$type};
      my $id       = $target;
      my $targetid = $target;

      # avoid giving out information on nonrequested parts
      if (defined($reqstart) && defined($reqend)) {
	next unless $start <= $reqend && $end >= $reqstart;
      }
      # flip start and end coordinates of target on negative strands
      ($tstart,$tstop) = ($tstop,$tstart) if $part->strand < 0;

      print <<END
   <FEATURE id="$id" label="$id">
      <TYPE id="$type" $description>$part</TYPE>
      <METHOD id="$method">$method</METHOD>
      <START>$start</START>
      <END>$end</END>
      <SCORE>-</SCORE>
      <ORIENTATION>$orientation</ORIENTATION>
      <PHASE>-</PHASE>
      <TARGET id="$id" start="$tstart" stop="$tstop">$id</TARGET>
   </FEATURE>
END
  ;
      print qq(</SEGMENT>\n);
    }
  }
}

sub types {
  return all_types();
  return all_types() unless param('ref') or param('segment');

  my $summary = param('summary');
  my $url     = get_url();
  my @filter  = param('type');

  my @segments = get_segments() or return;

  ok_header();

  print <<END;
<?xml version="1.0" standalone="yes"?>
<!DOCTYPE DASTYPES SYSTEM "http://www.biodas.org/dtd/dastypes.dtd">
<DASTYPES>
<GFF version="1.2" summary="yes" href="$url">
END
;

  foreach (@segments) {
    my ($reference,$class,$start,$stop) = @$_;
    next unless $reference;
    my ($seq) = get_segment_obj($reference,$class,$start,$stop) or next;
    unless ($seq) {  #empty section
      my $version = seq2version($reference);
      print qq(<SEGMENT id="$reference" start="$start" stop="$stop" version="$version">\n);
      print qq(</SEGMENT>\n);
      next;
    }

    my $s = $seq->start;
    my $e = $seq->stop;

    # use absolute coordinates -- people expect it
    my $name = $seq->refseq;

    my $version = seq2version($name);
    print qq(<SEGMENT id="$name" start="$s" stop="$e" version="$version">\n);

    my @args = (-enumerate=>1);
    push @args,(-types=>\@filter) if @filter;
    my %histogram = $seq->types(@args);
    foreach (keys %histogram) {
      next if $CFG->{EXCLUDE} && $CFG->{EXCLUDE}{$_};
      next if $CFG->{INCLUDE} && !$CFG->{INCLUDE}{$_};
      my ($method,$source) = split ':';
      my $count = $histogram{$_};
      my $category  = transmute($_);
      print qq(\t<TYPE id="$_" category="$category" method="$method" source="$source">$count</TYPE>\n);
    }
    print qq(</SEGMENT>\n);
  }
print <<END;
</GFF>
</DASTYPES>
END
}

# list of all the types
sub all_types {
    my $url = get_url();
    ok_header();

    print $das->types_header();
    
    print $das->all_types();
    
    print $das->types_footer();
}

# Big time kludge -- just outputs the prebuilt stylesheet in this
# directory.  Used primarily for testing.
sub stylesheet {
  my $stylesheet = read_stylesheet($DSN);
  unless ($stylesheet) {
    error_header('no stylesheet',404);
    exit 0;
  }

  ok_header();
  print <<END;
<?xml version="1.0" standalone="yes"?>
<!DOCTYPE DASSTYLE SYSTEM "http://www.biodas.org/dtd/dasstyle.dtd">
<DASSTYLE>
<STYLESHEET version="1.0">
END
;
  for my $cat (keys %$stylesheet) {
    print qq(  <CATEGORY id="$cat">\n);

    for my $type (keys %{$stylesheet->{$cat}}) {
      print qq(     <TYPE id="$type">\n);

      for my $mag (keys %{$stylesheet->{$cat}{$type}}) {

	for my $glyph (keys %{$stylesheet->{$cat}{$type}{$mag}}) {
	  my $zoom = $mag ? qq( zoom="$mag") : '';
	  print qq(        <GLYPH$zoom>\n);
	  print qq(           <\U$glyph\E>\n);
	  for my $attribute (keys %{$stylesheet->{$cat}{$type}{$mag}{$glyph}}) {
	    next if $attribute eq 'glyph';
	    print qq(              <\U$attribute\E>$stylesheet->{$cat}{$type}{$mag}{$glyph}{$attribute}<\U/$attribute\E>\n) unless $attribute eq 'glyph';
	  }
	  print qq(           </\U$glyph\E>\n);
	  print qq(        </GLYPH>\n);
	}
	
      }

      print qq(     </TYPE>\n);
    }

    print qq(  </CATEGORY>\n);
  }

  print <<END;
</STYLESHEET>
</DASSTYLE>
END
;
}

# calculate type and category from acedb type and method
sub transmute {
    my $type = shift;

    # look in $TYPE2CATEGORY first to see if we have an exact match
    my $category = $CFG->{TYPE2CATEGRY}{$type};
    return $category if $category;

    # otherwise do a fuzzy match using the values of %{$CFG->{TYPEOBJECTS}}
    for my $typeobj (values %{$CFG->{TYPEOBJECTS}}) {

      if ($typeobj->match($type)) {
	$category = $CFG->{TYPE2CATEGORY}{$typeobj};  # fetch category for this object
	$CFG->{TYPE2CATEGORY}{$type} = $category;     # remember this match for later
	return $category;
      }
    }
    return 'miscellaneous';  # no success
}

# -----------------------------------------------------------------
sub get_url {
  my $url = url(-path=>1, -query=>1);
  $url =~ tr/&/\;/;
  return $url;
}

sub seq2version {
  my $seqname = shift;
  return $seqname =~ /\.(\d+)$/ ? $1 : '1.0';
}

# -----------------------------------------------------------------
sub error_header {
  my ($message,$code) = @_;
  $code ||= 500;
  print header(-type          =>'text/plain',
	       -X_DAS_Version => $VERSION,
	       -X_DAS_Status  => $code,
	       -X_DAS_Capabilities => CAPABILITIES,
	      ) unless $HEADER++;
  return if request_method() eq 'HEAD';
  print $message;
}

sub ok_header {
  print header(-type          =>'text/plain',
	       -X_DAS_Version => $VERSION,
	       -X_DAS_Status  => "200",
	       -X_DAS_Capabilities => CAPABILITIES,
	      ) unless $HEADER++;
}

# phony dtd
sub dtd {
    ok_header();
    print <<DTD;
<!-- phony dtd for debugging parsers -->
DTD
}

# -----------------------------------------------------------------
sub get_segments {
  # extended segment argument
  my @segments;
  foreach (param('segment')) {
    my ($ref,$start,$stop) = /^(\S+?)(?::(\d+),(\d+))?$/;
    push @segments,[$ref,$start,$stop];
  }
  push @segments,[scalar param('ref'),scalar param('start'),scalar param('stop')] if param('ref');
  return unless @segments;

  foreach (@segments){
    my ($reference,$start,$stop) = @$_;
    my $class = param('entry_type') || 'Sequence';
    my $name  = $reference;

    if ($reference =~ /^(\w+):(\S+)$/) {
      $class = $1;
      $name  = $2;
    }
    my @values = ($name,$class,$start,$stop);
    $_ = \@values;
  }

  return wantarray ? @segments : \@segments;
}

# -----------------------------------------------------------------
sub get_feature_obj {
  my $id = shift;
  if ($id =~ m!^(.+)/(\d+)$!) {
    return $DB->fetch_feature_by_id($2);
  } elsif ($id =~ /^(\w+):(\S+)$/) {
    return $DB->segments($1 => $2);
  }  else {
    return $DB->segments($id);
  }
}

# -----------------------------------------------------------------
sub get_segment_obj {
  my ($reference,$class,$start,$stop,$as_feature) = @_;
  my @args = (-name=>$reference);
  push @args,(-class=>$class) if defined $class;
  push @args,(-start=>$start) if defined $start;
  push @args,(-stop=>$stop)   if defined $stop;


  # the "feature" flag is used when we are looking for supercomponents
  # and we want to fetch the segment as a feature object so as to find its parent
  if ($as_feature) {
    my @segments = $DB->fetch_feature(@args);
    warn $DB->error unless @segments;
    @segments;
  }

  else {
    my @segments = $DB->segment(@args);
    warn $DB->error unless @segments ;
    my @s = grep {$_->abs_ref eq $reference} @segments;
    return @s if @s;
    return @segments;
  }
}


# -----------------------------------------------------------------
sub make_categories {
  my @filter;
  for my $category (@_) {
    my $c = lc $category;
    push @filter,@{$CFG->{CATEGORIES}{$c}} if $CFG->{CATEGORIES}{$c};
    push @filter,$category            unless  $CFG->{CATEGORIES}{$c};
  }
  return @filter;
}

##################################################################################################
# configuration file reading code
##################################################################################################

sub read_configuration {
  my $conf_ref = shift;
  my $conf_dir = shift;

  my $config = $$conf_ref ||= {};

  my @conf_files;

  if (-d $conf_dir)
  {
      opendir(D,$conf_dir) or &das_die( "Couldn't open $conf_dir: $!", "Couldn't open Config directory" );

      @conf_files = map { "$conf_dir/$_" }readdir(D);
      close D;
  }

  # try to work around a bug in Apache/mod_perl which takes effect when
  # using glibc 2.2.1
  unless (@conf_files) {
    @conf_files = glob("$conf_dir/*.conf");
  }

  foreach (@conf_files) {
    next unless /\.conf$/;
    my $basename = basename($_,'.conf');
    next if $config->{$basename} && $config->{$basename}{mtime} >= (stat($_))[9];

    my $conf   = read_configfile($_) or next;
    $config->{$basename} = $conf;
  }
}

sub read_configfile {
  my $file = shift;
  my (%c,$current_section,$current_tag);

  open (F,$file) or &das_die( "Can't open configuration file $file: $!", "Can't open configuration file" );
  while (<F>) {
    chomp;
    next if /^\#/;  # ignore comments

    if (/^\s*\[([^\]]+)\]/) {  # beginning of a configuration section
      $current_section = lc($1);
      next;
    }

    if (/^([-+\w:]+)\s*=\s*(.+)/ && $current_section) {   # key value pair within a configuration section
      my $tag = lc $1;
      my $value = $2;
      $c{$current_section}{$tag} = $2;
      $current_tag = $tag;
      next;
    }

    if (/^\s+(.+)/ && $current_tag) { # continuation line
      my $value = $1;
      $c{$current_section}{$current_tag} .= ' ' . $value;
      next;
    }

    if (/^(\S.+)/ && $current_section) { # valueless tag
      $c{$current_section}{$1}++;
      next;
    }
  }
  close F;

  # Now rearrange and error-check the sections
  my %config;

  my $dsn = $c{'data source'};
  unless ($dsn) {
    warn "No [data source] section in configuration file\n";
    return;
  }
  $config{DSN}{description}   = $dsn->{description} or &das_die( "No description field in [data source] section" );
  $config{DSN}{adaptor}       = $dsn->{adaptor} || 'dbi::mysqlopt';
  $config{DSN}{authoritative} = $dsn->{authoritative};
  $config{DSN}{fasta}         = $dsn->{fasta_files};
  $config{DSN}{user}          = $dsn->{user};
  $config{DSN}{passwd}        = $dsn->{passwd};
  $config{DSN}{database}      = $dsn->{database}  or &das_die( "No database field in [data source] section" );
  $config{DSN}{mapmaster}     = $dsn->{mapmaster} or &das_die( "No mapmaster field in [data source] section" );

  # get the type and category information
  my $types = $c{categories} or &das_die( "No [categories] section in configuration file" );
  for my $category (keys %{$types}) {
    my @types = split /\s+/,$types->{$category};

    # from category to list of types
    $config{CATEGORIES}{$category} = \@types;

    # from types to list of categories
    for my $typename (@types) {
      #my $typeobj      = Bio::DB::GFF::Typename->new($typename);
      #$config{TYPE2CATEGORY}{$typeobj} = $category;
      #$config{TYPEOBJECTS}{$typeobj}   = $typeobj;
    }
  }
  # hard-code Component and Supercomponent
  foreach ('Component','Supercomponent') {
    #my $typeobj      = Bio::DB::GFF::Typename->new($_);
    #$config{TYPE2CATEGORY}{$typeobj} = 'structural';
    #$config{TYPEOBJECTS}{$typeobj}   = $typeobj;
  }

  # entry points to fetch
  $c{components}{entry_points} ||= 'entry_point';
  $config{ENTRY_POINTS}   = [ split /\s+/,$c{components}{entry_points}];

  # included features
  $config{INCLUDE} = { map {$_=>1} 
		       split /\s+/,$c{filter}{include} } if $c{filter}{include} =~ /\S/;

  # excluded features
  $config{EXCLUDE} = { map {$_=>1} 
		       split /\s+/,$c{filter}{exclude} } if $c{filter}{exclude} =~ /\S/;

  # structural information
  $config{COMPONENTS}{subparts}    =  { map {("Component:$_"     =>1)} split /\s+/,$c{components}{has_subparts} };
  $config{COMPONENTS}{superparts}  =  { map {("Supercomponent:$_"=>1)} split /\s+/,$c{components}{has_superparts} };

  # links
  $config{LINKS} = $c{links};

  return \%config;
}

#################################### style sheet reading ####################
sub read_stylesheet {
  my $dsn = shift;
  foreach my $f ( $dsn, 'default' ) {
    unless( exists $STYLESHEETS{$f}) {
      $STYLESHEETS{$f} = eval { parse_stylesheet("$CONF_DIR/$f.style"); };
    }
    return $STYLESHEETS{$f} if $STYLESHEETS{$f};
  }
  return undef;
}

sub parse_stylesheet {
  my $file = shift;
  open F,$file or die "Can't open stylesheet $file"; 

  my (%c,$current_section,$current_magnification,$current_tag);
  while (<F>) {
    chomp;
    next if /^\#/;  # ignore comments

    if (/^\s*\[([^\]]+)\]/) {  # beginning of a configuration section
      $current_section = $1;
      $current_magnification = ($current_section =~ s/^(.+):(low|high|med)$/$1/i) ? $2 : '';
      next;
    }

    if (/^([-+\w:]+)\s*=\s*(.+)/ && $current_section) {   # key value pair within a configuration section
      my $tag = $1;
      my $value = $2;
      $c{$current_section}{$current_magnification}{$tag} = $2;
      $current_tag = $tag;
      next;
    }

    if (/^\s+(.+)/ && $current_tag) { # continuation line
      my $value = $1;
      $c{$current_section}{$current_tag} .= ' ' . $value;
      next;
    }

  }
  close F;

  # reorganize according to the category structure
  my %style;
  my $default_glyph = $c{default}{''}{glyph};
  my @categories = keys( %{$CFG->{CATEGORIES}} );
  for my $cat (@categories) {
    my @types = @{$CFG->{CATEGORIES}{$cat}};
    for my $type (@types,$cat) {
      # $type = lc($type);
      next unless $c{$type};
      my $t = $type eq $cat ? 'default' : $type;

    for my $mag (keys %{$c{$type}}) {
	my $glyph = $c{$type}{$mag}{glyph} || $default_glyph || 'box';

	for my $att (keys %{$c{$type}{$mag}}) {
	  $style{$cat}{$t}{$mag}{$glyph}{$att} = $c{$type}{$mag}{$att};
	}

      }
    }
  }

  return \%style;
}

sub das_die { my $message = shift; my $message2 = shift;
  warn $message;
  do { error_header("Configuration error: ".($message2||$message),500); exit 0 } 
}


MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3