view release on metacpan or  search on metacpan

Ace/Graphics/GlyphFactory.pm  view on Meta::CPAN

package Ace::Graphics::GlyphFactory;
# parameters for creating sequence glyphs of various sorts
# you *do* like glyphs, don't you?

use strict;
use Carp qw(carp croak confess);
use Ace::Graphics::Glyph;
use GD;

sub DESTROY { }

sub new {
  my $class   = shift;
  my $type    = shift;
  my @options = @_;

  # normalize options
  my %options;
  while (my($key,$value) = splice (@options,0,2)) {
    $key =~ s/^-//;
    $options{lc $key} = $value;
  }
  $options{bgcolor}   ||= 'white';
  $options{fgcolor}   ||= 'black';
  $options{fillcolor} ||= 'turquoise';
  $options{height}    ||= 10;
  $options{font}      ||= gdSmallFont;
  $options{fontcolor} ||= 'black';

  $type = $options{glyph} if defined $options{glyph};

  my $glyphclass = 'Ace::Graphics::Glyph';
  $glyphclass .= "\:\:$type" if $type && $type ne 'generic';

    confess("the requested glyph class, ``$type'' is not available: $@")
      unless (eval "require $glyphclass");

  return bless {
		glyphclass => $glyphclass,
		scale      => 1,   # 1 pixel per kb
		options    => \%options,
	       },$class;
}

sub clone {
  my $self = shift;
  my %val = %$self;
  $val{options} = {%{$self->{options}}};
  return bless \%val,ref($self);
}

# set the scale for glyphs we create
sub scale {
  my $self = shift;
  my $g = $self->{scale};
  $self->{scale} = shift if @_;
  $g;
}

sub width {
  my $self = shift;
  my $g = $self->{width};
  $self->{width} = shift if @_;
  $g;
}

# font to draw with
sub font {
  my $self = shift;
  $self->option('font',@_);
}

# set the height for glyphs we create
sub height {
  my $self = shift;
  $self->option('height',@_);
}

sub options {
  my $self = shift;
  my $g = $self->{options};
  $self->{options} = shift if @_;
  $g;
}

sub panel {
  my $self = shift;
  my $g = $self->{panel};
  $self->{panel} = shift if @_;
  $g;
}

sub option {
  my $self        = shift;
  my $option_name = shift;
  my $o = $self->{options} or return;
  my $d = $o->{$option_name};
  $o->{$option_name} = shift if @_;
  $d;
}

# set the foreground and background colors
# expressed as GD color indices
sub _fgcolor {
  my $self = shift;
  my $c = $self->option('color',@_) || $self->option('fgcolor',@_) || $self->option('outlinecolor',@_);
  $self->translate($c);
}