t/t21draw.t

   1 # Before `make install' is performed this script should be runnable with
   2 # `make test'. After `make install' it should work as `perl test.pl'
   3
   4 ######################### We start with some black magic to print on failure.
   5
   6 # Change 1..1 below to 1..last_test_to_print .
   7 # (It may become useful if the test is moved to ./t subdirectory.)
   8 use strict;
   9 my $loaded;
  10
  11 BEGIN { $| = 1; print "1..29\n"; }
  12 END {print "not ok 1\n" unless $loaded;}
  13 use Imager qw/:all/;
  14 $loaded = 1;
  15 print "ok 1\n";
  16
  17 init_log("testout/t21draw.log",1);
  18
  19 my $redobj = NC(255, 0, 0);
  20 my $red = 'FF0000';
  21 my $greenobj = NC(0, 255, 0);
  22 my $green = [ 0, 255, 0 ];
  23 my $blueobj = NC(0, 0, 255);
  24 my $blue = { hue=>240, saturation=>1, value=>1 };
  25 my $white = '#FFFFFF';
  26
  27 my $testnum = 2;
  28
  29 my $img = Imager->new(xsize=>100, ysize=>100);
  30
  31 ok($img->box(color=>$blueobj, xmin=>10, ymin=>10, xmax=>48, ymax=>18),
  32    "box with color obj");
  33 ok($img->box(color=>$blue, xmin=>10, ymin=>20, xmax=>48, ymax=>28),
  34    "box with color");
  35 ok($img->box(color=>$redobj, xmin=>10, ymin=>30, xmax=>28, ymax=>48, filled=>1),
  36    "filled box with color obj");
  37 ok($img->box(color=>$red, xmin=>30, ymin=>30, xmax=>48, ymax=>48, filled=>1),
  38    "filled box with color");
  39
  40 ok($img->arc(x=>75, 'y'=>25, r=>24, color=>$redobj),
  41    "filled arc with colorobj");
  42
  43 ok($img->arc(x=>75, 'y'=>25, r=>20, color=>$green),
  44    "filled arc with colorobj");
  45 ok($img->arc(x=>75, 'y'=>25, r=>18, color=>$white, d1=>325, d2=>225),
  46    "filled arc with color");
  47
  48 ok($img->arc(x=>75, 'y'=>25, r=>18, color=>$blue, d1=>225, d2=>325),
  49    "filled arc with color");
  50 ok($img->arc(x=>75, 'y'=>25, r=>15, color=>$green, aa=>1),
  51    "filled arc with color");
  52
  53 ok($img->line(color=>$blueobj, x1=>5, y1=>55, x2=>35, y2=>95),
  54    "line with colorobj");
  55
  56 # FIXME - neither the start nor end-point is set for a non-aa line
  57 #my $c = Imager::i_get_pixel($img->{IMG}, 5, 55);
  58 #ok(color_cmp($c, $blueobj) == 0, "# TODO start point not set");
  59
  60 ok($img->line(color=>$red, x1=>10, y1=>55, x2=>40, y2=>95, aa=>1),
  61    "aa line with color");
  62 ok($img->line(color=>$green, x1=>15, y1=>55, x2=>45, y2=>95, antialias=>1),
  63    "antialias line with color");
  64
  65 ok($img->polyline(points=>[ [ 55, 55 ], [ 90, 60 ], [ 95, 95] ],
  66                   color=>$redobj),
  67    "polyline points with color obj");
  68 ok($img->polyline(x=>[ 55, 85, 90 ], 'y'=>[60, 65, 95], color=>$green, aa=>1),
  69    "polyline xy with color aa");
  70 ok($img->polyline(x=>[ 55, 80, 85 ], 'y'=>[65, 70, 95], color=>$green,
  71                   antialias=>1),
  72    "polyline xy with color antialias");
  73
  74 ok($img->setpixel(x=>[35, 37, 39], 'y'=>[55, 57, 59], color=>$red),
  75    "set array of pixels");
  76 ok($img->setpixel(x=>39, 'y'=>55, color=>$green),
  77    "set single pixel");
  78 use Imager::Color::Float;
  79 my $flred = Imager::Color::Float->new(1, 0, 0, 0);
  80 my $flgreen = Imager::Color::Float->new(0, 1, 0, 0);
  81 ok($img->setpixel(x=>[41, 43, 45], 'y'=>[55, 57, 59], color=>$flred),
  82    "set array of float pixels");
  83 ok($img->setpixel(x=>45, 'y'=>55, color=>$flgreen),
  84    "set single float pixel");
  85 my @gp = $img->getpixel(x=>[41, 43, 45], 'y'=>[55, 57, 59]);
  86 ok(grep($_->isa('Imager::Color'), @gp) == 3, "check getpixel result type");
  87 ok(grep(color_cmp($_, NC(255, 0, 0)) == 0, @gp) == 3,
  88    "check getpixel result colors");
  89 my $gp = $img->getpixel(x=>45, 'y'=>55);
  90 ok($gp->isa('Imager::Color'), "check scalar getpixel type");
  91 ok(color_cmp($gp, NC(0, 255, 0)) == 0, "check scalar getpixel color");
  92 @gp = $img->getpixel(x=>[35, 37, 39], 'y'=>[55, 57, 59], type=>'float');
  93 ok(grep($_->isa('Imager::Color::Float'), @gp) == 3,
  94    "check getpixel float result type");
  95 ok(grep(color_cmp($_, $flred) == 0, @gp) == 3,
  96    "check getpixel float result type");
  97 $gp = $img->getpixel(x=>39, 'y'=>55, type=>'float');
  98 ok($gp->isa('Imager::Color::Float'), "check scalar float getpixel type");
  99 ok(color_cmp($gp, $flgreen) == 0, "check scalar float getpixel color");
 100
 101 ok($img->write(file=>'testout/t21draw.ppm'),
 102    "saving output");
 103
 104 malloc_state();
 105
 106 sub ok {
 107   my ($ok, $msg) = @_;
 108
 109   if ($ok) {
 110     print "ok ",$testnum++,"\n";
 111   }
 112   else {
 113     print "not ok ",$testnum++," # $msg\n";
 114   }
 115 }
 116
 117 sub color_cmp {
 118   my ($l, $r) = @_;
 119   my @l = $l->rgba;
 120   my @r = $r->rgba;
 121   # print "# (",join(",", @l[0..2]),") <=> (",join(",", @r[0..2]),")\n";
 122   return $l[0] <=> $r[0]
 123     || $l[1] <=> $r[1]
 124       || $l[2] <=> $r[2];
 125 }