view release on metacpan or  search on metacpan

lib/Bio/Graphics/Glyph/image.pm  view on Meta::CPAN

    image => [
	'string',
	undef,
	'Specify the image path or URL to use for the feature.',
	'If no image option is specified, then the glyph will look',
	'inside the feature itself for an image path or URL in a tag named "image"',
	],
    image_prefix => [
	    'string',
	    undef,
	    'A string to prepend to each image path.',
	    'You may use this to prepend a directory path or a partial URL.'],
    vertical_spacing => [
	    'integer',
	    20,
	    'Vertical distance from the box that shows the physical span of the',
	    'feature to the top of the picture, in pixels.'],
    glyph_delegate => [
	'string',
	'generic',
	'The glyph to use for the part of the glyph that shows the physical',
	'span of features.']
    }
}

sub demo_feature {
    my $self = shift;
    my $ex_image = 
	'http://www.catch-fly.com/sites/awhittington/_files/Image/Drosophila-melanogaster.jpg';
    return Bio::Graphics::Feature->new(-start=>1,
				       -end=>500,
				       -name=>$ex_image,
				       -attributes => {
					   image=>$ex_image,
				       },
	);
}

sub new {
  my $self  = shift->SUPER::new(@_);
  $self->{image} = $self->get_image();
  return $self;
}

sub get_image {
  my $self    = shift;
  my ($format,$image)   = eval { $self->image_data };
  unless ($image) {
    warn $@ if $@;
    return;
  }
  my $gd      =   $format eq 'image/png'  ? GD::Image->newFromPngData($image,1)
                : $format eq 'image/jpeg' ? GD::Image->newFromJpegData($image,1)
		: $format eq 'image/gif'  ? GD::Image->newFromGifData($image)
		: $format eq 'image/gd'   ? GD::Image->newFromGdData($image)
		: $format eq 'image/gd2'  ? GD::Image->newFromGd2Data($image)
		: $self->throw("This module cannot handle images of type $format");
  return $gd;
}

sub _guess_format {
  my $self = shift;
  my $path = shift;
  return 'image/png'   if $path =~ /\.png$/i;
  return 'image/jpeg'  if $path =~ /\.jpe?g$/i;
  return 'image/gif'   if $path =~ /\.gif(87)?$/i;
  return 'image/gd'    if $path =~ /\.gd$/i;
  return 'image/gd2'   if $path =~ /\.gd2$/i;
  my ($extension) = $path =~ /\.(\w+)$/;  #cop-out
  return $extension;
}

sub image_path {
  my $self = shift;
  my $feature  = $self->feature  or $self->throw("no feature!");
  my $dirname  = $self->image_dir;
  my $basename = $self->option('image');

  # can't get it from callback, so try looking for an 'image' attribute
  if (!$basename && $feature->can('has_tag') && $feature->has_tag('image')) {
    ($basename)  = $feature->get_tag_values('image');
  }

  return unless $basename;
  return $basename             if $basename =~ m!^\w+:/!;  # looks like a URL
  return $basename             if $basename =~ m!^/!;      # looks like an abs path
  return "$dirname/$basename";
}

sub image_data {
  my $self = shift;
  my $path = $self->image_path or return;

  if ($path =~ m!^\w+:/!) { # looks like a URL
    require LWP::UserAgent;
    my $ua = LWP::UserAgent->new(env_proxy => 1);
    my $response = $ua->get($path);
    if ($response->is_success) {
      return ($response->content_type,$response->content);
    } else {
      $self->throw($response->status_line);
    }


  } else {
    my $content_type = $self->_guess_format($path);
    open F,$path or $self->throw("Can't open $path: $!");
    binmode F;
    my $data;
    $data .= $_ while read(F,$_,1024);
    close F;
    return ($content_type,$data);
  }
}

sub pad_left {
  my $self = shift;
  my $pad          = $self->SUPER::pad_left;
  my $image        = $self->{image} or return $pad;
  my $width_needed = ($image->width - $self->width)/2;
  return $pad > $width_needed ? $pad : $width_needed;
}

sub pad_right {
  my $self = shift;
  my $pad          = $self->SUPER::pad_right;
  my $image        = $self->{image} or return $pad;
  my $width_needed = ($image->width - $self->width)/2;
  return $pad > $width_needed ? $pad : $width_needed;
}

sub pad_bottom {
  my $self   = shift;
  my $pb     = $self->SUPER::pad_bottom;
  my $image  = $self->{image} or return $pb;
  $pb       += $self->vertical_spacing;
  $pb       += $image->height;
  return $pb;
}

sub vertical_spacing {
  my $self  = shift;
  my $vs    = $self->option('vertical_spacing');
  return $vs if defined $vs;
  return VERTICAL_SPACING;
}

sub draw_description {
  my $self = shift;
  my ($gd,$left,$top,$partno,$total_parts) = @_;
  $self->SUPER::draw_description($gd,$left,$top,$partno,$total_parts);
}

sub image_dir {
  my $self = shift;
  return $self->option('image_prefix');
}

sub draw_component {
  my $self  = shift;
  my $gd    = shift;
  my($x1,$y1,$x2,$y2) = $self->bounds(@_);

  my $delegate = $self->option('glyph_delegate') || 'generic';
  if ($delegate eq 'generic') {
    $self->SUPER::draw_component($gd,@_);