#!/usr/bin/perl -w

###################################################################
# Non-modperl users should change this variable if needed to point
# to the directory in which the configuration files are stored.
#
use CXGN::VHost;
use CXGN::Tools::Identifiers qw/link_identifier/;
my $vhost_conf=CXGN::VHost->new();
$CONF_DIR  = $vhost_conf->get_conf('basepath')."/conf/gbrowse.conf";
#
###################################################################
$VERSION   = 1.68;

#$Id: das.PLS,v 1.6.8.1.2.4 2007/03/23 17:02:00 lstein Exp $

use Bio::DB::GFF;
use File::Basename 'basename';
use CGI qw/header path_info param url request_method escapeHTML/ ;
use Carp;
use Bio::Graphics::Browser;
use Bio::Graphics::Browser::Util;
use Text::Shellwords;
use vars qw($DB $DSN $HEADER %ERRCODES $CONFIG
            $VERSION $DAS_VERSION $CONF_DIR 
            %CACHED_TYPES %FORCED_GROUP %NO_PARENT);

#$Id: das.PLS,v 1.6.8.1.2.4 2007/03/23 17:02:00 lstein Exp $ das.PLS,v 1.32 2004/01/02 14:52:15 lstein Exp  can probably be a reference server too

# minimal DAS annotation/reference server
$DAS_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',
	     );
$CONFIG = open_config($CONF_DIR) or error_header('Could not read config files'=> 500);
$HEADER = 0;
%FORCED_GROUP = ();
%NO_PARENT    = ();

my ($junk,$dsn,$operation) = split '/',path_info();
$DSN = $dsn;
$operation ||= '';
my %sources = map {$_=>1} $CONFIG->sources;

do { error_header('please append a command such as /types, to this URL',400); exit 0 } unless $DSN;
do { list_dsns();   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 $sources{$DSN};
$CONFIG->source($DSN);

do { error_header('Could not open database',500); exit 0 }
     unless $DB = open_database();

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

error_header('invalid request; please append a command such as /types to this URL',400);
exit 0;

# -----------------------------------------------------------------
sub list_dsns {
  my $j = ' 'x3;
  ok_header();
  print qq(<?xml version="1.0" standalone="yes"?>\n<!DOCTYPE DASDSN SYSTEM "http://www.biodas.org/dtd/dasdsn.dtd">\n);
  my $self_url = url(-full=>1);
  $self_url    =~ s/dsn.*$//;

  print "<DASDSN>\n";

  for my $dsn (sort $CONFIG->sources) {
    my $old_source = $CONFIG->source($dsn);
    if (my $mapmaster = $CONFIG->setting('das mapmaster')) {
      $mapmaster = "$self_url/$dsn" if $mapmaster eq 'SELF';
      print "$j<DSN>\n";
      print qq($j$j<SOURCE id="$dsn">$dsn</SOURCE>\n);
      print qq($j$j<MAPMASTER>),$mapmaster,qq(</MAPMASTER>\n);
      print qq($j$j<DESCRIPTION>),$CONFIG->description($dsn),qq(</DESCRIPTION>\n);
      print "$j</DSN>\n";
    }
    $CONFIG->source($old_source);
  }
  print "</DASDSN>\n";
}

# -----------------------------------------------------------------
sub dna {
  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 ($reference,$refclass,$start,$stop) = @$segment;
    my @seq = get_segment_obj($reference,$refclass,$start,$stop);
    error_segment($reference,$start,$stop) unless @seq;

    for my $obj (@seq) {
      my $dna = $obj->dna;
      my $length = length $dna;
      $dna =~ s/(.{60})/$1\n/g;
      my $ref = $obj->ref;
      my $s   = $obj->start;
      my $e   = $obj->end;
      print <<END
<SEQUENCE id="$ref" start="$s" stop="$e" version="1.0">
<DNA length="$length">
$dna
</DNA>
</SEQUENCE>
END
    }
  }
  print qq(</DASDNA>\n);
}

# -----------------------------------------------------------------
sub entry_points {
  my $segments = get_segments();

  my @parts;
  my @type_filter = map {$CONFIG->label2type($_)}
    grep {$CONFIG->setting($_=>'das landmark')}
      $CONFIG->labels;

  my ($category2type,$type2category) = categories($CONFIG);
  my $refclass = $CONFIG->setting('reference class') || 'Sequence';

  if ($segments) {
    @parts = map { get_segment_obj(@$_) } @$segments;
    @parts = map { $_->contained_features(-types=>\@type_filter,-merge=>0) } @parts;
  } else {
    @parts = $DB->features(-types=>\@type_filter) if @type_filter;
    push @parts,$DB->get_feature_by_name($refclass=>'*');
  }

  my $url = get_url();

  ok_header();
  print <<END;
<?xml version="1.0" standalone="no"?>
<!DOCTYPE DASEP SYSTEM "http://www.biodas.org/dtd/dasep.dtd">
<DASEP>
<ENTRY_POINTS href="$url" version="1.0">
END
;

  my %seenit;
  for my $part (@parts) {
    # I dunno, consider putting this back in for reference servers?
    # next unless $part->ref eq $part->group;
    $part->absolute(1);
    my $name  = $part->name;
    next if $seenit{$name}++;
    my $st    = $part->start;
    my $en    = $part->stop;
    my $class = $part->class;
    my $length = $part->length;
    my $orientation = $part->strand >= 0 ? '+' : '-';
    my $subparts    = $type2category->{__subparts__}{$part->type} ? 'yes' : 'no';
    $name = "$class:$name" unless $class eq $refclass;
    print qq(<SEGMENT id="$name" size="$length" start="$st" stop="$en" class="$class" orientation="$orientation" subparts="$subparts">$name</SEGMENT>\n);
  }
  print "</ENTRY_POINTS>\n</DASEP>\n";
}

# -----------------------------------------------------------------
# get the features for the segment indicated
sub features {
  my @segments = get_segments();

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

  my (@ordinary_categories,$want_supercomponent,$want_component);
  foreach (@category) {
    if (lc($_) eq 'component') {
      $want_component++;
    }
    elsif (lc($_) eq 'supercomponent') {
      $want_supercomponent++;
    }
    else {
      push @ordinary_categories,$_;
    }
  }

  my ($category2type,$type2category,$top_types) = categories($CONFIG);
  my %valid_types = map {$_=>1} @$top_types;

  unless (@filter || @category) {
    @filter = @$top_types;
  }

  push @filter,map {exists $category2type->{$_} ? @{$category2type->{$_}} : $_ } @ordinary_categories;
  @filter = map {$CONFIG->setting(feature=>$_)} $CONFIG->labels unless @filter;
  @filter = grep {$valid_types{$_}} @filter;

  ok_header();
  print <<END
<?xml version="1.0" standalone="yes"?>
<!DOCTYPE DASGFF SYSTEM "http://www.biodas.org/dtd/dasgff.dtd">
<DASGFF>
<GFF version="1.01" href="$url">
END
;

  foreach (@segments) {
    my ($reference,$refclass,$start,$stop) = @$_;

    dump_components($reference,$refclass,$start,$stop,$type2category)      if $want_component;
    dump_supercomponents($reference,$refclass,$start,$stop,$type2category) if $want_supercomponent;

    next if !@ordinary_categories && ($want_supercomponent || $want_component);

    my @segs = get_segment_obj($reference,$refclass,$start,$stop);
    error_segment($reference,$start,$stop) unless @segs;

    for my $seq (@segs) {
      dump_segment($seq,\@filter,undef,$type2category);
    }
  }

  # dump feature requests, if any
  for my $id (param('feature_id'),param('group_id')) {
    my @segments = get_feature_obj($id);
    error_id($id) unless @segments;
    foreach (@segments) {
      $_->absolute(1);
    }
    my @exact_matches = grep {$id eq $_->display_name} @segments;
    my @to_dump       = @exact_matches ? @exact_matches : @segments;
    dump_segment($_,\@filter,'toplevel') foreach @to_dump;
  }

print <<END;
</GFF>
</DASGFF>
END
}

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

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

  my %subparts     = map {$_=>1} map {$CONFIG->label2type($_)}
    grep {$CONFIG->setting($_=>'das subparts')}
      $CONFIG->labels;
  my %superparts     = map {$_=>1} map {$CONFIG->label2type($_)}
    grep {$CONFIG->setting($_=>'das superparts')}
      $CONFIG->labels;

  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 %agg_map;
  if ($DB->can('aggregators')) {
    %agg_map = map {($_->get_method||'') => ($_->main_name||'')} $DB->aggregators;
  }

  if (@$filter) {
    my $iterator = $seq->features(-types=>$filter,-merge=>1,-iterator=>1);
    while (my $f = $iterator->next_seq) {
      my @subparts  = $f->get_SeqFeatures;
      print_feature($f,undef,$type2category,\%agg_map) unless (@subparts && no_parent_wanted($f));
      my $count = 0;
      print_feature($_,$f,$type2category,\%agg_map,++$count)     foreach @subparts;
    }
  }

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

sub print_feature {
  local $^W = 0; # kill some uninit variable warnings

  my $f             = shift;
  my $parent        = shift;
  my $type2category = shift;
  my $agg_map       = shift || {};
  my $count         = shift;

  my $type        = $f->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 || 0;
  my $phase       = $f->phase;
  my $pid         = eval{$parent->id}||'';
  my $id          = $f->id || $pid . "/$count";
  # to avoid binary IDs!
  $id             = unpack('L',$id) if ref($DB) eq 'Bio::DB::GFF::Adaptor::berkeleydb';
  my $fid         = $id;
  my @notes       = $f->notes if $f->can('notes');

  my ($group,$gclass);
  if ($f->can('group')) { # Bio::DB::GFF feature
    $group       = $f->group;
    $gclass      = (ref($group) && $group->can('class')) ? $group->class : 'anonymous';
  } else {
    $group       = defined $parent ? $parent->id : $id;
    $gclass      = '';
  }

  my $group_type    = forced_group($parent||$f) || $type;
  $group_type =~ s/\:\w+$//;

  # This is way nasty.  The aggregator may have changed the method of the
  # main feature, so we need to change it back to what it was originally
  # for the purpose of serializing on the net.  What amazing shortsightedness
  # on the part of someone who should know better.
  $method = $agg_map->{$method} if defined $agg_map->{$method};
	
  $phase       ||= 0;
  $orientation ||= 0;
  $score       = '-' unless defined $score;
  $orientation = $orientation >= 0 ? '+' : '-';

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

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

  if (ref($info)) {
    my $class = $info->class;
    $fid = "$class:$info/$id";
    $id = $info;
    my $url = $CONFIG->make_link($parent || $f);
    $url ||= 'none';
    if($url ne 'none') {
      hack_link(\$url);
      $link = qq(<LINK href="$url">$info</LINK>);
      $gtype = qq( type="$group_type")
    }
  }

  else {  # repeated code here, but not sure of logic
      my $url = $CONFIG->make_link($parent || $f);
      $url ||= 'none';
      if ($url ne 'none') {
	hack_link(\$url);
	$link = qq(<LINK href="$url">$type</LINK>);
      }
    }

  if (@notes) {
    $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;
  my ($has_subparts,$has_superparts) = describe_component($type,$type2category);

  if ($has_subparts || $has_superparts) {
    $map = qq( reference="yes")
  } else {
    $map = qq() 
  }
  $map .= qq( subparts="yes")   if $has_subparts;
  $map .= qq( superparts="yes") if $has_superparts;

  $start ||= '';  $end ||= '';

  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 || $groupid) {
    $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
    ;
}

sub error_segment {
  my ($reference,$start,$stop) = @_;
  my $authoritative = $CONFIG->setting('das mapmaster')
    eq (url(-full=>1) . "/".$CONFIG->source);
  my $tag = $authoritative ? '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,$type2category) = @_;
  my @seq = grep {lc($_->abs_ref) eq lc($reference)} get_segment_obj($reference,$refclass,$reqstart,$reqend);

  error_segment($reference,$reqstart,$reqend) ;

  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 %{$type2category->{__superparts__}} or return;

    my @parts = $seq->contained_features(-type=>\@types,-merge=>0);
    @parts    = grep { $_->name ne $refseq } @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 || $part->info;


      my $orientation = $part->strand >= 0 ? '+1' : '-1';
      my $type   = $part->type;
      my $method = $type->method;
      my $description = qq(category="component" reference="yes");
      my ($has_subparts,$has_superparts) = describe_component($type,$type2category);

      $description .= qq( subparts="yes")   if $has_subparts;
      $description .= qq( superparts="yes") if $has_superparts;
      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,$type2category) = @_;
  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 %{$type2category->{__subparts__}} or return;
    my @parts = $seq->features(-type=>\@types,-merge=>0);

    my $printed_something;

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

      $printed_something++;

      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 ($has_subparts,$has_superparts) = describe_component($type,$type2category);

      my $description = qq(category="supercomponent" reference="yes");
      $description .= qq( subparts="yes")   if $has_subparts;
      $description .= qq( superparts="yes") if $has_superparts;
      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);
    }
    unless ($printed_something) {
      $seq->absolute(0);
      my $reference = $seq->ref;
      my $start     = $seq->start;
      my $stop      = $seq->stop;
      print qq(  <SEGMENT id="$reference" start="$start" stop="$stop" version="1.0" />\n);
    }
  }
}

sub 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) {
      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 ($category2type,$type2category,$types) = categories($CONFIG);
  ok_header();
  my $url = get_url();
  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">
<SEGMENT>
END
    ;


  for my $id (@$types) {
    my $category = transmute($id,$type2category);
    my $typeobj      = Bio::DB::GFF::Typename->new($id);
    my $method   = $typeobj->method;
    my $source   = $typeobj->source;
    print qq(\t<TYPE id="$id" category="$category" method="$method" source="$source" />\n);
  }

  print <<END
</SEGMENT>
</GFF>
</DASTYPES>
END
    ;

}

sub describe_component {
  my ($type,$type2category) = @_;
  (my $base = $type) =~ s/:[^:]+$//;
  my $has_subparts   = $type2category->{__subparts__}{$type}
    || $type2category->{__subparts__}{$base};
  my $has_superparts = $type2category->{__superparts__}{$type}
    || $type2category->{__superparts__}{$base};
  return ($has_subparts,$has_superparts);
}

sub stylesheet {
  my $config = $CONFIG;
  my ($category2type,$type2category) = categories($config);

  my %default_style       = $config->config->default_style;
  $default_style{-link} ||= $config->setting(general=>'link');

  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 %{$category2type}) {
    $cat ||= 'default';

    print qq(  <CATEGORY id="$cat">\n);

    my @types = exists $category2type->{$cat} ? @{$category2type->{$cat}} : 'default';
    my %doneit;

    for my $type (@types) {
      my $label =  $cat eq 'default' ? 'TRACK DEFAULTS'
	                             : $type2category->{__label__}{$type} || $CONFIG->type2label($type);
      my $forced_type = $CONFIG->setting($label=>'das type');
      my $typeid = $forced_type || $type;
      next if $doneit{$typeid}++;

      print qq(     <TYPE id="$typeid">\n);
      my %type_style = $config->config->style($label);

      my %style = (%default_style,map {ref $type_style{$_}?():($_=>$type_style{$_})} keys %type_style);
      delete $style{-feature};
      delete $style{-feature_low};
      delete $style{-link} if $style{-link} eq 'AUTO';
      my $glyph = $style{'-das glyph'} || $style{-glyph} || 'box';

      print qq(        <GLYPH>\n);
      print qq(           <\U$glyph\E>\n);
      for my $attribute (keys %style) {
	(my $name = $attribute) =~ s/^-//;
	$name =~ s/\s/_/g;
	next if $name =~ /glyph|category|das/;
	my $value = escapeHTML($style{$attribute});
	print qq(              <\U$name\E>$value<\U/$name\E>\n);
      }
      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 type and method
sub transmute {
  my $type = shift;
  my $map  = shift;

  # try fast exact match first
  return $map->{$type} if exists $map->{$type};

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

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

# -----------------------------------------------------------------
sub forced_group {
  my $feature = shift;
  return unless $feature;
  my $type = $feature->type;
  return $FORCED_GROUP{$type} if exists $FORCED_GROUP{$type};
  my $forced_group;
  my $label = $CONFIG->type2label($type);
  unless ($label) {
    $type =~ s/:\w+//;
    $label = $CONFIG->type2label($type);
  }
  $forced_group = $CONFIG->setting($label => 'das type') if $label;
  return $FORCED_GROUP{$type} = $forced_group;
}

sub no_parent_wanted {
  my $feature = shift;
  return unless $feature;
  my $type = $feature->type;
  return $NO_PARENT{$type} if exists $NO_PARENT{$type};
  my $no_parent;
  my $label = $CONFIG->type2label($type);
  unless ($label) {
    $type =~ s/:\w+//;
    $label = $CONFIG->type2label($type);
  }
  $no_parent = $CONFIG->setting($label => 'das flatten') ||
               $CONFIG->setting('TRACK DEFAULTS' => 'das flatten') if $label;
  return $NO_PARENT{$type} = $no_parent;
}

# -----------------------------------------------------------------
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 => $DAS_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 = $CONFIG->setting('reference class') || '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);
    my @s = grep {$_->abs_ref eq $reference} @segments;
    return @s if @s;
    return @segments;
  }
}

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

sub categories {
  my $config = shift;
  my $dsn    = $config->source;
  return @{$CACHED_TYPES{$dsn}} if exists $CACHED_TYPES{$dsn};

  my (%category2type,%type2category,@types);
  my @labels = $config->labels;

  for my $label (@labels) {
    my $category       = $config->setting($label=>'das category');
    my $has_subparts   = $config->setting($label=>'das subparts');
    my $has_superparts = $config->setting($label=>'das superparts');
    my $structural     = $config->setting($label=>'das landmark') ||
      $has_subparts || $has_superparts;
	
    $category ||= 'structural' if $structural;
    next unless $category;  # skip sections without a category marked

    my @composite_types = $config->label2type($label);
    push @types,@composite_types;
    my $t   = Bio::DB::GFF->parse_types(@composite_types);
    if ($DB->can('aggregators')) {
      $_->disaggregate($t,$DB) foreach $DB->aggregators;
    }
    my @t = map {defined($_->[1]) ? join(':',@$_) : $_->[0]} @$t;

    my %seenit;
    my @all_types = grep {!$seenit{$_}++} @t;

    push @{$category2type{$category}},(@composite_types,@all_types);
    $type2category{$_} = $category foreach @composite_types;

    for my $type (@all_types) {
      $type2category{$type} = $category;
      my $typeobj      = Bio::DB::GFF::Typename->new($type);
      $type2category{__label__}{$type}      = $label;
      $type2category{__fuzzy__}{$typeobj}   = $typeobj;
      $type2category{__subparts__}{$type}++   if $has_subparts;
      $type2category{__superparts__}{$type}++ if $has_superparts;
    }
  }
  $CACHED_TYPES{$dsn} = [\(%category2type,%type2category,@types)];
  return @{$CACHED_TYPES{$dsn}};
}

# unfortunately, the gbrowse library returns a relative address
# for AUTO links
sub hack_link {
  my $url_ref = shift;
  return unless $$url_ref =~ /^\.\./;
  my $self_url = url(-full=>1);
  $self_url =~ s!/das(/.+)?!!;
  $$url_ref =~ s!^(\.\.\/)+!!;
  $$url_ref = $self_url."/$$url_ref";
}

