Bio::Graphics::FeatureFile - A set of Bio::Graphics features, stored in a file

 use Bio::Graphics::FeatureFile;
 my $data  = Bio::Graphics::FeatureFile->new(-file => 'features.txt');




 # create a new panel and render contents of the file onto it
 my $panel = $data->new_panel;
 my $tracks_rendered = $data->render($panel);

 # or do it all in one step
 my ($tracks_rendered,$panel) = $data->render;

 # for more control, render tracks individually
 my @feature_types = $data->types;
 for my $type (@feature_types) {
    my $features = $data->features($type);
    my %options  = $data->style($type);
    $panel->add_track($features,%options);  # assuming we have a Bio::Graphics::Panel
 }

 # get individual settings
 my $est_fg_color = $data->setting(EST => 'fgcolor');

 # or create the FeatureFile by hand

 # add a type
 $data->add_type(EST => {fgcolor=>'blue',height=>12});

 # add a feature
 my $feature = Bio::Graphics::Feature->new(
                                             # params
                                          ); # or some other SeqI
 $data->add_feature($feature=>'EST');

 [Stanza Name]
 option1 = value1
 option2 = value2
 option3 = value3

 [Stanza Name 2]
 option1 = value1
 option2 = value2
 ...

 [Named Genes]
 feature = gene
 glyph   = transcript2
 description = These are genes that have been named
   by the international commission on gene naming
   (The Hague).

 Gene	B0511.1	Chr1:516..11208

 Gene "My Favorite Gene" Chr1:516..11208

 Gene B0511.1  Chr1:516..619,3185..3294,10946..11208

 Gene	B0511.1	Chr1:516..619
 Gene	B0511.1	Chr1:3185..3294
 Gene	B0511.1	Chr1:10946..11208

 reference=Chr1
 Gene	B0511.1	516..619
 Gene	B0511.1	3185..3294
 Gene	B0511.1	10946..11208

 Gene  B0511.1  Chr1:516..619,3185..3294 Note="Putative primase"

 Gene  B0511.1  Chr1:516..619,3185..3294 GO_Term=GO:100;GO_Term=GO:2087

 Tag     Meaning
 ---     -------

 Type    The primary tag for a subfeature.
 Score   The score of a feature or subfeature.
 Phase   The phase of a feature or subfeature.
 URL     A URL to link to (via the Bio::Graphics library).
 Note    A note to attach to the feature for display by the Bio::Graphics library.

 mRNA B0511.1 Chr1:1..100 Type=UTR
 mRNA B0511.1 Chr1:101..200,300..400,500..800 Type=CDS
 mRNA B0511.1 Chr1:801..1000 Type=UTR

 mRNA B0511.1 Chr1:1..100 Type=UTR;Note="Putative primase"
 mRNA B0511.1 Chr1:101..200,300..400,500..800 Type=CDS
 mRNA B0511.1 Chr1:801..1000 Type=UTR

 EST	yk53c10
 	yk53c10.3	15000-15500,15700-15800
 	yk53c10.5	18892-19154

 # this is ignored
 [Example]
 glyph   = generic   # this comment is ignored
 bgcolor = #FF0000
 link    = http://www.google.com/search?q=$name#results

 #include "/usr/local/share/my_directives.txt"
 #include 'my_directives.txt'
 #include chromosome3_features.gff3
 #include gff.d/*.conf

  $value = $browser->setting(gene => 'fgcolor');

 Title   : get_seq_stream
 Usage   : $stream = $s->get_seq_stream(@args)
 Function: get a stream of features that overlap this segment
 Returns : a Bio::SeqIO::Stream-compliant stream
 Args    : see below
 Status  : Public

 $stream = $s->get_seq_stream('exon');
 while (my $exon = $stream->next_seq) {
    print $exon->start,"\n";
 }

 Usage   : $db->get_feature_by_name(-name => $name)
 Function: fetch features by their name
 Returns : a list of Bio::DB::GFF::Feature objects
 Args    : the name of the desired feature
 Status  : public

  @f = $db->get_feature_by_name(-name  => $name,
                                -ref   => $sequence_name,
                                -start => $start,
                                -end   => $end);

 Title   : search_notes
 Usage   : @search_results = $db->search_notes("full text search string",$limit)
 Function: Search the notes for a text string
 Returns : array of results
 Args    : full text search string, and an optional row limit
 Status  : public

  column 1     Display name of the feature
  column 2     The text of the note
  column 3     A relevance score.

 # file begins
 [general]
 pixels = 1024
 bases = 1-20000
 reference = Contig41
 height = 12

 [mRNA]
 glyph = gene
 key   = Spliced genes

 [Cosmid]
 glyph = segments
 fgcolor = blue
 key = C. elegans conserved regions

 [EST]
 glyph = segments
 bgcolor= yellow
 connector = dashed
 height = 5;

 [FGENESH]
 glyph = transcript2
 bgcolor = green
 description = 1

 mRNA B0511.1 Chr1:1..100 Type=UTR;Note="putative primase"
 mRNA B0511.1 Chr1:101..200,300..400,500..800 Type=CDS
 mRNA B0511.1 Chr1:801..1000 Type=UTR

 reference = Chr3
 Cosmid	B0511	516..619
 Cosmid	B0511	3185..3294
 Cosmid	B0511	10946..11208
 Cosmid	B0511	13126..13511
 Cosmid	B0511	11394..11539
 EST	yk260e10.5	15569..15724
 EST	yk672a12.5	537..618,3187..3294
 EST	yk595e6.5	552..618
 EST	yk595e6.5	3187..3294
 EST	yk846e07.3	11015..11208
 EST	yk53c10
 	yk53c10.3	15000..15500,15700..15800
 	yk53c10.5	18892..19154
 EST	yk53c10.5	16032..16105
 SwissProt	PECANEX	13153-13656	Note="Swedish fish"
 FGENESH	"Predicted gene 1"	1-205,518-616,661-735,3187-3365,3436-3846	"Pfam domain"
 # file ends

package Bio::Graphics::FeatureFile;

# $Id: FeatureFile.pm,v 1.14 2009-05-29 14:48:06 lstein Exp $
# This package parses and renders a simple tab-delimited format for features.
# It is simpler than GFF, but still has a lot of expressive power.
# See __END__ for the file format

use strict;
use Bio::Graphics::Feature;
use Bio::DB::GFF::Util::Rearrange;
use Carp 'cluck','carp','croak';
use IO::File;
use File::Glob ':glob';
use Text::ParseWords 'shellwords';
use Bio::DB::SeqFeature::Store;
use File::Basename 'dirname';
use File::Spec;
use Cwd 'getcwd';

# default colors for unconfigured features
my @COLORS = qw(cyan blue red yellow green wheat turquoise orange);

# package variable which holds the limited set of libraries accessible
# from within the Safe::World container (please see the description of
# the -safe_world option).
# my $SAFE_LIB;

use constant WIDTH => 600;
use constant MAX_REMAP => 100;

sub version { return 2 }

# args array:
# -file => parse from a file (- allowed for ARGV)
# -text => parse from a text scalar
# -map_coords => code ref to do coordinate mapping
#                called with ($ref,[$start1,$stop1],[$start2,$stop2]...)
#                returns     ($newref,$new_coord1,$new_coord2...)

sub new {
    shift->_new(@_);
}

sub _new {
  my $class = shift;
  my %args  = @_;
  my $self = bless {
		    config   => {},
		    features => {},
		    seenit   => {},
		    types    => [],
		    max      => undef,
		    min      => undef,
		    stat     => [],
		    refs     => {},
                    safe     => undef,
		    safe_world => undef,
		   },$class;
  $self->{coordinate_mapper} = $args{-map_coords} 
    if exists $args{-map_coords} && ref($args{-map_coords}) eq 'CODE';

  $self->smart_features($args{-smart_features})   if exists $args{-smart_features};
  $self->{safe}              = $args{-safe}       if exists $args{-safe};
  $self->safe_world(1)                            if $args{-safe_world};
  $self->allow_whitespace(1)                      if $args{-allow_whitespace};

  $self->init_parse();

  # call with
  #   -file
  #   -text
  if (my $file = $args{-file}) {
    no strict 'refs';
    if (defined fileno($file)) { # a filehandle
	$self->parse_fh($file);
    } elsif ($file eq '-') {
	$self->parse_argv();
    } else {
	$self->parse_file($file);
    }
  } elsif (my $text = $args{-text}) {
      $self->parse_text($text);
  }

  $self->finish_parse();
  return $self;
}

sub new_from_cache {
    my $self = shift;
    my %args = @_;
    my $has_libs;

    unless ($has_libs = defined &nfreeze) {
	$has_libs = eval <<END;
use Storable 'lock_store','lock_retrieve';
use File::Path 'mkpath';
1;
END
    warn "You need Storable to use new_from_cache(); returning uncached data" unless $has_libs;
    }

    $Storable::Deparse = 1;
    $Storable::Eval    = 1;

    my $file      = $has_libs && $args{-file} or return $self->_new(@_);
    (my $name     = $args{-file}) =~ s!/!_!g;
    my $cachefile = $self->cachefile($name);
    if (-e $cachefile && (stat(_))[9] >= $self->file_mtime($args{-file})) { # cache is valid
	my $parsed_file = lock_retrieve($cachefile);
	$parsed_file->initialize_code if $parsed_file->safe;
	return $parsed_file;
    } else {
	mkpath(dirname($cachefile));
	my $parsed = $self->_new(@_);
	lock_store($parsed,$cachefile);
	return $parsed;
    }
    
}

sub cachedir {
    my $self = shift;
    my $uid       = $<;
    return File::Spec->catfile(File::Spec->tmpdir,"bio_graphics_ff_cache_${uid}");
}

sub cachefile {
    my $self = shift;
    my $name = shift;
    return File::Spec->catfile($self->cachedir,$name);
}

sub file_mtime {
    my $self = shift;

    my $file  = shift;
    my $mtime = 0;

    for my $f (glob($file)) {
	my $m  = (stat($f))[9] or next;
	$mtime = $m if $mtime < $m;
	open my $fh,'<',$file or next;
	my $cwd = getcwd();
	chdir(dirname($file));

        local $_;
	while (<$fh>) {
	    if (/^\#exec/) {
		return time();  # now!
	    }
	    if (/^\#include\s+(.+)/i) {  # #include directive
		my ($include_file) = shellwords($1);
		my $m  = $self->file_mtime($include_file);
		$mtime = $m if $mtime < $m;
	    }
	}
	chdir($cwd);
    }

    return $mtime;
}

sub file_list {
    my $self = shift;
    my @list = ();
    my $file  = shift;

    for my $f (glob($file)) {
        open my $fh,'<',$file or next;
        my $cwd = getcwd();
        chdir(dirname($file));


        while (<$fh>) {
            if (/^\#include\s+(.+)/i) {  # #include directive
                my ($include_file) = shellwords($1);
                my @files = glob($include_file);
                @files ? @list = (@list,@files) : push(@list,$include_file);
            }
        }
        chdir($cwd);
    }

    return \@list;
}

# render our features onto a panel using configuration data
# return the number of tracks inserted

#"

sub render {
  my $self  = shift;
  my $panel = shift;         # 8 arguments
  my ($position_to_insert,
      $options,
      $max_bump,
      $max_label,
      $selector,
      $range,
      $override_options
      ) = @_;
  my %seenit;

  unless ($panel && UNIVERSAL::isa($panel,'Bio::Graphics::Panel')) {
      $panel = $self->new_panel($panel);
  }

  # count up number of tracks inserted
  my @tracks;
  my $color;
  my @labels             = $self->labels;

  # we need to add a dummy section for each type that isn't
  # specifically configured
  my %types   = map {$_=>1
  } map {
      shellwords ($self->setting($_=>'feature')||$_) } @labels;
  my %lc_types = map {lc($_)}%types;

  my @unconfigured_types = sort grep {!exists $lc_types{lc $_} &&
					  !exists $lc_types{lc $_->method}
  }         $self->types;

  my @configured_types   = keys %types;

  my @labels_to_render = (@labels,@unconfigured_types);

  my @base_config = $self->style('general');

  my @pack_options = ();
  if ($options && ref $options eq 'HASH') {
    @pack_options = %$options;
  } else {
    $options ||= 0;
    if ($options == 1) {  # compact
      push @pack_options,(-bump => 0,-label=>0);
    } elsif ($options == 2) { #expanded
      push @pack_options,(-bump=>1);
    } elsif ($options == 3) { #expand and label
      push @pack_options,(-bump=>1,-label=>1);
    } elsif ($options == 4) { #hyperexpand
      push @pack_options,(-bump => 2);
    } elsif ($options == 5) { #hyperexpand and label
      push @pack_options,(-bump => 2,-label=>1);
    }
  }

  for my $label (@labels_to_render) {


      my @types = shellwords($self->setting($label=>'feature')||'');
      @types    = $label unless @types;

      next if defined $selector and !$selector->($self,$label);

      my @features = !$range ? grep {$self->_visible($_)} $self->features(\@types)
                             : $self->features(-types   => \@types,
					       -seq_id  => $range->seq_id,
					       -start   => $range->start,
					       -end     => $range->end
					      );
      next unless @features;  # suppress tracks for features that don't appear

      # fix up funky group hack
      foreach (@features) {$_->primary_tag('group') if $_->has_tag('_ff_group')};
      my $features = \@features;

      my @auto_bump;
      push @auto_bump,(-bump  => @$features < $max_bump)  if defined $max_bump;
      push @auto_bump,(-label => @$features < $max_label) if defined $max_label;

      my @more_arguments = $override_options ? @$override_options : ();

      my @config = ( -glyph   => 'segments',         # really generic
		     -bgcolor => $COLORS[$color++ % @COLORS],
		     -label   => 1,
		     -description => 1,
		     -key     => $features[0]->type || $label,
		     @auto_bump,
		     @base_config,         # global
		     $self->style($label),  # feature-specific
		     @pack_options,
		     @more_arguments,
	  );

      if (defined($position_to_insert)) {
	  push @tracks,$panel->insert_track($position_to_insert++,$features,@config);
      } else {
	  push @tracks,$panel->add_track($features,@config);
      }
  }
  return wantarray ? (scalar(@tracks),$panel,\@tracks) : scalar @tracks;
}

sub _stat {
  my $self = shift;
  my $file = shift;
  defined fileno($file)  or return;
  my @stat = stat($file) or return;
  if ($self->{stat} && @{$self->{stat}}) { # merge #includes so that mtime etc are max age
      for (8,9,10) {
	  $self->{stat}[$_] = $stat[$_] if $stat[$_] > $self->{stat}[$_];
      }
      $self->{stat}[7] += $stat[7];
  } else {
      $self->{stat} = \@stat;
  }
}

sub _visible {
    my $self = shift;
    my $feat = shift;
    my $min  = $self->min;
    my $max  = $self->max;
    return $feat->start<=$max && $feat->end>=$min;
}

sub error {
  my $self = shift;
  my $d = $self->{error};
  $self->{error} = shift if @_;
  $d;
}

sub smart_features {
  my $self = shift;
  my $d = $self->{smart_features};
  $self->{smart_features} = shift if @_;
  $d;
}

sub parse_argv {
  my $self = shift;
  local $/ = "\n";
  local $_;
  while (<>) {
    chomp;
    $self->parse_line($_);
  }
}

sub parse_file {
    my $self = shift;
    my $file = shift;

    $file =~ s/(\s)/\\$1/g; # escape whitespace from glob expansion

    for my $f (glob($file)) {
	my $fh   = IO::File->new($f) or return;
	my $cwd  = getcwd();
	chdir(dirname($f));
	$self->parse_fh($fh);
	chdir($cwd);
    }
}

sub parse_fh {
    my $self = shift;
    my $fh   = shift;
    $self->_stat($fh);
    local $/ = "\n";
    local $_;
    while (<$fh>) {
	chomp;
	$self->parse_line($_) || last;
    }
}

sub parse_text {
  my $self = shift;
  my $text = shift;

  foreach (split m/\015?\012|\015\012?/,$text) {
    $self->parse_line($_);
  }
}

sub parse_line {
  my $self = shift;
  my $line = shift;

  $line =~ s/\015//g;  # get rid of carriage returns left over by MS-DOS/Windows systems
  $line =~ s/\s+$//;   # get rid of trailing whitespace

  if (/^#include\s+(.+)/i) {  # #include directive
      my ($include_file) = shellwords($1);
      # detect some loops
      croak "#include loop detected at $include_file"
	  if $self->{includes}{$include_file}++;
      $self->parse_file($include_file);
      return 1;
  }

  if (/^#exec\s+(.+)/i) {  # #exec directive
      my ($command,@args) = shellwords($1);
      open (my $fh,'-|') || exec $command,@args;
      $self->parse_fh($fh);
      return 1;
  }

  return 1 if $line =~ /^\s*\#[^\#]?$/;   # comment line

  # Are we in a configuration section or a data section?
  # We start out in 'config' state, and are triggered to
  # reenter config state whenever we see a /^\[ pattern (config section)
  my $old_state = $self->{state};
  my $new_state = $self->_state_transition($line);

  if ($new_state ne $old_state) {
      delete $self->{current_config};
      delete $self->{current_tag};
  }

  if ($new_state eq 'config') {
      $self->parse_config_line($line);
  } elsif ($new_state eq 'data') {
      $self->parse_data_line($line);
  }
  $self->{state} = $new_state;
  1;
}

sub _state_transition {
    my $self = shift;
    my $line = shift;
    my $current_state = $self->{state};

    if ($current_state eq 'data') {
	return 'config' if $line =~ m/^\s*\[([^\]]+)\]/;  # start of a configuration section
    }

    elsif ($current_state eq 'config') {
	return 'data'   if $line =~ /^\#\#(\w+)/;     # GFF3 meta instruction
	return 'data'   if $line =~ /^reference\s*=/; # feature-file reference sequence directive
	
	return 'config' if $line =~ /^\s*$/;                             #empty line
	return 'config' if $line =~ m/^\[([^\]]+)\]/;                    # section beginning
	return 'config' if $line =~ m/^[\w:\s]+=/ 
	    && $self->{current_config};                                  # configuration line
	return 'config' if $line =~ m/^\s+(.+)/
	    && $self->{current_tag};                                     # continuation section
	return 'config' if $line =~ /^\#/;                               # comment -not a meta
	return 'data';
    }
    return $current_state;
}

sub parse_config_line {
    my $self = shift;
    local $_ = shift;

    # strip right-column comments unless they look like colors or html fragments
    s/\s*\#.*$// unless /\#[0-9a-f]{6,8}\s*$/i || /\w+\#\w+/ || /\w+\"*\s*\#\d+$/;   

    if (/^\s+(.+)/ && $self->{current_tag}) { # configuration continuation line
	my $value = $1;
	my $cc = $self->{current_config} ||= 'general';       # in case no configuration named
	$self->{config}{$cc}{$self->{current_tag}} .= ' ' . $value;
	# respect newlines in code subs
	$self->{config}{$cc}{$self->{current_tag}} .= "\n"
	    if $self->{config}{$cc}{$self->{current_tag}}=~ /^sub\s*\{/;
	return 1;
    }

    elsif (/^\[([^\]]+)\]/) {  # beginning of a configuration section
	my $label = $1;
	my $cc = $label =~ /^(general|default)$/i ? 'general' : $label;  # normalize
	push @{$self->{types}},$cc unless $cc eq 'general';
	$self->{current_config} = $cc;
	return 1;
    }

    elsif (/^([\w: -]+?)\s*=\s*(.*)/) {   # key value pair within a configuration section
	my $tag = lc $1;
	my $cc = $self->{current_config} ||= 'general';       # in case no configuration named
	my $value = defined $2 ? $2 : '';
	$self->{config}{$cc}{$tag} = $value;
	$self->{current_tag} = $tag;
	return 1;
    }


    elsif (/^$/) { # empty line
     # no longer required -- new sections are indicated by the start of a [stanza]
     # line and not by termination with a blank line
     #	undef $self->{current_tag}; 
	return 1;
    }

}

sub parse_data_line {
    my $self = shift;
    my $line = shift;
    $self->{loader} ||= $self->_make_loader($line) or return;
    $self->{loader}->load_line($line);
}

sub _make_loader {
    my $self = shift;
    local $_ = shift;
    my $db   = $self->db;

    my $type;

    # we support gff2, gff3 and featurefile formats
    if (/^\#\#gff-version\s+([23])/) {
	$type = "Bio::DB::SeqFeature::Store::GFF$1Loader";
    }
    elsif (/^reference\s*=.+/) {
	$type = "Bio::DB::SeqFeature::Store::FeatureFileLoader";
    }
    else {
	my @tokens = shellwords($_);
	unshift @tokens,'' if /^\s+/ and length $tokens[0];
	
	if (@tokens >=8 && $tokens[3]=~ /^-?\d+$/ && $tokens[4]=~ /^-?\d+$/) {
	    $type = 'Bio::DB::SeqFeature::Store::GFF3Loader';
	} 
	else {
	    $type = 'Bio::DB::SeqFeature::Store::FeatureFileLoader';
	}
    }
    eval "require $type"
	    unless $type->can('new');
    my $loader = $type->new(-store             => $db,
			    -map_coords        => $self->{coordinate_mapper},
			    -index_subfeatures => 0,
	);
    eval {$loader->allow_whitespace(1)} 
        if $self->allow_whitespace;  # gff2 and gff3 loaders allow this

    $loader->start_load() if $loader;
    return $loader;
}

sub db {
    my $self = shift;
    return $self->{db} ||= Bio::DB::SeqFeature::Store->new(-adaptor=>'memory',
							   -write  => 1);
}

sub allow_whitespace {
    my $self = shift;
    my $d    = $self->{allow_whitespace};
    $self->{allow_whitespace} = shift if @_;
    $d;
}

# add a feature of given type to our list
# we use the primary_tag() method
sub add_feature {
  my $self = shift;
  my ($feature,$type) = @_;
  $feature->configurator($self) if $self->smart_features;
  $feature->primary_tag($type) if defined $type;
  $self->db->store($feature);
}

# Add a type to the list.  Hash values are used for key/value pairs
# in the configuration.  Call as add_type($type,$configuration) where
# $configuration is a hashref.
sub add_type {
  my $self = shift;
  my ($type,$type_configuration) = @_;
  my $cc = $type =~ /^(general|default)$/i ? 'general' : $type;  # normalize
  push @{$self->{types}},$cc unless $cc eq 'general' or $self->{config}{$cc};
  if (defined $type_configuration) {
    for my $tag (keys %$type_configuration) {
      $self->{config}{$cc}{lc $tag} = $type_configuration->{$tag};
    }
  }
}

# change configuration of a type.  Call as set($type,$tag,$value)
# $type will be added if not already there.
sub set {
  my $self = shift;
  croak("Usage: \$featurefile->set(\$type,\$tag,\$value\n")
    unless @_ == 3;
  my ($type,$tag,$value) = @_;
  unless ($self->{config}{$type}) {
    return $self->add_type($type,{$tag=>$value});
  } else {
    $self->{config}{$type}{lc $tag} = $value;
  }
}

# break circular references
sub finished {
  my $self = shift;
  delete $self->{features};
}

sub DESTROY { 
    my $self = shift;
    $self->finished(@_);
#    $self->{safe_context}->unlink_all_worlds
#	if $self->{safe_context};
}

sub setting {
  my $self = shift;
  if (@_ > 2) {
    $self->{config}->{$_[0]}{$_[1]} = $_[2];
  }

  elsif (@_ <= 1) {
      return $self->_setting(@_);
  }

  elsif ($self->safe) {
      return $self->code_setting(@_);
  }

  elsif ($self->safe_world) {
      return $self->safe_setting(@_);
  }

  else {
      $self->{code_check}++ && $self->clean_code(); # not safe; clean coderefs
      return $self->_setting(@_);
  }
}

sub fallback_setting {
  my $self = shift;
  my ($label,$option) = @_;
  for my $key ($label,'TRACK DEFAULTS','GENERAL') {
    my $value = $self->setting($key,$option);
    return $value if defined $value;
  }
  return;
}


# return configuration information
# arguments are ($type) => returns tags for type
#               ($type=>$tag) => returns values of tag on type
#               ($type=>$tag,$value) => sets value of tag
sub _setting {
  my $self = shift;
  my $config = $self->{config} or return;
  return keys %{$config} unless @_;
  return keys %{$config->{$_[0]}}        if @_ == 1;
  return $config->{$_[0]}{$_[1]}         if @_ == 2 && defined $_[0] && exists $config->{$_[0]};
  return $config->{$_[0]}{$_[1]} = $_[2] if @_ > 2;
  return;
}

sub code_setting {
  my $self = shift;
  my $section = shift;
  my $option  = shift;
  croak 'Cannot call code_setting unless feature file is marked as safe'
      unless $self->safe;

  my $setting = $self->_setting($section=>$option);
  return unless defined $setting;
  return $setting if ref($setting) eq 'CODE';
  if ($setting =~ /^\\&(\w+)/) {  # coderef in string form
    my $subroutine_name = $1;
    my $package         = $self->base2package;
    my $codestring      = "\\&${package}\:\:${subroutine_name}";
    my $coderef         = eval $codestring;
    $self->_callback_complain($section,$option) if $@;
    $self->set($section,$option,$coderef);
    $self->set_callback_source($section,$option,$setting);
    return $coderef;
  }
  elsif ($setting =~ /^sub\s*(\(\$\$\))*\s*\{/) {
    my $package         = $self->base2package;
    my $coderef         = eval "package $package; $setting";
    $self->_callback_complain($section,$option) if $@;
    $self->set($section,$option,$coderef);
    $self->set_callback_source($section,$option,$setting);
    return $coderef;
  } else {
    return $setting;
  }
}

sub _callback_complain {
  my $self    = shift;
  my ($section,$option) = @_;
  carp "An error occurred while evaluating the callback at section='$section', option='$option':\n   => $@";
}

sub safe_setting {
    my $self    = shift;

    my $section = shift;
    my $option  = shift;

    my $setting = $self->_setting($section=>$option);
    return unless defined $setting;
    return $setting if ref($setting) eq 'CODE';

    if ($setting =~ /^sub\s*(\(\$\$\))*\s*\{/ 
	&& (my $context = $self->{safe_context})) {


	# turn setting from an anonymous sub into a named
	# sub in the context namespace

	# create proper symbol name
	my $subname = "${section}_${option}";
	$subname    =~ tr/a-zA-Z0-9_//cd;
	$subname    =~ s/^\d+//;

	my ($prototype) 
	    = $setting =~ /^sub\s*\(\$\$\)/;

	$setting    =~ s/^sub?.*?\{/sub $subname {/;

	my $success = $context->eval("$setting; 1");
	$self->_callback_complain($section,$option) if $@;
	unless ($success) {
	    $self->set($section,$option,1);  # if call fails, it becomes a generic "true" value
	    return 1;
	}

	my $coderef = $prototype 
	    ?  sub ($$) { return $context->call($subname,$_[0],$_[1]) }
	    :  sub {
		if ($_[-1]->isa('Bio::Graphics::Glyph')) {
		    my %newglyph = %{$_[-1]};
		    $_[-1]       = bless \%newglyph,'Bio::Graphics::Glyph'; # make generic
		}
		$context->call($subname,@_);
	    };
	$self->set($section,$option,$coderef);
	$self->set_callback_source($section,$option,$setting);
	return $coderef;
    }
    else {
	return $setting;
    }
}

sub safe {
   my $self = shift;
   my $d = $self->{safe};
   $self->{safe} = shift if @_;
   $self->evaluate_coderefs if $self->{safe} && !$d;
   $d;
}

sub safe_world {
    my $self            = shift;
    my $safe            = shift;

    if ($safe && !$self->{safe_content}) {  # initialise the thing

	eval "require Safe::World; 1";
	unless (Safe::World->can('new')) {
	    warn "The Safe::World module is not installed on this system. Can't use it to evaluate codesubs in a safe context";
	    return;
	}
	
	unless ($self->{safe_lib}) {
	    $self->{safe_lib} = Safe::World->new(sharepack => ['Bio::DB::SeqFeature',
							       'Bio::Graphics::Feature',
							       'Bio::SeqFeature::Lite',
							       'Bio::Graphics::Glyph',
						 ])  or return;

	    $self->{safe_lib}->eval(<<END)           or return;
use Bio::DB::SeqFeature;
use Bio::Graphics::Feature;
use Bio::SeqFeature::Lite;
use Bio::Graphics::Glyph; 
1;
END
	}

	$self->{safe_context} = Safe::World->new(root => $self->base2package)        or return;
	$self->{safe_context}->op_permit_only(':default');
	$self->{safe_context}->link_world($self->{safe_lib});
	$self->{safe_world} = $safe;
    }
    return $self->{safe_world};
}

sub set_callback_source {
    my $self = shift;
    my ($type,$tag,$value) = @_;
    $self->{source}{$type}{lc $tag} = $value;
}

sub get_callback_source {
    my $self = shift;
    my ($type,$tag) = @_;
    $self->{source}{$type}{lc $tag};
}

# turn configuration into a set of -name=>value pairs suitable for add_track()
sub style {
  my $self = shift;
  my $type = shift;

  my $config  = $self->{config}  or return;
  my $hashref = $config->{$type};
  unless ($hashref) {
    $type =~ s/:.+$//;
    $hashref = $config->{$type} or return;
  }

  return map {("-$_" => $hashref->{$_})} keys %$hashref;
}

# retrieve just the glyph part of the configuration
sub glyph {
  my $self = shift;
  my $type = shift;
  my $config  = $self->{config}  or return;
  my $hashref = $config->{$type} or return;
  return $hashref->{glyph};
}

# return list of configured types, in proper order
sub configured_types {
  my $self = shift;
  my $types = $self->{types} or return;
  return @$types;
}

sub labels {
    return shift->configured_types;
}

sub types {
  my $self = shift;
  my $db = $self->db;
  $self->_patch_old_bioperl;
  return $self->db->types;
}

sub _patch_old_bioperl {
    my $self = shift;
    if ($Bio::Root::Version::VERSION >= 1.0069 &&
	$Bio::Root::Version::VERSION <= 1.006901
	) {  # bad version!
	local $^W=0;
	*Bio::DB::SeqFeature::Store::memory::types = sub {
	    my $self = shift;
	    eval "require Bio::DB::GFF::Typename" unless Bio::DB::GFF::Typename->can('new');
	    my @types;
	    for my $primary_tag ( keys %{$$self{_index}{type}} ) {
		for my $source_tag ( keys %{$$self{_index}{type}{$primary_tag}} ) {
		    push @types, Bio::DB::GFF::Typename->new($primary_tag,$source_tag);
		}
	    }
	    return @types;
	}
    }
}

# return features
sub features {
  my $self = shift;
  my ($types,$iterator,$seq_id,$start,$end,@rest) = defined($_[0] && $_[0]=~/^-/)
    ? rearrange([['TYPE','TYPES'],'ITERATOR','SEQ_ID','START','END'],@_) : (\@_);

  $types = [$types] if $types && !ref($types);
  my @args     = $types && @$types ? (-type=>$types) : ();

  push @args,(-seq_id => $seq_id) if $seq_id;
  push @args,(-start  => $start)  if defined $start;
  push @args,(-end    => $end)    if defined $end;

  my $db = $self->db;

  if ($iterator) {
      return $db->get_seq_stream(@args);
  } else {
      my @f = $db->features(@args);
      return wantarray ?  @f : \@f;
  }
}

sub make_strand {
  local $^W = 0;
  return +1 if $_[0] =~ /^\+/ || $_[0] > 0;
  return -1 if $_[0] =~ /^\-/ || $_[0] < 0;
  return 0;
}

sub get_seq_stream {
  my $self = shift;
  local $^W = 0;
  my @args = $_[0] =~ /^-/ ? (@_,-iterator=>1) : (-types=>\@_,-iterator=>1);
  $self->features(@args);
}

sub get_feature_by_name {
   my $self = shift;
   my ($name,$ref,$start,$end) = rearrange(['NAME','REF','START','END'],@_);
   my @args;
   push @args,(-name   => $name) if defined $name;
   push @args,(-seq_id => $ref)  if defined $ref;
   push @args,(-start  => $start)if defined $start;
   push @args,(-end    => $end)  if defined $end;
   return $self->db->features(@args);
}

sub get_features_by_name { shift->get_feature_by_name(@_) }

sub search_notes {
  my $self = shift;
  return $self->db->search_notes(@_);
}

*get_feature_stream = \&get_seq_stream;
*top_SeqFeatures    = *all_SeqFeatures = \&features;

sub refs {
  my $self = shift;
  my $refs = $self->{refs} or return;
  keys %$refs;
}

sub min { 
    my $self = shift;
    $self->_min_max();
    $self->{min};
}

sub max {
    my $self = shift;
    $self->_min_max();
    $self->{max};
}

sub _min_max {
    my $self = shift;
    return if defined $self->{min} and defined $self->{max};

    my ($min,$max);
    if (my $bases = $self->setting(general=>'bases')) {
	($min,$max)        = $bases =~ /^(-?\d+)(?:\.\.|-)(-?\d+)/;
    }

    if (!defined $min) {
	# otherwise sort through the features
	my $fs = $self->get_seq_stream;
	while (my $f = $fs->next_seq) {
	    $min = $f->start if !defined $min or $min > $f->start;
	    $max = $f->end   if !defined $max or $max < $f->start;
	}
    }

    @{$self}{'min','max'} = ($min,$max);
}

sub init_parse {
  my $s = shift;

  $s->{max}          = $s->{min} = undef;
  $s->{types}        = [];
  $s->{features}     = {};
  $s->{config}       = {};
  $s->{loader}       = undef;
  $s->{state}        = 'config';
  $s->{feature_count}= 0; 
}

sub finish_parse {
  my $s = shift;
  if ($s->safe) {
      $s->initialize_code;
      $s->evaluate_coderefs;
  } 
  elsif ($s->safe_world) {
      $s->evaluate_safecoderefs;
  }
  $s->{loader}->finish_load() if $s->{loader};
  $s->{loader}       = undef;
  $s->{state}        = 'config';
}

sub evaluate_coderefs {
  my $self = shift;
  for my $s ($self->_setting) {
    for my $o ($self->_setting($s)) {
      $self->code_setting($s,$o);
    }
  }
}
sub evaluate_safecoderefs {
  my $self = shift;
  for my $s ($self->_setting) {
    for my $o ($self->_setting($s)) {
      $self->safe_setting($s,$o);
    }
  }
}

sub clean_code {
  my $self = shift;
  for my $s ($self->_setting) {
    for my $o ($self->_setting($s)) {
	$self->_setting($s,$o,1) if
	    $self->_setting($s,$o) =~ /\Asub\s*{/;
    }
  }
}

sub initialize_code {
  my $self       = shift;
  my $package    = $self->base2package;
  my $init_code  = $self->_setting(general => 'init_code') or return;
  my $code       = "package $package; $init_code; 1;";
  eval $code;
  $self->_callback_complain(general=>'init_code') if $@;
}

sub base2package {
  my $self = shift;
  return $self->{base2package} if exists $self->{base2package};
  my $rand     = int rand(1000000);
  return $self->{base2package} = "Bio::Graphics::FeatureFile::CallBack::P$rand";
}

sub split_group {
  my $self = shift;
  my $gff = $self->{gff} ||= Bio::DB::GFF->new(-adaptor=>'memory');
  return $gff->split_group(shift, $self->{gff_version} > 2);
}

# create a panel if needed
sub new_panel {
  my $self    = shift;
  my $options = shift;

  eval "require Bio::Graphics::Panel" unless Bio::Graphics::Panel->can('new');

  # general configuration of the image here
  my $width         = $self->setting(general => 'pixels')
                      || $self->setting(general => 'width')
			|| WIDTH;

  my ($start,$stop);
  my $range_expr = '(-?\d+)(?:-|\.\.)(-?\d+)';

  if (my $bases = $self->setting(general => 'bases')) {
    ($start,$stop) =  $bases =~ /([\d-]+)(?:-|\.\.)([\d-]+)/;
  }

  if (!defined $start || !defined $stop) {
    $start = $self->min unless defined $start;
    $stop  = $self->max unless defined $stop;
  }

  my $new_segment   = Bio::Graphics::Feature->new(-start=>$start,-stop=>$stop);
  my @panel_options = %$options if $options && ref $options eq 'HASH';
  my $panel = Bio::Graphics::Panel->new(-segment   => $new_segment,
					-width     => $width,
					-key_style => 'between',
					$self->style('general'),
					@panel_options
      );
  $panel;
}

sub mtime {
  my $self = shift;
  my $d = $self->{m_time} || $self->{stat}->[9];
  $self->{m_time} = shift if @_;
  $d;
}
sub atime { shift->{stat}->[8];  }
sub ctime { shift->{stat}->[10]; }
sub size  { shift->{stat}->[7];  }

sub feature2label {
  my $self    = shift;
  my $feature = shift;
  my $type      = $feature->can('type') ? $feature->type 
                                        : $feature->primary_tag;
  $type or return;
  (my $basetype = $type) =~ s/:.+$//;
  my @labels    = $self->type2label($type);
  @labels       = $self->type2label($basetype) unless @labels;
  @labels       = ($type) unless @labels;
  wantarray ? @labels : $labels[0];
}

sub link_pattern {
  my $self     = shift;
  my ($linkrule,$feature,$panel,$dont_escape) = @_;

  $panel ||= 'Bio::Graphics::Panel';

  if (ref($linkrule) && ref($linkrule) eq 'CODE') {
    my $val = eval {$linkrule->($feature,$panel)};
    $self->_callback_complain(none=>"linkrule for $feature") if $@;
    return $val;
  }

  require CGI unless defined &CGI::escape;
  my $escape_method = $dont_escape ? sub {shift} : \&CGI::escape;

  my $n;
  $linkrule ||= ''; # prevent uninit warning
  my $seq_id  = $feature->can('seq_id') ? $feature->seq_id() : $feature->location->seq_id();
  $seq_id   ||= $feature->seq_id; #fallback
  $linkrule =~ s!\$(\w+)!
        $escape_method->(
        $1 eq 'ref'              ? (($n = $seq_id) && "$n") || ''
            : $1 eq 'name'         ? (($n = $feature->display_name) && "$n")     || ''
            : $1 eq 'class'        ? eval {$feature->class}  || ''
            : $1 eq 'type'         ? eval {$feature->method} || $feature->primary_tag || ''
            : $1 eq 'method'       ? eval {$feature->method} || $feature->primary_tag || ''
            : $1 eq 'source'       ? eval {$feature->source} || $feature->source_tag  || ''
            : $1 =~ 'seq_?id'      ? eval{$feature->seq_id} || eval{$feature->location->seq_id} || ''
            : $1 eq 'start'        ? $feature->start || ''
            : $1 eq 'end'          ? $feature->end   || ''
            : $1 eq 'stop'         ? $feature->end   || ''
            : $1 eq 'segstart'     ? $panel->start   || ''
            : $1 eq 'segend'       ? $panel->end     || ''
            : $1 eq 'length'       ? $feature->length || 0
            : $1 eq 'description'  ? eval {join '',$feature->notes} || ''
            : $1 eq 'id'           ? eval {$feature->feature_id} || eval {$feature->primary_id} || ''
            : '$'.$1
              )
		!exg;
  return $linkrule;
}

sub make_link {
  my $self             = shift;
  my ($feature,$panel) = @_;

  my ($linkrule) = $feature->each_tag_value('link');

  unless ($linkrule) {
      for my $label ($self->feature2label($feature)) {
	  $linkrule     ||= $self->setting($label,'link');
	  $linkrule     ||= $self->setting(general=>'link');
      }
  }
  return $self->link_pattern($linkrule,$feature,$panel);
}

sub make_title {
  my $self    = shift;
  my $feature = shift;

  for my $label ($self->feature2label($feature)) {
    my $linkrule     = $self->setting($label,'title');
    $linkrule      ||= $self->setting(general=>'title');
    next unless $linkrule;
    return $self->link_pattern($linkrule,$feature,undef,1);
  }

  my $method  = eval {$feature->method} || $feature->primary_tag;
  my $seqid   = $feature->can('seq_id')  ? $feature->seq_id : $feature->location->seq_id;
  my $title = eval {
    if ($feature->can('target') && (my $target = $feature->target)) {
      join (' ',
	    $method,
	    (defined $seqid ? "$seqid:" : '').
	    $feature->start."..".$feature->end,
	    $feature->target.':'.
	    $feature->target->start."..".$feature->target->end);
    } else {
      join(' ',
	   $method,
	   $feature->can('display_name') ? $feature->display_name : $feature->info,
	   (defined $seqid ? "$seqid:" : '').
	   ($feature->start||'?')."..".($feature->end||'?')
	  );
    }
  };
  warn $@ if $@;
  $title;
}

# given a feature type, return its label(s)
sub type2label {
  my $self = shift;
  my $type = shift;
  $self->{_type2label} ||= $self->invert_types;
  my @labels = keys %{$self->{_type2label}{lc $type}};
  wantarray ? @labels : $labels[0]
}

sub invert_types {
  my $self = shift;
  my $config  = $self->{config} or return;
  my %inverted;
  for my $label (keys %{$config}) {
      my $feature = $config->{$label}{feature} || $label;
      foreach (shellwords($feature||'')) {
	  $inverted{lc $_}{$label}++;
      }
  }
  \%inverted;
}

# This routine returns the "citation" field.  It is here in order to simplify the logic
# a bit in the generic browser
sub citation {
  my $self = shift;
  my $feature = shift || 'general';
  return $self->setting($feature=>'citation');
}

# give this feature file a nickname
sub name {
  my $self = shift;
  my $d = $self->{name};
  $self->{name} = shift if @_;
  $d;
}

1;

__END__