remove 5.005 inappropriate use warnings
[imager-graph.git] / Graph.pm
index 7a2f404eb0c5fc7b77de5532bbccfec187321db8..93e05f8c1a3e4c061f49c6adf0cb26587b8f12ed 100644 (file)
--- a/Graph.pm
+++ b/Graph.pm
@@ -9,7 +9,7 @@ Imager::Graph - Perl extension for producing Graphs using the Imager library.
 
   use Imager::Graph::SubClass;
   my $chart = Imager::Graph::SubClass->new;
-  my $img = $chart->draw(data=>..., ...)
+  my $img = $chart->draw(data=> \@data, ...)
     or die $chart->error;
 
 =head1 DESCRIPTION
@@ -19,15 +19,6 @@ defines the colors, text display information and fills based on both
 built-in styles and modifications supplied by the user to the draw()
 method.
 
-For best results you need a version of Imager after 0.38.  At the time
-of writing this is only available via CVS:
-
-  cvs -d :pserver:anoncvs@cvs.imager.perl.org:/u02/cvsroot login
-  cvs -d :pserver:anoncvs@cvs.imager.perl.org:/u02/cvsroot co Imager
-
-This provides extra file format support, fountain (gradient), hatch
-and image fills, and masked images.
-
 =over
 
 =cut
@@ -37,7 +28,7 @@ use vars qw($VERSION);
 use Imager qw(:handy);
 use Imager::Fountain;
 
-$VERSION = '0.05';
+$VERSION = '0.06';
 
 # the maximum recursion depth in determining a color, fill or number
 use constant MAX_DEPTH => 10;
@@ -79,10 +70,16 @@ the value can be a hashref containing sub values.
 The C<style> parameter will selects a basic color set, and possibly
 sets other related parameters.  See L</"STYLES">.
 
-  my $img = $graph->draw(data=>\@data,
-                         title=>{ text=>"Hello, World!",
-                                  size=>36,
-                                  color=>'FF0000' });
+ my $font = Imager::Font->new(file => 'ImUgly.ttf');
+ my $img = $chart->draw(
+                 data    => \@data,
+                 font    => $font,
+                 title   => {
+                                 text  => "Hello, World!",
+                                 size  => 36,
+                                 color => 'FF0000'
+                            }
+                 );
 
 When referring to a single sub-value this documentation will refer to
 'title.color' rather than 'the color element of title'.
@@ -97,15 +94,20 @@ The currently defined styles are:
 
 =over
 
+=item primary
+
+a light grey background with no outlines.  Uses primary colors for the
+data fills.
+
 =item primary_red
 
 a light red background with no outlines.  Uses primary colors for the
-data fills.  This style is compatible with all versions of Imager.
+data fills.
 
 Graphs drawn using this style should save well as a gif, even though
 some graphs may perform a slight blur.
 
-This is the default style.
+This was the default style, but the red was too loud.
 
 =item mono
 
@@ -122,8 +124,6 @@ background, by supplying C<<bg=>'00000000', channels=>4>>.
 
 This style outlines the legend if present and outlines the hashed fills.
 
-This and following styles require versions of Imager after 0.38.
-
 =item fount_lin
 
 designed as a "pretty" style this uses linear fountain fills for the
@@ -132,6 +132,8 @@ background and data fills, and adds a drop shadow.
 You can override the value used for text and outlines by setting the
 C<fg> parameter.
 
+This is the default style.
+
 =item fount_rad
 
 also designed as a "pretty" style this uses radial fountain fills for
@@ -389,8 +391,28 @@ the background fill for the legend.  Default: none
 the border color of the legend.  Default: none (no border is drawn
 around the legend.)
 
+=item orientation
+
+The orientation of the legend.  If this is C<vertical> the the patches
+and labels are stacked on top of each other.  If this is C<horizontal>
+the patchs and labels are word wrapped across the image.  Default:
+vertical.
+
 =back
 
+For example to create a horizontal legend with borderless patches,
+darker than the background, you might do:
+
+  my $im = $chart->draw
+    (...,
+    legend =>
+    {
+      patchborder => undef,
+      orientation => 'horizontal',
+      fill => { solid => Imager::Color->new(0, 0, 0, 32), }
+    },
+    ...);
+
 =item callout
 
 defines attributes for graph callouts, if any are present.  eg. if the
@@ -537,8 +559,7 @@ Fills can be used for the graph background color, the background color
 for the legend block and for the fills used for each data element.
 
 You can specify a fill as a L<color value|Specifying colors> or as a
-general fill, see L<Imager::Fill> for details.  To use a general fill
-you need a version of Imager after 0.38.
+general fill, see L<Imager::Fill> for details.
 
 You don't need (or usually want) to call Imager::Fill::new yourself,
 since the various fill functions will call it for you, and
@@ -562,6 +583,9 @@ define the fountain fills xa, ya, xb and yb parameters.
 As with colors, you can use lookup(name) or lookup(name1.name2) to
 have one element to inherit the fill of another.
 
+Imager::Graph defaults the fill combine value to C<'normal'>.  This
+doesn't apply to simple color fills.
+
 =head2 Specifying numbers
 
 You can specify various numbers, usually representing the size of
@@ -639,7 +663,7 @@ my %style_defs =
              pconlyformat  => sub { sprintf "%.1f%%", $_[0] },
             },
    dropshadow => {
-                  fill    => '404040',
+                  fill    => { solid => Imager::Color->new(0, 0, 0, 96) },
                   off     => 'scale(0.4,text.size)',
                   offx    => 'lookup(dropshadow.off)',
                   offy    => 'lookup(dropshadow.off)',
@@ -662,6 +686,14 @@ Sets the error field of the object and returns an empty list or undef,
 depending on context.  Should be used for error handling, since it may
 provide some user hooks at some point.
 
+The intended usage is:
+
+  some action
+    or return $self->_error("error description");
+
+You should almost always return the result of _error() or return
+immediately afterwards.
+
 =cut
 
 sub _error {
@@ -687,10 +719,24 @@ sub _style_defs {
   \%style_defs;
 }
 
-my $def_style = 'primary_red';
+# Let's make the default something that looks really good, so folks will be interested enough to customize the style.
+my $def_style = 'fount_lin';
 
 my %styles =
   (
+   primary =>
+   {
+    fills=>
+    [
+     qw(FF0000 00FF00 0000FF C0C000 00C0C0 FF00FF)
+    ],
+    fg=>'000000',
+    bg=>'E0E0E0',
+    legend=>
+    {
+     #patchborder=>'000000'
+    },
+   },
    primary_red =>
    {
     fills=>
@@ -731,7 +777,6 @@ my %styles =
     [
      { fountain=>'linear',
        xa_ratio=>0.13, ya_ratio=>0.13, xb_ratio=>0.87, yb_ratio=>0.87,
-       repeat=>'sawtooth',
        segments => Imager::Fountain->simple(positions=>[0, 1],
                                            colors=>[ NC('FFC0C0'), NC('FF0000') ]),
      },
@@ -894,6 +939,8 @@ Retrieve some general 'thing'.
 
 Supports the 'lookup(foo)' mechanism.
 
+Returns an empty list on failure.
+
 =cut
 
 sub _get_thing {
@@ -935,7 +982,7 @@ Recursively looks up I<newname> in the style.
 
 =item scale(value1,value2)
 
-Each value can be a number or a name.  Names are recursively looks up
+Each value can be a number or a name.  Names are recursively looked up
 in the style and the product is returned.
 
 =back
@@ -990,6 +1037,24 @@ sub _get_number {
   }
 }
 
+=item $self->_get_integer($name)
+
+Retrieves an integer from the style.  This is a simple wrapper around
+_get_number() that rounds the result to an integer.
+
+Returns an empty list on failure.
+
+=cut
+
+sub _get_integer {
+  my ($self, $name, @depth) = @_;
+
+  my $number = $self->_get_number($name, @depth)
+    or return;
+
+  return sprintf("%.0f", $number);
+}
+
 =item _get_color($name)
 
 Returns a color object of the given name from the style hash.
@@ -998,6 +1063,8 @@ Uses Imager::Color->new to translate normal scalars into color objects.
 
 Allows the lookup(name) mechanism.
 
+Returns an empty list on failure.
+
 =cut
 
 sub _get_color {
@@ -1038,6 +1105,8 @@ the 'lookup(name)' mechanism.
 This function does the fg and bg initialization for hatched fills, and
 translation of *_ratio for fountain fills (using the $box parameter).
 
+Returns an empty list on failure.
+
 =cut
 
 sub _translate_fill {
@@ -1049,8 +1118,9 @@ sub _translate_fill {
     }
     else {
       # a general fill
+      # default to normal combine mode
+      my %work = ( combine => 'normal', %$what );
       if ($what->{hatch}) {
-       my %work = %$what;
        if (!$work{fg}) {
          $work{fg} = $self->_get_color('fg')
            or return;
@@ -1062,7 +1132,6 @@ sub _translate_fill {
        return ( fill=>\%work );
       }
       elsif ($what->{fountain}) {
-       my %work = %$what;
        for my $key (qw(xa ya xb yb)) {
          if (exists $work{"${key}_ratio"}) {
            if ($key =~ /^x/) {
@@ -1078,7 +1147,7 @@ sub _translate_fill {
        return ( fill=>\%work );
       }
       else {
-       return ( fill=> $what );
+       return ( fill=> \%work );
       }
     }
   }
@@ -1140,11 +1209,9 @@ fill.
 
 sub _make_img {
   my ($self) = @_;
-  
-  my ($width, $height) = (256, 256);
 
-  $width = $self->_get_number('width');
-  $height = $self->_get_number('height');
+  my $width = $self->_get_number('width') || 256;
+  my $height = $self->_get_number('height') || 256;
   my $channels = $self->{_style}{channels};
 
   $channels ||= 3;
@@ -1156,6 +1223,15 @@ sub _make_img {
   $img;
 }
 
+=item _text_style($name)
+
+Returns parameters suitable for calls to Imager::Font's bounding_box()
+and draw() methods intended for use in defining text styles.
+
+Returns an empty list on failure.
+
+=cut
+
 sub _text_style {
   my ($self, $name) = @_;
 
@@ -1168,10 +1244,10 @@ sub _text_style {
     %work = %{$self->{_style}{text}};
   }
   $work{font}
-      or return $self->_error("$name has no font parameter");
+    or return $self->_error("$name has no font parameter");
 
   $work{font} = $self->_get_thing("$name.font")
-    or return $self->_error("invalid font");
+    or return $self->_error("No $name.font defined, either set $name.font or font to a font");
   UNIVERSAL::isa($work{font}, "Imager::Font")
       or return $self->_error("$name.font is not a font");
   if ($work{color} && !ref $work{color}) {
@@ -1185,10 +1261,19 @@ sub _text_style {
   %work;
 }
 
+=item _text_bbox($text, $name)
+
+Returns a bounding box for the specified $text as styled by $name.
+
+Returns an empty list on failure.
+
+=cut
+
 sub _text_bbox {
   my ($self, $text, $name) = @_;
 
-  my %text_info = $self->_text_style($name);
+  my %text_info = $self->_text_style($name)
+    or return;
 
   my @bbox = $text_info{font}->bounding_box(%text_info, string=>$text,
                                            canon=>1);
@@ -1280,17 +1365,136 @@ sub _remove_box {
 sub _draw_legend {
   my ($self, $img, $labels, $chart_box) = @_;
 
-  defined(my $padding = $self->_get_number('legend.padding'))
+  my $orient = $self->_get_thing('legend.orientation');
+  defined $orient or $orient = 'vertical';
+
+  if ($orient eq 'vertical') {
+    return $self->_draw_legend_vertical($img, $labels, $chart_box);
+  }
+  elsif ($orient eq 'horizontal') {
+    return $self->_draw_legend_horizontal($img, $labels, $chart_box);
+  }
+  else {
+    return $self->_error("Unknown legend.orientation $orient");
+  }
+}
+
+sub _draw_legend_horizontal {
+  my ($self, $img, $labels, $chart_box) = @_;
+
+  defined(my $padding = $self->_get_integer('legend.padding'))
+    or return;
+  my $patchsize = $self->_get_integer('legend.patchsize')
+    or return;
+  defined(my $gap = $self->_get_integer('legend.patchgap'))
+    or return;
+
+  my $minrowsize = $patchsize + $gap;
+  my ($width, $height) = (0,0);
+  my $row_height = $minrowsize;
+  my $pos = 0;
+  my @sizes;
+  my @offsets;
+  for my $label (@$labels) {
+    my @text_box = $self->_text_bbox($label, 'legend')
+      or return;
+    push(@sizes, \@text_box);
+    my $entry_width = $patchsize + $gap + $text_box[2];
+    if ($pos == 0) {
+      # never re-wrap the first entry
+      push @offsets, [ 0, $height ];
+    }
+    else {
+      if ($pos + $gap + $entry_width > $chart_box->[2]) {
+       $pos = 0;
+       $height += $row_height;
+      }
+      push @offsets, [ $pos, $height ];
+    }
+    my $entry_right = $pos + $entry_width;
+    $pos += $gap + $entry_width;
+    $entry_right > $width and $width = $entry_right;
+    if ($text_box[3] > $row_height) {
+      $row_height = $text_box[3];
+    }
+  }
+  $height += $row_height;
+  my @box = ( 0, 0, $width + $padding * 2, $height + $padding * 2 );
+  my $outsidepadding = 0;
+  if ($self->{_style}{legend}{border}) {
+    defined($outsidepadding = $self->_get_integer('legend.outsidepadding'))
+      or return;
+    $box[2] += 2 * $outsidepadding;
+    $box[3] += 2 * $outsidepadding;
+  }
+  $self->_align_box(\@box, $chart_box, 'legend')
+    or return;
+  if ($self->{_style}{legend}{fill}) {
+    $img->box(xmin=>$box[0]+$outsidepadding, 
+              ymin=>$box[1]+$outsidepadding, 
+              xmax=>$box[2]-$outsidepadding, 
+              ymax=>$box[3]-$outsidepadding,
+            $self->_get_fill('legend.fill', \@box));
+  }
+  $box[0] += $outsidepadding;
+  $box[1] += $outsidepadding;
+  $box[2] -= $outsidepadding;
+  $box[3] -= $outsidepadding;
+  my %text_info = $self->_text_style('legend')
+    or return;
+  my $patchborder;
+  if ($self->{_style}{legend}{patchborder}) {
+    $patchborder = $self->_get_color('legend.patchborder')
+      or return;
+  }
+  
+  my $dataindex = 0;
+  for my $label (@$labels) {
+    my ($left, $top) = @{$offsets[$dataindex]};
+    $left += $box[0] + $padding;
+    $top += $box[1] + $padding;
+    my $textpos = $left + $patchsize + $gap;
+    my @patchbox = ( $left, $top,
+                     $left + $patchsize, $top + $patchsize );
+    my @fill = $self->_data_fill($dataindex, \@patchbox)
+      or return;
+    $img->box(xmin=>$left, ymin=>$top, xmax=>$left + $patchsize,
+              ymax=>$top + $patchsize, @fill);
+    if ($self->{_style}{legend}{patchborder}) {
+      $img->box(xmin=>$left, ymin=>$top, xmax=>$left + $patchsize,
+               ymax=>$top + $patchsize,
+               color=>$patchborder);
+    }
+    $img->string(%text_info, x=>$textpos, 'y'=>$top + $patchsize, 
+                 text=>$label);
+
+    ++$dataindex;
+  }
+  if ($self->{_style}{legend}{border}) {
+    my $border_color = $self->_get_color('legend.border')
+      or return;
+    $img->box(xmin=>$box[0], ymin=>$box[1], xmax=>$box[2], ymax=>$box[3],
+             color=>$border_color);
+  }
+  $self->_remove_box($chart_box, \@box);
+  1;
+}
+
+sub _draw_legend_vertical {
+  my ($self, $img, $labels, $chart_box) = @_;
+
+  defined(my $padding = $self->_get_integer('legend.padding'))
     or return;
-  my $patchsize = $self->_get_number('legend.patchsize')
+  my $patchsize = $self->_get_integer('legend.patchsize')
     or return;
-  defined(my $gap = $self->_get_number('legend.patchgap'))
+  defined(my $gap = $self->_get_integer('legend.patchgap'))
     or return;
   my $minrowsize = $patchsize + $gap;
   my ($width, $height) = (0,0);
   my @sizes;
   for my $label (@$labels) {
-    my @box = $self->_text_bbox($label, 'legend');
+    my @box = $self->_text_bbox($label, 'legend')
+      or return;
     push(@sizes, \@box);
     $width = $box[2] if $box[2] > $width;
     if ($minrowsize > $box[3]) {
@@ -1305,7 +1509,7 @@ sub _draw_legend {
             $height + $padding * 2 - $gap);
   my $outsidepadding = 0;
   if ($self->{_style}{legend}{border}) {
-    defined($outsidepadding = $self->_get_number('legend.outsidepadding'))
+    defined($outsidepadding = $self->_get_integer('legend.outsidepadding'))
       or return;
     $box[2] += 2 * $outsidepadding;
     $box[3] += 2 * $outsidepadding;
@@ -1372,11 +1576,13 @@ sub _draw_title {
   my ($self, $img, $chart_box) = @_;
 
   my $title = $self->{_style}{title}{text};
-  my @box = $self->_text_bbox($title, 'title');
+  my @box = $self->_text_bbox($title, 'title')
+    or return;
   my $yoff = $box[1];
   @box[0,1] = (0,0);
   $self->_align_box(\@box, $chart_box, 'title');
-  my %text_info = $self->_text_style('title');
+  my %text_info = $self->_text_style('title')
+    or return;
   $img->string(%text_info, x=>$box[0], 'y'=>$box[3] + $yoff, text=>$title);
   $self->_remove_box($chart_box, \@box);
   1;