]>
Commit | Line | Data |
---|---|---|
ec6d8908 TC |
1 | #!perl -w |
2 | # Before `make install' is performed this script should be runnable with | |
3 | # `make test'. After `make install' it should work as `perl test.pl' | |
4 | ||
5 | ######################### We start with some black magic to print on failure. | |
6 | ||
7 | # Change 1..1 below to 1..last_test_to_print . | |
8 | # (It may become useful if the test is moved to ./t subdirectory.) | |
9 | ||
10 | ||
11 | use strict; | |
12 | use Test::More tests => 21; | |
13 | ||
14 | use Imager qw(:all :handy); | |
15 | use Imager::Test qw(test_image is_color3); | |
16 | ||
40e78f96 TC |
17 | -d "testout" or mkdir "testout"; |
18 | ||
ec6d8908 TC |
19 | Imager::init('log'=>'testout/t70newgif.log'); |
20 | ||
21 | my $green=i_color_new(0,255,0,0); | |
22 | my $blue=i_color_new(0,0,255,0); | |
23 | ||
24 | { | |
25 | my $img = test_image(); | |
26 | ||
27 | ok($img->write(file=>'testout/t70newgif.gif',type=>'gif',gifplanes=>1,gifquant=>'lm',lmfixed=>[$green,$blue])) | |
28 | or print "# failed: ",$img->{ERRSTR}, "\n"; | |
29 | } | |
30 | ||
31 | SKIP: | |
32 | { | |
33 | # make sure the palette is loaded properly (minimal test) | |
34 | my $im2 = Imager->new(); | |
35 | my $map; | |
36 | ok($im2->read(file=>'testimg/bandw.gif', colors=>\$map)) | |
37 | or skip("Can't load bandw.gif", 5); | |
38 | # check the palette | |
39 | ok($map) | |
40 | or skip("No palette", 4); | |
41 | is(@$map, 2) | |
42 | or skip("Bad map count", 3); | |
43 | my @sorted = sort { comp_entry($a,$b) } @$map; | |
44 | # first entry must be #000000 and second #FFFFFF | |
45 | is_color3($sorted[0], 0,0,0, "check first palette entry"); | |
46 | is_color3($sorted[1], 255,255,255, "check second palette entry"); | |
47 | } | |
48 | ||
49 | { | |
50 | # test the read_multi interface | |
51 | my @imgs = Imager->read_multi(); | |
52 | ok(!@imgs, "read with no sources should fail"); | |
53 | like(Imager->errstr, qr/callback parameter missing/, "check error"); | |
54 | print "# ",Imager->errstr,"\n"; | |
55 | ||
56 | @imgs = Imager->read_multi(type=>'gif'); | |
57 | ok(!@imgs, "read multi no source but type should fail"); | |
58 | like(Imager->errstr, qr/file/, "check error"); | |
59 | ||
60 | # kill warning | |
61 | *NONESUCH = \20; | |
62 | @imgs = Imager->read_multi(type=>'gif', fh=>*NONESUCH); | |
63 | ok(!@imgs, "read from bad fh"); | |
64 | like(Imager->errstr, qr/fh option not open/, "check message"); | |
65 | print "# ",Imager->errstr,"\n"; | |
66 | { | |
67 | @imgs = Imager->read_multi(type=>'gif', file=>'testimg/screen2.gif'); | |
68 | is(@imgs, 2, "should read 2 images"); | |
69 | isa_ok($imgs[0], "Imager"); | |
70 | isa_ok($imgs[1], "Imager"); | |
71 | is($imgs[0]->type, "paletted"); | |
72 | is($imgs[1]->type, "paletted"); | |
73 | my @left = $imgs[0]->tags(name=>'gif_left'); | |
74 | is(@left, 1); | |
75 | my $left = $imgs[1]->tags(name=>'gif_left'); | |
76 | is($left, 3); | |
77 | } | |
78 | { | |
79 | open FH, "< testimg/screen2.gif" | |
80 | or die "Cannot open testimg/screen2.gif: $!"; | |
81 | binmode FH; | |
82 | my $cb = | |
83 | sub { | |
84 | my $tmp; | |
85 | read(FH, $tmp, $_[0]) and $tmp | |
86 | }; | |
87 | @imgs = Imager->read_multi(type=>'gif', | |
88 | callback => $cb); | |
89 | close FH; | |
90 | is(@imgs, 2, "read multi from callback"); | |
91 | ||
92 | open FH, "< testimg/screen2.gif" | |
93 | or die "Cannot open testimg/screen2.gif: $!"; | |
94 | binmode FH; | |
95 | my $data = do { local $/; <FH>; }; | |
96 | close FH; | |
97 | @imgs = Imager->read_multi(type=>'gif', | |
98 | data=>$data); | |
99 | is(@imgs, 2, "read multi from data"); | |
100 | } | |
101 | } | |
102 | ||
103 | sub comp_entry { | |
104 | my ($l, $r) = @_; | |
105 | my @l = $l->rgba; | |
106 | my @r = $r->rgba; | |
107 | return $l[0] <=> $r[0] | |
108 | || $l[1] <=> $r[1] | |
109 | || $l[2] <=> $r[2]; | |
110 | } |