projects / imager.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
make sure we can see the supplied copy of Test::More
[imager.git] / Imager.pm
CommitLineData
02d1d628
AMH		 1package Imager;
2
02d1d628 3use strict;
97c4effc 4use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR $fontstate %OPCODES $I2P $FORMATGUESS $warn_obsolete);
02d1d628
AMH		 5use IO::File;
6
7use Imager::Color;
8use Imager::Font;
9
10@EXPORT_OK = qw(
11 init
12 init_log
13 DSO_open
14 DSO_close
15 DSO_funclist
16 DSO_call
dd55acc8 17
02d1d628
AMH		 18 load_plugin
19 unload_plugin
dd55acc8 20
02d1d628
AMH		 21 i_list_formats
22 i_has_format
dd55acc8 23
02d1d628
AMH		 24 i_color_new
25 i_color_set
26 i_color_info
dd55acc8 27
02d1d628
AMH		 28 i_img_empty
29 i_img_empty_ch
30 i_img_exorcise
31 i_img_destroy
32
33 i_img_info
34
35 i_img_setmask
36 i_img_getmask
37
aa833c97 38 i_line
02d1d628
AMH		 39 i_line_aa
40 i_box
41 i_box_filled
42 i_arc
18063344 43 i_circle_aa
dd55acc8 44
02d1d628
AMH		 45 i_bezier_multi
46 i_poly_aa
43c5dacb 47 i_poly_aa_cfill
02d1d628
AMH		 48
49 i_copyto
50 i_rubthru
51 i_scaleaxis
52 i_scale_nn
53 i_haar
54 i_count_colors
dd55acc8 55
02d1d628
AMH		 56 i_gaussian
57 i_conv
dd55acc8 58
f5991c03 59 i_convert
40eba1ea 60 i_map
dd55acc8 61
02d1d628
AMH		 62 i_img_diff
63
64 i_init_fonts
65 i_t1_new
66 i_t1_destroy
67 i_t1_set_aa
68 i_t1_cp
69 i_t1_text
70 i_t1_bbox
71
02d1d628
AMH		 72 i_tt_set_aa
73 i_tt_cp
74 i_tt_text
75 i_tt_bbox
76
02d1d628
AMH		 77 i_readjpeg_wiol
78 i_writejpeg_wiol
79
80 i_readtiff_wiol
81 i_writetiff_wiol
d2dfdcc9 82 i_writetiff_wiol_faxable
02d1d628 83
790923a4
AMH		 84 i_readpng_wiol
85 i_writepng_wiol
02d1d628
AMH		 86
87 i_readgif
10461f9a 88 i_readgif_wiol
02d1d628
AMH		 89 i_readgif_callback
90 i_writegif
91 i_writegifmc
92 i_writegif_gen
93 i_writegif_callback
94
95 i_readpnm_wiol
067d6bdc 96 i_writeppm_wiol
02d1d628 97
895dbd34
AMH		 98 i_readraw_wiol
99 i_writeraw_wiol
02d1d628
AMH		 100
101 i_contrast
102 i_hardinvert
103 i_noise
104 i_bumpmap
105 i_postlevels
106 i_mosaic
107 i_watermark
dd55acc8 108
02d1d628
AMH		 109 malloc_state
110
111 list_formats
dd55acc8 112
02d1d628
AMH		 113 i_gifquant
114
115 newfont
116 newcolor
117 newcolour
118 NC
119 NF
02d1d628
AMH		 120);
121
9982a307 122@EXPORT=qw(
02d1d628
AMH		 123 init_log
124 i_list_formats
125 i_has_format
126 malloc_state
127 i_color_new
128
129 i_img_empty
130 i_img_empty_ch
131 );
132
133%EXPORT_TAGS=
134 (handy => [qw(
135 newfont
136 newcolor
137 NF
138 NC
139 )],
140 all => [@EXPORT_OK],
141 default => [qw(
142 load_plugin
143 unload_plugin
144 )]);
145
02d1d628
AMH		 146BEGIN {
147 require Exporter;
148 require DynaLoader;
149
ae7124a6 150 $VERSION = '0.44';
02d1d628
AMH		 151 @ISA = qw(Exporter DynaLoader);
152 bootstrap Imager $VERSION;
153}
154
155BEGIN {
156 i_init_fonts(); # Initialize font engines
faa9b3e7 157 Imager::Font::__init();
02d1d628
AMH		 158 for(i_list_formats()) { $formats{$_}++; }
159
160 if ($formats{'t1'}) {
161 i_t1_set_aa(1);
162 }
163
faa9b3e7
TC		 164 if (!$formats{'t1'} and !$formats{'tt'}
165 && !$formats{'ft2'} && !$formats{'w32'}) {
02d1d628
AMH		 166 $fontstate='no font support';
167 }
168
169 %OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
170
171 $DEBUG=0;
172
6607600c
TC		 173 # the members of the subhashes under %filters are:
174 # callseq - a list of the parameters to the underlying filter in the
175 # order they are passed
176 # callsub - a code ref that takes a named parameter list and calls the
177 # underlying filter
178 # defaults - a hash of default values
179 # names - defines names for value of given parameters so if the names
180 # field is foo=> { bar=>1 }, and the user supplies "bar" as the
181 # foo parameter, the filter will receive 1 for the foo
182 # parameter
02d1d628
AMH		 183 $filters{contrast}={
184 callseq => ['image','intensity'],
185 callsub => sub { my %hsh=@_; i_contrast($hsh{image},$hsh{intensity}); }
186 };
187
188 $filters{noise} ={
189 callseq => ['image', 'amount', 'subtype'],
190 defaults => { amount=>3,subtype=>0 },
191 callsub => sub { my %hsh=@_; i_noise($hsh{image},$hsh{amount},$hsh{subtype}); }
192 };
193
194 $filters{hardinvert} ={
195 callseq => ['image'],
196 defaults => { },
197 callsub => sub { my %hsh=@_; i_hardinvert($hsh{image}); }
198 };
199
200 $filters{autolevels} ={
201 callseq => ['image','lsat','usat','skew'],
202 defaults => { lsat=>0.1,usat=>0.1,skew=>0.0 },
203 callsub => sub { my %hsh=@_; i_autolevels($hsh{image},$hsh{lsat},$hsh{usat},$hsh{skew}); }
204 };
205
206 $filters{turbnoise} ={
207 callseq => ['image'],
208 defaults => { xo=>0.0,yo=>0.0,scale=>10.0 },
209 callsub => sub { my %hsh=@_; i_turbnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{scale}); }
210 };
211
212 $filters{radnoise} ={
213 callseq => ['image'],
214 defaults => { xo=>100,yo=>100,ascale=>17.0,rscale=>0.02 },
215 callsub => sub { my %hsh=@_; i_radnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{rscale},$hsh{ascale}); }
216 };
217
218 $filters{conv} ={
219 callseq => ['image', 'coef'],
220 defaults => { },
221 callsub => sub { my %hsh=@_; i_conv($hsh{image},$hsh{coef}); }
222 };
223
f0ddaffd
TC		 224 $filters{gradgen} =
225 {
226 callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
227 defaults => { dist => 0 },
228 callsub =>
229 sub {
230 my %hsh=@_;
231 my @colors = @{$hsh{colors}};
232 $_ = _color($_)
233 for @colors;
234 i_gradgen($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors, $hsh{dist});
235 }
236 };
02d1d628
AMH		 237
238 $filters{nearest_color} ={
239 callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
240 defaults => { },
241 callsub => sub { my %hsh=@_; i_nearest_color($hsh{image}, $hsh{xo}, $hsh{yo}, $hsh{colors}, $hsh{dist}); }
242 };
faa9b3e7
TC		 243 $filters{gaussian} = {
244 callseq => [ 'image', 'stddev' ],
245 defaults => { },
246 callsub => sub { my %hsh = @_; i_gaussian($hsh{image}, $hsh{stddev}); },
247 };
d08b8f85
TC		 248 $filters{mosaic} =
249 {
250 callseq => [ qw(image size) ],
251 defaults => { size => 20 },
252 callsub => sub { my %hsh = @_; i_mosaic($hsh{image}, $hsh{size}) },
253 };
254 $filters{bumpmap} =
255 {
256 callseq => [ qw(image bump elevation lightx lighty st) ],
257 defaults => { elevation=>0, st=> 2 },
b2778574 258 callsub => sub {
d08b8f85
TC		 259 my %hsh = @_;
260 i_bumpmap($hsh{image}, $hsh{bump}{IMG}, $hsh{elevation},
261 $hsh{lightx}, $hsh{lighty}, $hsh{st});
262 },
263 };
b2778574
AMH		 264 $filters{bumpmap_complex} =
265 {
266 callseq => [ qw(image bump channel tx ty Lx Ly Lz cd cs n Ia Il Is) ],
267 defaults => {
268 channel => 0,
269 tx => 0,
270 ty => 0,
271 Lx => 0.2,
272 Ly => 0.4,
273 Lz => -1.0,
274 cd => 1.0,
275 cs => 40,
276 n => 1.3,
277 Ia => Imager::Color->new(rgb=>[0,0,0]),
278 Il => Imager::Color->new(rgb=>[255,255,255]),
279 Is => Imager::Color->new(rgb=>[255,255,255]),
280 },
281 callsub => sub {
282 my %hsh = @_;
283 i_bumpmap_complex($hsh{image}, $hsh{bump}{IMG}, $hsh{channel},
284 $hsh{tx}, $hsh{ty}, $hsh{Lx}, $hsh{Ly}, $hsh{Lz},
285 $hsh{cd}, $hsh{cs}, $hsh{n}, $hsh{Ia}, $hsh{Il},
286 $hsh{Is});
287 },
288 };
d08b8f85
TC		 289 $filters{postlevels} =
290 {
291 callseq => [ qw(image levels) ],
292 defaults => { levels => 10 },
293 callsub => sub { my %hsh = @_; i_postlevels($hsh{image}, $hsh{levels}); },
294 };
295 $filters{watermark} =
296 {
297 callseq => [ qw(image wmark tx ty pixdiff) ],
298 defaults => { pixdiff=>10, tx=>0, ty=>0 },
299 callsub =>
300 sub {
301 my %hsh = @_;
302 i_watermark($hsh{image}, $hsh{wmark}{IMG}, $hsh{tx}, $hsh{ty},
303 $hsh{pixdiff});
304 },
305 };
6607600c
TC		 306 $filters{fountain} =
307 {
308 callseq => [ qw(image xa ya xb yb ftype repeat combine super_sample ssample_param segments) ],
309 names => {
310 ftype => { linear => 0,
311 bilinear => 1,
312 radial => 2,
313 radial_square => 3,
314 revolution => 4,
315 conical => 5 },
316 repeat => { none => 0,
317 sawtooth => 1,
318 triangle => 2,
319 saw_both => 3,
320 tri_both => 4,
321 },
322 super_sample => {
323 none => 0,
324 grid => 1,
325 random => 2,
326 circle => 3,
327 },
efdc2568
TC		 328 combine => {
329 none => 0,
330 normal => 1,
331 multiply => 2, mult => 2,
332 dissolve => 3,
333 add => 4,
9d540150 334 subtract => 5, 'sub' => 5,
efdc2568
TC		 335 diff => 6,
336 lighten => 7,
337 darken => 8,
338 hue => 9,
339 sat => 10,
340 value => 11,
341 color => 12,
342 },
6607600c
TC		 343 },
344 defaults => { ftype => 0, repeat => 0, combine => 0,
345 super_sample => 0, ssample_param => 4,
346 segments=>[
347 [ 0, 0.5, 1,
348 Imager::Color->new(0,0,0),
349 Imager::Color->new(255, 255, 255),
350 0, 0,
351 ],
352 ],
353 },
354 callsub =>
355 sub {
356 my %hsh = @_;
357 i_fountain($hsh{image}, $hsh{xa}, $hsh{ya}, $hsh{xb}, $hsh{yb},
358 $hsh{ftype}, $hsh{repeat}, $hsh{combine}, $hsh{super_sample},
359 $hsh{ssample_param}, $hsh{segments});
360 },
361 };
b6381851
TC		 362 $filters{unsharpmask} =
363 {
364 callseq => [ qw(image stddev scale) ],
365 defaults => { stddev=>2.0, scale=>1.0 },
366 callsub =>
367 sub {
368 my %hsh = @_;
369 i_unsharp_mask($hsh{image}, $hsh{stddev}, $hsh{scale});
370 },
371 };
02d1d628
AMH		 372
373 $FORMATGUESS=\&def_guess_type;
97c4effc
TC		 374
375 $warn_obsolete = 1;
02d1d628
AMH		 376}
377
378#
379# Non methods
380#
381
382# initlize Imager
383# NOTE: this might be moved to an import override later on
384
385#sub import {
386# my $pack = shift;
387# (look through @_ for special tags, process, and remove them);
388# use Data::Dumper;
389# print Dumper($pack);
390# print Dumper(@_);
391#}
392
f83bf98a
AMH		 393sub init_log {
394 m_init_log($_[0],$_[1]);
395 log_entry("Imager $VERSION starting\n", 1);
396}
397
398
02d1d628
AMH		 399sub init {
400 my %parms=(loglevel=>1,@_);
401 if ($parms{'log'}) {
402 init_log($parms{'log'},$parms{'loglevel'});
403 }
f83bf98a 404
97c4effc
TC		 405 if (exists $parms{'warn_obsolete'}) {
406 $warn_obsolete = $parms{'warn_obsolete'};
407 }
02d1d628
AMH		 408
409# if ($parms{T1LIB_CONFIG}) { $ENV{T1LIB_CONFIG}=$parms{T1LIB_CONFIG}; }
410# if ( $ENV{T1LIB_CONFIG} and ( $fontstate eq 'missing conf' )) {
411# i_init_fonts();
412# $fontstate='ok';
413# }
4cb58f1b
TC		 414 if (exists $parms{'t1log'}) {
415 i_init_fonts($parms{'t1log'});
416 }
02d1d628
AMH		 417}
418
419END {
420 if ($DEBUG) {
421 print "shutdown code\n";
422 # for(keys %instances) { $instances{$_}->DESTROY(); }
423 malloc_state(); # how do decide if this should be used? -- store something from the import
424 print "Imager exiting\n";
425 }
426}
427
428# Load a filter plugin
429
430sub load_plugin {
431 my ($filename)=@_;
432 my $i;
433 my ($DSO_handle,$str)=DSO_open($filename);
434 if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
435 my %funcs=DSO_funclist($DSO_handle);
436 if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf(" %2d: %s\n",$i++,$_); } }
437 $i=0;
438 for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
439
440 $DSOs{$filename}=[$DSO_handle,\%funcs];
441
442 for(keys %funcs) {
443 my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
444 $DEBUG && print "eval string:\n",$evstr,"\n";
445 eval $evstr;
446 print $@ if $@;
447 }
448 return 1;
449}
450
451# Unload a plugin
452
453sub unload_plugin {
454 my ($filename)=@_;
455
456 if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
457 my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
458 for(keys %{$funcref}) {
459 delete $filters{$_};
460 $DEBUG && print "unloading: $_\n";
461 }
462 my $rc=DSO_close($DSO_handle);
463 if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
464 return 1;
465}
466
64606cc7
TC		 467# take the results of i_error() and make a message out of it
468sub _error_as_msg {
469 return join(": ", map $_->[0], i_errors());
470}
471
3a9a4241
TC		 472# this function tries to DWIM for color parameters
473# color objects are used as is
474# simple scalars are simply treated as single parameters to Imager::Color->new
475# hashrefs are treated as named argument lists to Imager::Color->new
476# arrayrefs are treated as list arguments to Imager::Color->new iff any
477# parameter is > 1
478# other arrayrefs are treated as list arguments to Imager::Color::Float
479
480sub _color {
481 my $arg = shift;
b6cfd214
TC		 482 # perl 5.6.0 seems to do weird things to $arg if we don't make an
483 # explicitly stringified copy
484 # I vaguely remember a bug on this on p5p, but couldn't find it
485 # through bugs.perl.org (I had trouble getting it to find any bugs)
486 my $copy = $arg . "";
3a9a4241
TC		 487 my $result;
488
489 if (ref $arg) {
490 if (UNIVERSAL::isa($arg, "Imager::Color")
491 || UNIVERSAL::isa($arg, "Imager::Color::Float")) {
492 $result = $arg;
493 }
494 else {
b6cfd214 495 if ($copy =~ /^HASH\(/) {
3a9a4241
TC		 496 $result = Imager::Color->new(%$arg);
497 }
b6cfd214 498 elsif ($copy =~ /^ARRAY\(/) {
3a9a4241
TC		 499 if (grep $_ > 1, @$arg) {
500 $result = Imager::Color->new(@$arg);
501 }
502 else {
503 $result = Imager::Color::Float->new(@$arg);
504 }
505 }
506 else {
507 $Imager::ERRSTR = "Not a color";
508 }
509 }
510 }
511 else {
512 # assume Imager::Color::new knows how to handle it
513 $result = Imager::Color->new($arg);
514 }
515
516 return $result;
517}
518
519
02d1d628
AMH		 520#
521# Methods to be called on objects.
522#
523
524# Create a new Imager object takes very few parameters.
525# usually you call this method and then call open from
526# the resulting object
527
528sub new {
529 my $class = shift;
530 my $self ={};
531 my %hsh=@_;
532 bless $self,$class;
533 $self->{IMG}=undef; # Just to indicate what exists
534 $self->{ERRSTR}=undef; #
535 $self->{DEBUG}=$DEBUG;
536 $self->{DEBUG} && print "Initialized Imager\n";
1501d9b3
TC		 537 if (defined $hsh{xsize} && defined $hsh{ysize}) {
538 unless ($self->img_set(%hsh)) {
539 $Imager::ERRSTR = $self->{ERRSTR};
540 return;
541 }
542 }
02d1d628
AMH		 543 return $self;
544}
545
02d1d628
AMH		 546# Copy an entire image with no changes
547# - if an image has magic the copy of it will not be magical
548
549sub copy {
550 my $self = shift;
551 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
552
553 my $newcopy=Imager->new();
554 $newcopy->{IMG}=i_img_new();
555 i_copy($newcopy->{IMG},$self->{IMG});
556 return $newcopy;
557}
558
559# Paste a region
560
561sub paste {
562 my $self = shift;
563 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
564 my %input=(left=>0, top=>0, @_);
565 unless($input{img}) {
566 $self->{ERRSTR}="no source image";
567 return;
568 }
569 $input{left}=0 if $input{left} <= 0;
570 $input{top}=0 if $input{top} <= 0;
571 my $src=$input{img};
572 my($r,$b)=i_img_info($src->{IMG});
573
574 i_copyto($self->{IMG}, $src->{IMG},
575 0,0, $r, $b, $input{left}, $input{top});
576 return $self; # What should go here??
577}
578
579# Crop an image - i.e. return a new image that is smaller
580
581sub crop {
582 my $self=shift;
583 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
02d1d628 584
676d5bb5
TC		 585
586 my %hsh=@_;
299a3866 587
676d5bb5
TC		 588 my ($w, $h, $l, $r, $b, $t) =
589 @hsh{qw(width height left right bottom top)};
299a3866 590
676d5bb5
TC		 591 # work through the various possibilities
592 if (defined $l) {
593 if (defined $w) {
594 $r = $l + $w;
595 }
596 elsif (!defined $r) {
597 $r = $self->getwidth;
598 }
599 }
600 elsif (defined $r) {
601 if (defined $w) {
602 $l = $r - $w;
603 }
604 else {
605 $l = 0;
606 }
607 }
608 elsif (defined $w) {
609 $l = int(0.5+($self->getwidth()-$w)/2);
610 $r = $l + $w;
611 }
612 else {
613 $l = 0;
614 $r = $self->getwidth;
615 }
616 if (defined $t) {
617 if (defined $h) {
618 $b = $t + $h;
619 }
620 elsif (!defined $b) {
621 $b = $self->getheight;
622 }
623 }
624 elsif (defined $b) {
625 if (defined $h) {
626 $t = $b - $h;
627 }
628 else {
629 $t = 0;
630 }
631 }
632 elsif (defined $h) {
633 $t=int(0.5+($self->getheight()-$h)/2);
634 $b=$t+$h;
635 }
636 else {
637 $t = 0;
638 $b = $self->getheight;
639 }
02d1d628
AMH		 640
641 ($l,$r)=($r,$l) if $l>$r;
642 ($t,$b)=($b,$t) if $t>$b;
643
676d5bb5
TC		 644 $l < 0 and $l = 0;
645 $r > $self->getwidth and $r = $self->getwidth;
646 $t < 0 and $t = 0;
647 $b > $self->getheight and $b = $self->getheight;
02d1d628 648
676d5bb5
TC		 649 if ($l == $r || $t == $b) {
650 $self->_set_error("resulting image would have no content");
651 return;
652 }
02d1d628 653
676d5bb5 654 my $dst = $self->_sametype(xsize=>$r-$l, ysize=>$b-$t);
02d1d628
AMH		 655
656 i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
657 return $dst;
658}
659
ec76939c
TC		 660sub _sametype {
661 my ($self, %opts) = @_;
662
663 $self->{IMG} or return $self->_set_error("Not a valid image");
664
665 my $x = $opts{xsize} || $self->getwidth;
666 my $y = $opts{ysize} || $self->getheight;
667 my $channels = $opts{channels} || $self->getchannels;
668
669 my $out = Imager->new;
670 if ($channels == $self->getchannels) {
671 $out->{IMG} = i_sametype($self->{IMG}, $x, $y);
672 }
673 else {
674 $out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
675 }
676 unless ($out->{IMG}) {
677 $self->{ERRSTR} = $self->_error_as_msg;
678 return;
679 }
680
681 return $out;
682}
683
02d1d628
AMH		 684# Sets an image to a certain size and channel number
685# if there was previously data in the image it is discarded
686
687sub img_set {
688 my $self=shift;
689
faa9b3e7 690 my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
02d1d628
AMH		 691
692 if (defined($self->{IMG})) {
faa9b3e7
TC		 693 # let IIM_DESTROY destroy it, it's possible this image is
694 # referenced from a virtual image (like masked)
695 #i_img_destroy($self->{IMG});
02d1d628
AMH		 696 undef($self->{IMG});
697 }
698
faa9b3e7
TC		 699 if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
700 $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
701 $hsh{maxcolors} || 256);
702 }
365ea842
TC		 703 elsif ($hsh{bits} eq 'double') {
704 $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
705 }
faa9b3e7
TC		 706 elsif ($hsh{bits} == 16) {
707 $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
708 }
709 else {
710 $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'},
711 $hsh{'channels'});
712 }
1501d9b3
TC		 713
714 unless ($self->{IMG}) {
715 $self->{ERRSTR} = Imager->_error_as_msg();
716 return;
717 }
718
719 $self;
faa9b3e7
TC		 720}
721
722# created a masked version of the current image
723sub masked {
724 my $self = shift;
725
726 $self or return undef;
727 my %opts = (left => 0,
728 top => 0,
729 right => $self->getwidth,
730 bottom => $self->getheight,
731 @_);
732 my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
733
734 my $result = Imager->new;
735 $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left},
736 $opts{top}, $opts{right} - $opts{left},
737 $opts{bottom} - $opts{top});
738 # keep references to the mask and base images so they don't
739 # disappear on us
740 $result->{DEPENDS} = [ $self->{IMG}, $mask ];
741
742 $result;
743}
744
745# convert an RGB image into a paletted image
746sub to_paletted {
747 my $self = shift;
748 my $opts;
749 if (@_ != 1 && !ref $_[0]) {
750 $opts = { @_ };
751 }
752 else {
753 $opts = shift;
754 }
755
756 my $result = Imager->new;
757 $result->{IMG} = i_img_to_pal($self->{IMG}, $opts);
758
759 #print "Type ", i_img_type($result->{IMG}), "\n";
760
1501d9b3
TC		 761 if ($result->{IMG}) {
762 return $result;
763 }
764 else {
765 $self->{ERRSTR} = $self->_error_as_msg;
766 return;
767 }
faa9b3e7
TC		 768}
769
770# convert a paletted (or any image) to an 8-bit/channel RGB images
771sub to_rgb8 {
772 my $self = shift;
773 my $result;
774
775 if ($self->{IMG}) {
776 $result = Imager->new;
777 $result->{IMG} = i_img_to_rgb($self->{IMG})
778 or undef $result;
779 }
780
781 return $result;
782}
783
784sub addcolors {
785 my $self = shift;
786 my %opts = (colors=>[], @_);
787
788 @{$opts{colors}} or return undef;
789
790 $self->{IMG} and i_addcolors($self->{IMG}, @{$opts{colors}});
791}
792
793sub setcolors {
794 my $self = shift;
795 my %opts = (start=>0, colors=>[], @_);
796 @{$opts{colors}} or return undef;
797
798 $self->{IMG} and i_setcolors($self->{IMG}, $opts{start}, @{$opts{colors}});
799}
800
801sub getcolors {
802 my $self = shift;
803 my %opts = @_;
804 if (!exists $opts{start} && !exists $opts{count}) {
805 # get them all
806 $opts{start} = 0;
807 $opts{count} = $self->colorcount;
808 }
809 elsif (!exists $opts{count}) {
810 $opts{count} = 1;
811 }
812 elsif (!exists $opts{start}) {
813 $opts{start} = 0;
814 }
815
816 $self->{IMG} and
817 return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
818}
819
820sub colorcount {
821 i_colorcount($_[0]{IMG});
822}
823
824sub maxcolors {
825 i_maxcolors($_[0]{IMG});
826}
827
828sub findcolor {
829 my $self = shift;
830 my %opts = @_;
831 $opts{color} or return undef;
832
833 $self->{IMG} and i_findcolor($self->{IMG}, $opts{color});
834}
835
836sub bits {
837 my $self = shift;
af3c2450
TC		 838 my $bits = $self->{IMG} && i_img_bits($self->{IMG});
839 if ($bits && $bits == length(pack("d", 1)) * 8) {
840 $bits = 'double';
841 }
842 $bits;
faa9b3e7
TC		 843}
844
845sub type {
846 my $self = shift;
847 if ($self->{IMG}) {
848 return i_img_type($self->{IMG}) ? "paletted" : "direct";
849 }
850}
851
852sub virtual {
853 my $self = shift;
854 $self->{IMG} and i_img_virtual($self->{IMG});
855}
856
857sub tags {
858 my ($self, %opts) = @_;
859
860 $self->{IMG} or return;
861
862 if (defined $opts{name}) {
863 my @result;
864 my $start = 0;
865 my $found;
866 while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
867 push @result, (i_tags_get($self->{IMG}, $found))[1];
868 $start = $found+1;
869 }
870 return wantarray ? @result : $result[0];
871 }
872 elsif (defined $opts{code}) {
873 my @result;
874 my $start = 0;
875 my $found;
876 while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
877 push @result, (i_tags_get($self->{IMG}, $found))[1];
878 $start = $found+1;
879 }
880 return @result;
881 }
882 else {
883 if (wantarray) {
884 return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
885 }
886 else {
887 return i_tags_count($self->{IMG});
888 }
889 }
890}
891
892sub addtag {
893 my $self = shift;
894 my %opts = @_;
895
896 return -1 unless $self->{IMG};
897 if ($opts{name}) {
898 if (defined $opts{value}) {
899 if ($opts{value} =~ /^\d+$/) {
900 # add as a number
901 return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
902 }
903 else {
904 return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
905 }
906 }
907 elsif (defined $opts{data}) {
908 # force addition as a string
909 return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
910 }
911 else {
912 $self->{ERRSTR} = "No value supplied";
913 return undef;
914 }
915 }
916 elsif ($opts{code}) {
917 if (defined $opts{value}) {
918 if ($opts{value} =~ /^\d+$/) {
919 # add as a number
920 return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
921 }
922 else {
923 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
924 }
925 }
926 elsif (defined $opts{data}) {
927 # force addition as a string
928 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
929 }
930 else {
931 $self->{ERRSTR} = "No value supplied";
932 return undef;
933 }
934 }
935 else {
936 return undef;
937 }
938}
939
940sub deltag {
941 my $self = shift;
942 my %opts = @_;
943
944 return 0 unless $self->{IMG};
945
9d540150
TC		 946 if (defined $opts{'index'}) {
947 return i_tags_delete($self->{IMG}, $opts{'index'});
faa9b3e7
TC		 948 }
949 elsif (defined $opts{name}) {
950 return i_tags_delbyname($self->{IMG}, $opts{name});
951 }
952 elsif (defined $opts{code}) {
953 return i_tags_delbycode($self->{IMG}, $opts{code});
954 }
955 else {
956 $self->{ERRSTR} = "Need to supply index, name, or code parameter";
957 return 0;
958 }
02d1d628
AMH		 959}
960
97c4effc
TC		 961sub settag {
962 my ($self, %opts) = @_;
963
964 if ($opts{name}) {
965 $self->deltag(name=>$opts{name});
966 return $self->addtag(name=>$opts{name}, value=>$opts{value});
967 }
968 elsif (defined $opts{code}) {
969 $self->deltag(code=>$opts{code});
970 return $self->addtag(code=>$opts{code}, value=>$opts{value});
971 }
972 else {
973 return undef;
974 }
975}
976
10461f9a
TC		 977
978sub _get_reader_io {
84e51293 979 my ($self, $input) = @_;
10461f9a 980
84e51293
AMH		 981 if ($input->{io}) {
982 return $input->{io}, undef;
983 }
984 elsif ($input->{fd}) {
10461f9a
TC		 985 return io_new_fd($input->{fd});
986 }
987 elsif ($input->{fh}) {
988 my $fd = fileno($input->{fh});
989 unless ($fd) {
990 $self->_set_error("Handle in fh option not opened");
991 return;
992 }
993 return io_new_fd($fd);
994 }
995 elsif ($input->{file}) {
996 my $file = IO::File->new($input->{file}, "r");
997 unless ($file) {
998 $self->_set_error("Could not open $input->{file}: $!");
999 return;
1000 }
1001 binmode $file;
1002 return (io_new_fd(fileno($file)), $file);
1003 }
1004 elsif ($input->{data}) {
1005 return io_new_buffer($input->{data});
1006 }
1007 elsif ($input->{callback} || $input->{readcb}) {
84e51293
AMH		 1008 if (!$input->{seekcb}) {
1009 $self->_set_error("Need a seekcb parameter");
10461f9a
TC		 1010 }
1011 if ($input->{maxbuffer}) {
1012 return io_new_cb($input->{writecb},
1013 $input->{callback} || $input->{readcb},
1014 $input->{seekcb}, $input->{closecb},
1015 $input->{maxbuffer});
1016 }
1017 else {
1018 return io_new_cb($input->{writecb},
1019 $input->{callback} || $input->{readcb},
1020 $input->{seekcb}, $input->{closecb});
1021 }
1022 }
1023 else {
1024 $self->_set_error("file/fd/fh/data/callback parameter missing");
1025 return;
1026 }
1027}
1028
1029sub _get_writer_io {
1030 my ($self, $input, $type) = @_;
1031
1032 if ($input->{fd}) {
1033 return io_new_fd($input->{fd});
1034 }
1035 elsif ($input->{fh}) {
1036 my $fd = fileno($input->{fh});
1037 unless ($fd) {
1038 $self->_set_error("Handle in fh option not opened");
1039 return;
1040 }
9d1c4956
TC		 1041 # flush it
1042 my $oldfh = select($input->{fh});
1043 # flush anything that's buffered, and make sure anything else is flushed
1044 $| = 1;
1045 select($oldfh);
10461f9a
TC		 1046 return io_new_fd($fd);
1047 }
1048 elsif ($input->{file}) {
1049 my $fh = new IO::File($input->{file},"w+");
1050 unless ($fh) {
1051 $self->_set_error("Could not open file $input->{file}: $!");
1052 return;
1053 }
1054 binmode($fh) or die;
1055 return (io_new_fd(fileno($fh)), $fh);
1056 }
1057 elsif ($input->{data}) {
1058 return io_new_bufchain();
1059 }
1060 elsif ($input->{callback} || $input->{writecb}) {
1061 if ($input->{maxbuffer}) {
1062 return io_new_cb($input->{callback} || $input->{writecb},
1063 $input->{readcb},
1064 $input->{seekcb}, $input->{closecb},
1065 $input->{maxbuffer});
1066 }
1067 else {
1068 return io_new_cb($input->{callback} || $input->{writecb},
1069 $input->{readcb},
1070 $input->{seekcb}, $input->{closecb});
1071 }
1072 }
1073 else {
1074 $self->_set_error("file/fd/fh/data/callback parameter missing");
1075 return;
1076 }
1077}
1078
02d1d628
AMH		 1079# Read an image from file
1080
1081sub read {
1082 my $self = shift;
1083 my %input=@_;
02d1d628
AMH		 1084
1085 if (defined($self->{IMG})) {
faa9b3e7
TC		 1086 # let IIM_DESTROY do the destruction, since the image may be
1087 # referenced from elsewhere
1088 #i_img_destroy($self->{IMG});
02d1d628
AMH		 1089 undef($self->{IMG});
1090 }
1091
84e51293
AMH		 1092 my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1093
10461f9a 1094 unless ($input{'type'}) {
66614d6e
TC		 1095 $input{'type'} = i_test_format_probe($IO, -1);
1096 }
84e51293
AMH		 1097
1098 unless ($input{'type'}) {
1099 $self->_set_error('type parameter missing and not possible to guess from extension');
10461f9a
TC		 1100 return undef;
1101 }
02d1d628 1102
66614d6e
TC		 1103 unless ($formats{$input{'type'}}) {
1104 $self->_set_error("format '$input{'type'}' not supported");
1105 return;
1106 }
1107
2fe0b227 1108 # Setup data source
2fe0b227 1109 if ( $input{'type'} eq 'jpeg' ) {
527c0c3e 1110 ($self->{IMG},$self->{IPTCRAW}) = i_readjpeg_wiol( $IO );
2fe0b227
AMH		 1111 if ( !defined($self->{IMG}) ) {
1112 $self->{ERRSTR}='unable to read jpeg image'; return undef;
02d1d628 1113 }
2fe0b227
AMH		 1114 $self->{DEBUG} && print "loading a jpeg file\n";
1115 return $self;
1116 }
02d1d628 1117
2fe0b227
AMH		 1118 if ( $input{'type'} eq 'tiff' ) {
1119 $self->{IMG}=i_readtiff_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1120 if ( !defined($self->{IMG}) ) {
1121 $self->{ERRSTR}=$self->_error_as_msg(); return undef;
02d1d628 1122 }
2fe0b227
AMH		 1123 $self->{DEBUG} && print "loading a tiff file\n";
1124 return $self;
1125 }
02d1d628 1126
2fe0b227
AMH		 1127 if ( $input{'type'} eq 'pnm' ) {
1128 $self->{IMG}=i_readpnm_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1129 if ( !defined($self->{IMG}) ) {
1130 $self->{ERRSTR}='unable to read pnm image: '._error_as_msg(); return undef;
790923a4 1131 }
2fe0b227
AMH		 1132 $self->{DEBUG} && print "loading a pnm file\n";
1133 return $self;
1134 }
790923a4 1135
2fe0b227
AMH		 1136 if ( $input{'type'} eq 'png' ) {
1137 $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1138 if ( !defined($self->{IMG}) ) {
1139 $self->{ERRSTR}='unable to read png image';
1140 return undef;
705fd961 1141 }
2fe0b227
AMH		 1142 $self->{DEBUG} && print "loading a png file\n";
1143 }
705fd961 1144
2fe0b227
AMH		 1145 if ( $input{'type'} eq 'bmp' ) {
1146 $self->{IMG}=i_readbmp_wiol( $IO );
1147 if ( !defined($self->{IMG}) ) {
1148 $self->{ERRSTR}=$self->_error_as_msg();
1149 return undef;
10461f9a 1150 }
2fe0b227
AMH		 1151 $self->{DEBUG} && print "loading a bmp file\n";
1152 }
10461f9a 1153
2fe0b227
AMH		 1154 if ( $input{'type'} eq 'gif' ) {
1155 if ($input{colors} && !ref($input{colors})) {
1156 # must be a reference to a scalar that accepts the colour map
1157 $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1158 return undef;
1ec86afa 1159 }
2fe0b227
AMH		 1160 if ($input{colors}) {
1161 my $colors;
1162 ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1163 if ($colors) {
1164 ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
737a830c 1165 }
737a830c 1166 }
2fe0b227
AMH		 1167 else {
1168 $self->{IMG} =i_readgif_wiol( $IO );
895dbd34 1169 }
2fe0b227
AMH		 1170 if ( !defined($self->{IMG}) ) {
1171 $self->{ERRSTR}=$self->_error_as_msg();
1172 return undef;
895dbd34 1173 }
2fe0b227
AMH		 1174 $self->{DEBUG} && print "loading a gif file\n";
1175 }
895dbd34 1176
2fe0b227
AMH		 1177 if ( $input{'type'} eq 'tga' ) {
1178 $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1179 if ( !defined($self->{IMG}) ) {
1180 $self->{ERRSTR}=$self->_error_as_msg();
1181 return undef;
895dbd34 1182 }
2fe0b227
AMH		 1183 $self->{DEBUG} && print "loading a tga file\n";
1184 }
02d1d628 1185
2fe0b227
AMH		 1186 if ( $input{'type'} eq 'rgb' ) {
1187 $self->{IMG}=i_readrgb_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1188 if ( !defined($self->{IMG}) ) {
1189 $self->{ERRSTR}=$self->_error_as_msg();
a59ffd27
TC		 1190 return undef;
1191 }
2fe0b227
AMH		 1192 $self->{DEBUG} && print "loading a tga file\n";
1193 }
895dbd34 1194
895dbd34 1195
2fe0b227
AMH		 1196 if ( $input{'type'} eq 'raw' ) {
1197 my %params=(datachannels=>3,storechannels=>3,interleave=>1,%input);
1198
1199 if ( !($params{xsize} && $params{ysize}) ) {
1200 $self->{ERRSTR}='missing xsize or ysize parameter for raw';
1201 return undef;
895dbd34
AMH		 1202 }
1203
2fe0b227
AMH		 1204 $self->{IMG} = i_readraw_wiol( $IO,
1205 $params{xsize},
1206 $params{ysize},
1207 $params{datachannels},
1208 $params{storechannels},
1209 $params{interleave});
1210 if ( !defined($self->{IMG}) ) {
1211 $self->{ERRSTR}='unable to read raw image';
1212 return undef;
dd55acc8 1213 }
2fe0b227 1214 $self->{DEBUG} && print "loading a raw file\n";
02d1d628 1215 }
2fe0b227 1216
02d1d628 1217 return $self;
02d1d628
AMH		 1218}
1219
97c4effc
TC		 1220sub _fix_gif_positions {
1221 my ($opts, $opt, $msg, @imgs) = @_;
2fe0b227 1222
97c4effc
TC		 1223 my $positions = $opts->{'gif_positions'};
1224 my $index = 0;
1225 for my $pos (@$positions) {
1226 my ($x, $y) = @$pos;
1227 my $img = $imgs[$index++];
9d1c4956
TC		 1228 $img->settag(name=>'gif_left', value=>$x);
1229 $img->settag(name=>'gif_top', value=>$y) if defined $y;
97c4effc
TC		 1230 }
1231 $$msg .= "replaced with the gif_left and gif_top tags";
1232}
1233
1234my %obsolete_opts =
1235 (
1236 gif_each_palette=>'gif_local_map',
1237 interlace => 'gif_interlace',
1238 gif_delays => 'gif_delay',
1239 gif_positions => \&_fix_gif_positions,
1240 gif_loop_count => 'gif_loop',
1241 );
1242
1243sub _set_opts {
1244 my ($self, $opts, $prefix, @imgs) = @_;
1245
1246 for my $opt (keys %$opts) {
1247 my $tagname = $opt;
1248 if ($obsolete_opts{$opt}) {
1249 my $new = $obsolete_opts{$opt};
1250 my $msg = "Obsolete option $opt ";
1251 if (ref $new) {
1252 $new->($opts, $opt, \$msg, @imgs);
1253 }
1254 else {
1255 $msg .= "replaced with the $new tag ";
1256 $tagname = $new;
1257 }
1258 $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1259 warn $msg if $warn_obsolete && $^W;
1260 }
1261 next unless $tagname =~ /^\Q$prefix/;
1262 my $value = $opts->{$opt};
1263 if (ref $value) {
1264 if (UNIVERSAL::isa($value, "Imager::Color")) {
1265 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1266 for my $img (@imgs) {
1267 $img->settag(name=>$tagname, value=>$tag);
1268 }
1269 }
1270 elsif (ref($value) eq 'ARRAY') {
1271 for my $i (0..$#$value) {
1272 my $val = $value->[$i];
1273 if (ref $val) {
1274 if (UNIVERSAL::isa($val, "Imager::Color")) {
1275 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1276 $i < @imgs and
1277 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1278 }
1279 else {
1280 $self->_set_error("Unknown reference type " . ref($value) .
1281 " supplied in array for $opt");
1282 return;
1283 }
1284 }
1285 else {
1286 $i < @imgs
1287 and $imgs[$i]->settag(name=>$tagname, value=>$val);
1288 }
1289 }
1290 }
1291 else {
1292 $self->_set_error("Unknown reference type " . ref($value) .
1293 " supplied for $opt");
1294 return;
1295 }
1296 }
1297 else {
1298 # set it as a tag for every image
1299 for my $img (@imgs) {
1300 $img->settag(name=>$tagname, value=>$value);
1301 }
1302 }
1303 }
1304
1305 return 1;
1306}
1307
02d1d628 1308# Write an image to file
02d1d628
AMH		 1309sub write {
1310 my $self = shift;
2fe0b227
AMH		 1311 my %input=(jpegquality=>75,
1312 gifquant=>'mc',
1313 lmdither=>6.0,
febba01f
AMH		 1314 lmfixed=>[],
1315 idstring=>"",
1316 compress=>1,
1317 wierdpack=>0,
4c2d6970 1318 fax_fine=>1, @_);
10461f9a 1319 my $rc;
02d1d628 1320
97c4effc
TC		 1321 $self->_set_opts(\%input, "i_", $self)
1322 or return undef;
1323
02d1d628
AMH		 1324 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1325
9d540150
TC		 1326 if (!$input{'type'} and $input{file}) {
1327 $input{'type'}=$FORMATGUESS->($input{file});
1328 }
1329 if (!$input{'type'}) {
1330 $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1331 return undef;
1332 }
02d1d628 1333
9d540150 1334 if (!$formats{$input{'type'}}) { $self->{ERRSTR}='format not supported'; return undef; }
02d1d628 1335
10461f9a
TC		 1336 my ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
1337 or return undef;
02d1d628 1338
2fe0b227
AMH		 1339 if ($input{'type'} eq 'tiff') {
1340 $self->_set_opts(\%input, "tiff_", $self)
1341 or return undef;
1342 $self->_set_opts(\%input, "exif_", $self)
1343 or return undef;
febba01f 1344
2fe0b227
AMH		 1345 if (defined $input{class} && $input{class} eq 'fax') {
1346 if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1347 $self->{ERRSTR}='Could not write to buffer';
1ec86afa
AMH		 1348 return undef;
1349 }
2fe0b227
AMH		 1350 } else {
1351 if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1352 $self->{ERRSTR}='Could not write to buffer';
1353 return undef;
10461f9a 1354 }
02d1d628 1355 }
2fe0b227
AMH		 1356 } elsif ( $input{'type'} eq 'pnm' ) {
1357 $self->_set_opts(\%input, "pnm_", $self)
1358 or return undef;
1359 if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1360 $self->{ERRSTR}='unable to write pnm image';
1361 return undef;
1362 }
1363 $self->{DEBUG} && print "writing a pnm file\n";
1364 } elsif ( $input{'type'} eq 'raw' ) {
1365 $self->_set_opts(\%input, "raw_", $self)
1366 or return undef;
1367 if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1368 $self->{ERRSTR}='unable to write raw image';
1369 return undef;
1370 }
1371 $self->{DEBUG} && print "writing a raw file\n";
1372 } elsif ( $input{'type'} eq 'png' ) {
1373 $self->_set_opts(\%input, "png_", $self)
1374 or return undef;
1375 if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1376 $self->{ERRSTR}='unable to write png image';
1377 return undef;
1378 }
1379 $self->{DEBUG} && print "writing a png file\n";
1380 } elsif ( $input{'type'} eq 'jpeg' ) {
1381 $self->_set_opts(\%input, "jpeg_", $self)
1382 or return undef;
1383 $self->_set_opts(\%input, "exif_", $self)
1384 or return undef;
1385 if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1386 $self->{ERRSTR} = $self->_error_as_msg();
1387 return undef;
1388 }
1389 $self->{DEBUG} && print "writing a jpeg file\n";
1390 } elsif ( $input{'type'} eq 'bmp' ) {
1391 $self->_set_opts(\%input, "bmp_", $self)
1392 or return undef;
1393 if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
1394 $self->{ERRSTR}='unable to write bmp image';
1395 return undef;
1396 }
1397 $self->{DEBUG} && print "writing a bmp file\n";
1398 } elsif ( $input{'type'} eq 'tga' ) {
1399 $self->_set_opts(\%input, "tga_", $self)
1400 or return undef;
02d1d628 1401
2fe0b227
AMH		 1402 if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1403 $self->{ERRSTR}=$self->_error_as_msg();
1404 return undef;
930c67c8 1405 }
2fe0b227
AMH		 1406 $self->{DEBUG} && print "writing a tga file\n";
1407 } elsif ( $input{'type'} eq 'gif' ) {
1408 $self->_set_opts(\%input, "gif_", $self)
1409 or return undef;
1410 # compatibility with the old interfaces
1411 if ($input{gifquant} eq 'lm') {
1412 $input{make_colors} = 'addi';
1413 $input{translate} = 'perturb';
1414 $input{perturb} = $input{lmdither};
1415 } elsif ($input{gifquant} eq 'gen') {
1416 # just pass options through
1417 } else {
1418 $input{make_colors} = 'webmap'; # ignored
1419 $input{translate} = 'giflib';
1420 }
1501d9b3
TC		 1421 if (!i_writegif_wiol($IO, \%input, $self->{IMG})) {
1422 $self->{ERRSTR} = $self->_error_as_msg;
1423 return;
1424 }
02d1d628 1425 }
10461f9a 1426
2fe0b227
AMH		 1427 if (exists $input{'data'}) {
1428 my $data = io_slurp($IO);
1429 if (!$data) {
1430 $self->{ERRSTR}='Could not slurp from buffer';
1431 return undef;
1432 }
1433 ${$input{data}} = $data;
1434 }
02d1d628
AMH		 1435 return $self;
1436}
1437
1438sub write_multi {
1439 my ($class, $opts, @images) = @_;
1440
10461f9a
TC		 1441 if (!$opts->{'type'} && $opts->{'file'}) {
1442 $opts->{'type'} = $FORMATGUESS->($opts->{'file'});
1443 }
1444 unless ($opts->{'type'}) {
1445 $class->_set_error('type parameter missing and not possible to guess from extension');
1446 return;
1447 }
1448 # translate to ImgRaw
1449 if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1450 $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1451 return 0;
1452 }
97c4effc
TC		 1453 $class->_set_opts($opts, "i_", @images)
1454 or return;
10461f9a
TC		 1455 my @work = map $_->{IMG}, @images;
1456 my ($IO, $file) = $class->_get_writer_io($opts, $opts->{'type'})
1457 or return undef;
9d540150 1458 if ($opts->{'type'} eq 'gif') {
97c4effc
TC		 1459 $class->_set_opts($opts, "gif_", @images)
1460 or return;
ed88b092
TC		 1461 my $gif_delays = $opts->{gif_delays};
1462 local $opts->{gif_delays} = $gif_delays;
10461f9a 1463 if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
ed88b092
TC		 1464 # assume the caller wants the same delay for each frame
1465 $opts->{gif_delays} = [ ($gif_delays) x @images ];
1466 }
10461f9a
TC		 1467 my $res = i_writegif_wiol($IO, $opts, @work);
1468 $res or $class->_set_error($class->_error_as_msg());
1469 return $res;
1470 }
1471 elsif ($opts->{'type'} eq 'tiff') {
97c4effc
TC		 1472 $class->_set_opts($opts, "tiff_", @images)
1473 or return;
1474 $class->_set_opts($opts, "exif_", @images)
1475 or return;
10461f9a
TC		 1476 my $res;
1477 $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1478 if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1479 $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
02d1d628
AMH		 1480 }
1481 else {
10461f9a 1482 $res = i_writetiff_multi_wiol($IO, @work);
02d1d628 1483 }
10461f9a
TC		 1484 $res or $class->_set_error($class->_error_as_msg());
1485 return $res;
02d1d628
AMH		 1486 }
1487 else {
9d540150 1488 $ERRSTR = "Sorry, write_multi doesn't support $opts->{'type'} yet";
02d1d628
AMH		 1489 return 0;
1490 }
1491}
1492
faa9b3e7
TC		 1493# read multiple images from a file
1494sub read_multi {
1495 my ($class, %opts) = @_;
1496
9d540150 1497 if ($opts{file} && !exists $opts{'type'}) {
faa9b3e7
TC		 1498 # guess the type
1499 my $type = $FORMATGUESS->($opts{file});
9d540150 1500 $opts{'type'} = $type;
faa9b3e7 1501 }
9d540150 1502 unless ($opts{'type'}) {
faa9b3e7
TC		 1503 $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1504 return;
1505 }
faa9b3e7 1506
10461f9a
TC		 1507 my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1508 or return;
9d540150 1509 if ($opts{'type'} eq 'gif') {
faa9b3e7 1510 my @imgs;
10461f9a
TC		 1511 @imgs = i_readgif_multi_wiol($IO);
1512 if (@imgs) {
1513 return map {
1514 bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1515 } @imgs;
faa9b3e7
TC		 1516 }
1517 else {
10461f9a
TC		 1518 $ERRSTR = _error_as_msg();
1519 return;
faa9b3e7 1520 }
10461f9a
TC		 1521 }
1522 elsif ($opts{'type'} eq 'tiff') {
1523 my @imgs = i_readtiff_multi_wiol($IO, -1);
faa9b3e7
TC		 1524 if (@imgs) {
1525 return map {
1526 bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1527 } @imgs;
1528 }
1529 else {
1530 $ERRSTR = _error_as_msg();
1531 return;
1532 }
1533 }
1534
9d540150 1535 $ERRSTR = "Cannot read multiple images from $opts{'type'} files";
faa9b3e7
TC		 1536 return;
1537}
1538
02d1d628
AMH		 1539# Destroy an Imager object
1540
1541sub DESTROY {
1542 my $self=shift;
1543 # delete $instances{$self};
1544 if (defined($self->{IMG})) {
faa9b3e7
TC		 1545 # the following is now handled by the XS DESTROY method for
1546 # Imager::ImgRaw object
1547 # Re-enabling this will break virtual images
1548 # tested for in t/t020masked.t
1549 # i_img_destroy($self->{IMG});
02d1d628
AMH		 1550 undef($self->{IMG});
1551 } else {
1552# print "Destroy Called on an empty image!\n"; # why did I put this here??
1553 }
1554}
1555
1556# Perform an inplace filter of an image
1557# that is the image will be overwritten with the data
1558
1559sub filter {
1560 my $self=shift;
1561 my %input=@_;
1562 my %hsh;
1563 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1564
9d540150 1565 if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
02d1d628 1566
9d540150 1567 if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
02d1d628
AMH		 1568 $self->{ERRSTR}='type parameter not matching any filter'; return undef;
1569 }
1570
9d540150
TC		 1571 if ($filters{$input{'type'}}{names}) {
1572 my $names = $filters{$input{'type'}}{names};
6607600c
TC		 1573 for my $name (keys %$names) {
1574 if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
1575 $input{$name} = $names->{$name}{$input{$name}};
1576 }
1577 }
1578 }
9d540150
TC		 1579 if (defined($filters{$input{'type'}}{defaults})) {
1580 %hsh=('image',$self->{IMG},%{$filters{$input{'type'}}{defaults}},%input);
02d1d628
AMH		 1581 } else {
1582 %hsh=('image',$self->{IMG},%input);
1583 }
1584
9d540150 1585 my @cs=@{$filters{$input{'type'}}{callseq}};
02d1d628
AMH		 1586
1587 for(@cs) {
1588 if (!defined($hsh{$_})) {
9d540150 1589 $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
02d1d628
AMH		 1590 }
1591 }
1592
9d540150 1593 &{$filters{$input{'type'}}{callsub}}(%hsh);
02d1d628
AMH		 1594
1595 my @b=keys %hsh;
1596
1597 $self->{DEBUG} && print "callseq is: @cs\n";
1598 $self->{DEBUG} && print "matching callseq is: @b\n";
1599
1600 return $self;
1601}
1602
1603# Scale an image to requested size and return the scaled version
1604
1605sub scale {
1606 my $self=shift;
9d540150 1607 my %opts=(scalefactor=>0.5,'type'=>'max',qtype=>'normal',@_);
02d1d628
AMH		 1608 my $img = Imager->new();
1609 my $tmp = Imager->new();
1610
ace46df2 1611 unless (defined wantarray) {
1501d9b3
TC		 1612 my @caller = caller;
1613 warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
ace46df2
TC		 1614 return;
1615 }
1616
02d1d628
AMH		 1617 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1618
9d540150 1619 if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
02d1d628 1620 my ($xpix,$ypix)=( $opts{xpixels}/$self->getwidth() , $opts{ypixels}/$self->getheight() );
9d540150
TC		 1621 if ($opts{'type'} eq 'min') { $opts{scalefactor}=min($xpix,$ypix); }
1622 if ($opts{'type'} eq 'max') { $opts{scalefactor}=max($xpix,$ypix); }
02d1d628
AMH		 1623 } elsif ($opts{xpixels}) { $opts{scalefactor}=$opts{xpixels}/$self->getwidth(); }
1624 elsif ($opts{ypixels}) { $opts{scalefactor}=$opts{ypixels}/$self->getheight(); }
1625
1626 if ($opts{qtype} eq 'normal') {
1627 $tmp->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1628 if ( !defined($tmp->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1629 $img->{IMG}=i_scaleaxis($tmp->{IMG},$opts{scalefactor},1);
1630 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1631 return $img;
1632 }
1633 if ($opts{'qtype'} eq 'preview') {
1634 $img->{IMG}=i_scale_nn($self->{IMG},$opts{'scalefactor'},$opts{'scalefactor'});
1635 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1636 return $img;
1637 }
1638 $self->{ERRSTR}='scale: invalid value for qtype'; return undef;
1639}
1640
1641# Scales only along the X axis
1642
1643sub scaleX {
1644 my $self=shift;
1645 my %opts=(scalefactor=>0.5,@_);
1646
1647 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1648
1649 my $img = Imager->new();
1650
1651 if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getwidth(); }
1652
1653 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1654 $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},0);
1655
1656 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1657 return $img;
1658}
1659
1660# Scales only along the Y axis
1661
1662sub scaleY {
1663 my $self=shift;
1664 my %opts=(scalefactor=>0.5,@_);
1665
1666 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1667
1668 my $img = Imager->new();
1669
1670 if ($opts{pixels}) { $opts{scalefactor}=$opts{pixels}/$self->getheight(); }
1671
1672 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1673 $img->{IMG}=i_scaleaxis($self->{IMG},$opts{scalefactor},1);
1674
1675 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='unable to scale image'; return undef; }
1676 return $img;
1677}
1678
1679
1680# Transform returns a spatial transformation of the input image
1681# this moves pixels to a new location in the returned image.
1682# NOTE - should make a utility function to check transforms for
1683# stack overruns
1684
1685sub transform {
1686 my $self=shift;
1687 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1688 my %opts=@_;
1689 my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
1690
1691# print Dumper(\%opts);
1692# xopcopdes
1693
1694 if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
1695 if (!$I2P) {
1696 eval ("use Affix::Infix2Postfix;");
1697 print $@;
1698 if ( $@ ) {
1699 $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
1700 return undef;
1701 }
1702 $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
1703 {op=>'-',trans=>'Sub'},
1704 {op=>'*',trans=>'Mult'},
1705 {op=>'/',trans=>'Div'},
9d540150 1706 {op=>'-','type'=>'unary',trans=>'u-'},
02d1d628 1707 {op=>'**'},
9d540150 1708 {op=>'func','type'=>'unary'}],
02d1d628
AMH		 1709 'grouping'=>[qw( \( \) )],
1710 'func'=>[qw( sin cos )],
1711 'vars'=>[qw( x y )]
1712 );
1713 }
1714
1715 @xt=$I2P->translate($opts{'xexpr'});
1716 @yt=$I2P->translate($opts{'yexpr'});
1717
1718 $numre=$I2P->{'numre'};
1719 @pt=(0,0);
1720
1721 for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
1722 for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
1723 @{$opts{'parm'}}=@pt;
1724 }
1725
1726# print Dumper(\%opts);
1727
1728 if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
1729 $self->{ERRSTR}='transform: no xopcodes given.';
1730 return undef;
1731 }
1732
1733 @op=@{$opts{'xopcodes'}};
1734 for $iop (@op) {
1735 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1736 $self->{ERRSTR}="transform: illegal opcode '$_'.";
1737 return undef;
1738 }
1739 push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1740 }
1741
1742
1743# yopcopdes
1744
1745 if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
1746 $self->{ERRSTR}='transform: no yopcodes given.';
1747 return undef;
1748 }
1749
1750 @op=@{$opts{'yopcodes'}};
1751 for $iop (@op) {
1752 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
1753 $self->{ERRSTR}="transform: illegal opcode '$_'.";
1754 return undef;
1755 }
1756 push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
1757 }
1758
1759#parameters
1760
1761 if ( !exists $opts{'parm'}) {
1762 $self->{ERRSTR}='transform: no parameter arg given.';
1763 return undef;
1764 }
1765
1766# print Dumper(\@ropx);
1767# print Dumper(\@ropy);
1768# print Dumper(\@ropy);
1769
1770 my $img = Imager->new();
1771 $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
1772 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
1773 return $img;
1774}
1775
1776
bf94b653
TC		 1777sub transform2 {
1778 my ($opts, @imgs) = @_;
1779
1780 require "Imager/Expr.pm";
1781
1782 $opts->{variables} = [ qw(x y) ];
1783 my ($width, $height) = @{$opts}{qw(width height)};
1784 if (@imgs) {
1785 $width ||= $imgs[0]->getwidth();
1786 $height ||= $imgs[0]->getheight();
1787 my $img_num = 1;
1788 for my $img (@imgs) {
1789 $opts->{constants}{"w$img_num"} = $img->getwidth();
1790 $opts->{constants}{"h$img_num"} = $img->getheight();
1791 $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
1792 $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
1793 ++$img_num;
02d1d628 1794 }
02d1d628 1795 }
bf94b653
TC		 1796 if ($width) {
1797 $opts->{constants}{w} = $width;
1798 $opts->{constants}{cx} = $width/2;
1799 }
1800 else {
1801 $Imager::ERRSTR = "No width supplied";
1802 return;
1803 }
1804 if ($height) {
1805 $opts->{constants}{h} = $height;
1806 $opts->{constants}{cy} = $height/2;
1807 }
1808 else {
1809 $Imager::ERRSTR = "No height supplied";
1810 return;
1811 }
1812 my $code = Imager::Expr->new($opts);
1813 if (!$code) {
1814 $Imager::ERRSTR = Imager::Expr::error();
1815 return;
1816 }
e5744e01
TC		 1817 my $channels = $opts->{channels} || 3;
1818 unless ($channels >= 1 && $channels <= 4) {
1819 return Imager->_set_error("channels must be an integer between 1 and 4");
1820 }
9982a307 1821
bf94b653 1822 my $img = Imager->new();
e5744e01
TC		 1823 $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
1824 $channels, $code->code(),
bf94b653
TC		 1825 $code->nregs(), $code->cregs(),
1826 [ map { $_->{IMG} } @imgs ]);
1827 if (!defined $img->{IMG}) {
1828 $Imager::ERRSTR = Imager->_error_as_msg();
1829 return;
1830 }
9982a307 1831
bf94b653 1832 return $img;
02d1d628
AMH		 1833}
1834
02d1d628
AMH		 1835sub rubthrough {
1836 my $self=shift;
71dc4a83 1837 my %opts=(tx => 0,ty => 0, @_);
02d1d628
AMH		 1838
1839 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1840 unless ($opts{src} && $opts{src}->{IMG}) { $self->{ERRSTR}='empty input image for source'; return undef; }
1841
71dc4a83
AMH		 1842 %opts = (src_minx => 0,
1843 src_miny => 0,
1844 src_maxx => $opts{src}->getwidth(),
1845 src_maxy => $opts{src}->getheight(),
1846 %opts);
1847
1848 unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $opts{tx}, $opts{ty},
1849 $opts{src_minx}, $opts{src_miny}, $opts{src_maxx}, $opts{src_maxy})) {
faa9b3e7
TC		 1850 $self->{ERRSTR} = $self->_error_as_msg();
1851 return undef;
1852 }
02d1d628
AMH		 1853 return $self;
1854}
1855
1856
142c26ff
AMH		 1857sub flip {
1858 my $self = shift;
1859 my %opts = @_;
9191e525 1860 my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
142c26ff
AMH		 1861 my $dir;
1862 return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
1863 $dir = $xlate{$opts{'dir'}};
1864 return $self if i_flipxy($self->{IMG}, $dir);
1865 return ();
1866}
1867
faa9b3e7
TC		 1868sub rotate {
1869 my $self = shift;
1870 my %opts = @_;
1871 if (defined $opts{right}) {
1872 my $degrees = $opts{right};
1873 if ($degrees < 0) {
1874 $degrees += 360 * int(((-$degrees)+360)/360);
1875 }
1876 $degrees = $degrees % 360;
1877 if ($degrees == 0) {
1878 return $self->copy();
1879 }
1880 elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
1881 my $result = Imager->new();
1882 if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
1883 return $result;
1884 }
1885 else {
1886 $self->{ERRSTR} = $self->_error_as_msg();
1887 return undef;
1888 }
1889 }
1890 else {
1891 $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
1892 return undef;
1893 }
1894 }
1895 elsif (defined $opts{radians} || defined $opts{degrees}) {
1896 my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
1897
1898 my $result = Imager->new;
0d3b936e
TC		 1899 if ($opts{back}) {
1900 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $opts{back});
1901 }
1902 else {
1903 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
1904 }
1905 if ($result->{IMG}) {
faa9b3e7
TC		 1906 return $result;
1907 }
1908 else {
1909 $self->{ERRSTR} = $self->_error_as_msg();
1910 return undef;
1911 }
1912 }
1913 else {
0d3b936e 1914 $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
faa9b3e7
TC		 1915 return undef;
1916 }
1917}
1918
1919sub matrix_transform {
1920 my $self = shift;
1921 my %opts = @_;
1922
1923 if ($opts{matrix}) {
1924 my $xsize = $opts{xsize} || $self->getwidth;
1925 my $ysize = $opts{ysize} || $self->getheight;
142c26ff 1926
faa9b3e7 1927 my $result = Imager->new;
0d3b936e
TC		 1928 if ($opts{back}) {
1929 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
1930 $opts{matrix}, $opts{back})
1931 or return undef;
1932 }
1933 else {
1934 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
1935 $opts{matrix})
1936 or return undef;
1937 }
faa9b3e7
TC		 1938
1939 return $result;
1940 }
1941 else {
1942 $self->{ERRSTR} = "matrix parameter required";
1943 return undef;
1944 }
1945}
1946
1947# blame Leolo :)
1948*yatf = \&matrix_transform;
02d1d628
AMH		 1949
1950# These two are supported for legacy code only
1951
1952sub i_color_new {
faa9b3e7 1953 return Imager::Color->new(@_);
02d1d628
AMH		 1954}
1955
1956sub i_color_set {
faa9b3e7 1957 return Imager::Color::set(@_);
02d1d628
AMH		 1958}
1959
02d1d628 1960# Draws a box between the specified corner points.
02d1d628
AMH		 1961sub box {
1962 my $self=shift;
1963 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1964 my $dflcl=i_color_new(255,255,255,255);
1965 my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
1966
1967 if (exists $opts{'box'}) {
1968 $opts{'xmin'} = min($opts{'box'}->[0],$opts{'box'}->[2]);
1969 $opts{'xmax'} = max($opts{'box'}->[0],$opts{'box'}->[2]);
1970 $opts{'ymin'} = min($opts{'box'}->[1],$opts{'box'}->[3]);
1971 $opts{'ymax'} = max($opts{'box'}->[1],$opts{'box'}->[3]);
1972 }
1973
f1ac5027 1974 if ($opts{filled}) {
3a9a4241
TC		 1975 my $color = _color($opts{'color'});
1976 unless ($color) {
1977 $self->{ERRSTR} = $Imager::ERRSTR;
1978 return;
1979 }
f1ac5027 1980 i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
3a9a4241 1981 $opts{ymax}, $color);
f1ac5027
TC		 1982 }
1983 elsif ($opts{fill}) {
1984 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
1985 # assume it's a hash ref
1986 require 'Imager/Fill.pm';
141a6114
TC		 1987 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
1988 $self->{ERRSTR} = $Imager::ERRSTR;
1989 return undef;
1990 }
f1ac5027
TC		 1991 }
1992 i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
1993 $opts{ymax},$opts{fill}{fill});
1994 }
cdd23610 1995 else {
3a9a4241
TC		 1996 my $color = _color($opts{'color'});
1997 unless ($color) {
cdd23610
AMH		 1998 $self->{ERRSTR} = $Imager::ERRSTR;
1999 return;
3a9a4241
TC		 2000 }
2001 i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
2002 $color);
f1ac5027 2003 }
02d1d628
AMH		 2004 return $self;
2005}
2006
2007# Draws an arc - this routine SUCKS and is buggy - it sometimes doesn't work when the arc is a convex polygon
2008
2009sub arc {
2010 my $self=shift;
2011 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2012 my $dflcl=i_color_new(255,255,255,255);
2013 my %opts=(color=>$dflcl,
2014 'r'=>min($self->getwidth(),$self->getheight())/3,
2015 'x'=>$self->getwidth()/2,
2016 'y'=>$self->getheight()/2,
2017 'd1'=>0, 'd2'=>361, @_);
f1ac5027
TC		 2018 if ($opts{fill}) {
2019 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2020 # assume it's a hash ref
2021 require 'Imager/Fill.pm';
569795e8
TC		 2022 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2023 $self->{ERRSTR} = $Imager::ERRSTR;
2024 return;
2025 }
f1ac5027
TC		 2026 }
2027 i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2028 $opts{'d2'}, $opts{fill}{fill});
2029 }
2030 else {
3a9a4241
TC		 2031 my $color = _color($opts{'color'});
2032 unless ($color) {
2033 $self->{ERRSTR} = $Imager::ERRSTR;
2034 return;
2035 }
0d321238
TC		 2036 if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2037 i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
3a9a4241 2038 $color);
0d321238
TC		 2039 }
2040 else {
3a9a4241
TC		 2041 if ($opts{'d1'} <= $opts{'d2'}) {
2042 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2043 $opts{'d1'}, $opts{'d2'}, $color);
2044 }
2045 else {
2046 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2047 $opts{'d1'}, 361, $color);
2048 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2049 0, $opts{'d2'}, $color);
2050 }
0d321238 2051 }
f1ac5027
TC		 2052 }
2053
02d1d628
AMH		 2054 return $self;
2055}
2056
aa833c97
AMH		 2057# Draws a line from one point to the other
2058# the endpoint is set if the endp parameter is set which it is by default.
2059# to turn of the endpoint being set use endp=>0 when calling line.
02d1d628
AMH		 2060
2061sub line {
2062 my $self=shift;
2063 my $dflcl=i_color_new(0,0,0,0);
aa833c97
AMH		 2064 my %opts=(color=>$dflcl,
2065 endp => 1,
2066 @_);
02d1d628
AMH		 2067 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2068
2069 unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2070 unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2071
3a9a4241 2072 my $color = _color($opts{'color'});
aa833c97
AMH		 2073 unless ($color) {
2074 $self->{ERRSTR} = $Imager::ERRSTR;
2075 return;
3a9a4241 2076 }
aa833c97 2077
3a9a4241 2078 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628 2079 if ($opts{antialias}) {
aa833c97 2080 i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
b437ce0a 2081 $color, $opts{endp});
02d1d628 2082 } else {
aa833c97
AMH		 2083 i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2084 $color, $opts{endp});
02d1d628
AMH		 2085 }
2086 return $self;
2087}
2088
2089# Draws a line between an ordered set of points - It more or less just transforms this
2090# into a list of lines.
2091
2092sub polyline {
2093 my $self=shift;
2094 my ($pt,$ls,@points);
2095 my $dflcl=i_color_new(0,0,0,0);
2096 my %opts=(color=>$dflcl,@_);
2097
2098 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2099
2100 if (exists($opts{points})) { @points=@{$opts{points}}; }
2101 if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2102 @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2103 }
2104
2105# print Dumper(\@points);
2106
3a9a4241
TC		 2107 my $color = _color($opts{'color'});
2108 unless ($color) {
2109 $self->{ERRSTR} = $Imager::ERRSTR;
2110 return;
2111 }
2112 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628
AMH		 2113 if ($opts{antialias}) {
2114 for $pt(@points) {
3a9a4241 2115 if (defined($ls)) {
b437ce0a 2116 i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
3a9a4241 2117 }
02d1d628
AMH		 2118 $ls=$pt;
2119 }
2120 } else {
2121 for $pt(@points) {
3a9a4241 2122 if (defined($ls)) {
aa833c97 2123 i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
3a9a4241 2124 }
02d1d628
AMH		 2125 $ls=$pt;
2126 }
2127 }
2128 return $self;
2129}
2130
d0e7bfee
AMH		 2131sub polygon {
2132 my $self = shift;
2133 my ($pt,$ls,@points);
2134 my $dflcl = i_color_new(0,0,0,0);
2135 my %opts = (color=>$dflcl, @_);
2136
2137 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2138
2139 if (exists($opts{points})) {
2140 $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2141 $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2142 }
2143
2144 if (!exists $opts{'x'} or !exists $opts{'y'}) {
2145 $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2146 }
2147
43c5dacb
TC		 2148 if ($opts{'fill'}) {
2149 unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2150 # assume it's a hash ref
2151 require 'Imager/Fill.pm';
2152 unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2153 $self->{ERRSTR} = $Imager::ERRSTR;
2154 return undef;
2155 }
2156 }
2157 i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2158 $opts{'fill'}{'fill'});
2159 }
2160 else {
3a9a4241
TC		 2161 my $color = _color($opts{'color'});
2162 unless ($color) {
2163 $self->{ERRSTR} = $Imager::ERRSTR;
2164 return;
2165 }
2166 i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
43c5dacb
TC		 2167 }
2168
d0e7bfee
AMH		 2169 return $self;
2170}
2171
2172
2173# this the multipoint bezier curve
02d1d628
AMH		 2174# this is here more for testing that actual usage since
2175# this is not a good algorithm. Usually the curve would be
2176# broken into smaller segments and each done individually.
2177
2178sub polybezier {
2179 my $self=shift;
2180 my ($pt,$ls,@points);
2181 my $dflcl=i_color_new(0,0,0,0);
2182 my %opts=(color=>$dflcl,@_);
2183
2184 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2185
2186 if (exists $opts{points}) {
2187 $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
2188 $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
2189 }
2190
2191 unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
2192 $self->{ERRSTR}='Missing or invalid points.';
2193 return;
2194 }
2195
3a9a4241
TC		 2196 my $color = _color($opts{'color'});
2197 unless ($color) {
2198 $self->{ERRSTR} = $Imager::ERRSTR;
2199 return;
2200 }
2201 i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
02d1d628
AMH		 2202 return $self;
2203}
2204
cc6483e0
TC		 2205sub flood_fill {
2206 my $self = shift;
2207 my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
aa833c97
AMH		 2208 my $rc;
2209
9d540150 2210 unless (exists $opts{'x'} && exists $opts{'y'}) {
cc6483e0
TC		 2211 $self->{ERRSTR} = "missing seed x and y parameters";
2212 return undef;
2213 }
07d70837 2214
cc6483e0
TC		 2215 if ($opts{fill}) {
2216 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2217 # assume it's a hash ref
2218 require 'Imager/Fill.pm';
569795e8
TC		 2219 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2220 $self->{ERRSTR} = $Imager::ERRSTR;
2221 return;
2222 }
cc6483e0 2223 }
a321d497 2224 $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
cc6483e0
TC		 2225 }
2226 else {
3a9a4241 2227 my $color = _color($opts{'color'});
aa833c97
AMH		 2228 unless ($color) {
2229 $self->{ERRSTR} = $Imager::ERRSTR;
2230 return;
3a9a4241 2231 }
a321d497 2232 $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
cc6483e0 2233 }
aa833c97 2234 if ($rc) { $self; } else { $self->{ERRSTR} = $self->_error_as_msg(); return (); }
cc6483e0
TC		 2235}
2236
591b5954
TC		 2237sub setpixel {
2238 my $self = shift;
2239
2240 my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
2241
2242 unless (exists $opts{'x'} && exists $opts{'y'}) {
2243 $self->{ERRSTR} = 'missing x and y parameters';
2244 return undef;
2245 }
2246
2247 my $x = $opts{'x'};
2248 my $y = $opts{'y'};
2249 my $color = _color($opts{color})
2250 or return undef;
2251 if (ref $x && ref $y) {
2252 unless (@$x == @$y) {
9650c424 2253 $self->{ERRSTR} = 'length of x and y mismatch';
591b5954
TC		 2254 return undef;
2255 }
2256 if ($color->isa('Imager::Color')) {
2257 for my $i (0..$#{$opts{'x'}}) {
2258 i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color);
2259 }
2260 }
2261 else {
2262 for my $i (0..$#{$opts{'x'}}) {
2263 i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color);
2264 }
2265 }
2266 }
2267 else {
2268 if ($color->isa('Imager::Color')) {
2269 i_ppix($self->{IMG}, $x, $y, $color);
2270 }
2271 else {
2272 i_ppixf($self->{IMG}, $x, $y, $color);
2273 }
2274 }
2275
2276 $self;
2277}
2278
2279sub getpixel {
2280 my $self = shift;
2281
a9fa203f 2282 my %opts = ( "type"=>'8bit', @_);
591b5954
TC		 2283
2284 unless (exists $opts{'x'} && exists $opts{'y'}) {
2285 $self->{ERRSTR} = 'missing x and y parameters';
2286 return undef;
2287 }
2288
2289 my $x = $opts{'x'};
2290 my $y = $opts{'y'};
2291 if (ref $x && ref $y) {
2292 unless (@$x == @$y) {
2293 $self->{ERRSTR} = 'length of x and y mismatch';
2294 return undef;
2295 }
2296 my @result;
a9fa203f 2297 if ($opts{"type"} eq '8bit') {
591b5954
TC		 2298 for my $i (0..$#{$opts{'x'}}) {
2299 push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
2300 }
2301 }
2302 else {
2303 for my $i (0..$#{$opts{'x'}}) {
2304 push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
2305 }
2306 }
2307 return wantarray ? @result : \@result;
2308 }
2309 else {
a9fa203f 2310 if ($opts{"type"} eq '8bit') {
591b5954
TC		 2311 return i_get_pixel($self->{IMG}, $x, $y);
2312 }
2313 else {
2314 return i_gpixf($self->{IMG}, $x, $y);
2315 }
2316 }
2317
2318 $self;
2319}
2320
f5991c03
TC		 2321# make an identity matrix of the given size
2322sub _identity {
2323 my ($size) = @_;
2324
2325 my $matrix = [ map { [ (0) x $size ] } 1..$size ];
2326 for my $c (0 .. ($size-1)) {
2327 $matrix->[$c][$c] = 1;
2328 }
2329 return $matrix;
2330}
2331
2332# general function to convert an image
2333sub convert {
2334 my ($self, %opts) = @_;
2335 my $matrix;
2336
2337 # the user can either specify a matrix or preset
2338 # the matrix overrides the preset
2339 if (!exists($opts{matrix})) {
2340 unless (exists($opts{preset})) {
2341 $self->{ERRSTR} = "convert() needs a matrix or preset";
2342 return;
2343 }
2344 else {
2345 if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
2346 # convert to greyscale, keeping the alpha channel if any
2347 if ($self->getchannels == 3) {
2348 $matrix = [ [ 0.222, 0.707, 0.071 ] ];
2349 }
2350 elsif ($self->getchannels == 4) {
2351 # preserve the alpha channel
2352 $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
2353 [ 0, 0, 0, 1 ] ];
2354 }
2355 else {
2356 # an identity
2357 $matrix = _identity($self->getchannels);
2358 }
2359 }
2360 elsif ($opts{preset} eq 'noalpha') {
2361 # strip the alpha channel
2362 if ($self->getchannels == 2 or $self->getchannels == 4) {
2363 $matrix = _identity($self->getchannels);
2364 pop(@$matrix); # lose the alpha entry
2365 }
2366 else {
2367 $matrix = _identity($self->getchannels);
2368 }
2369 }
2370 elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
2371 # extract channel 0
2372 $matrix = [ [ 1 ] ];
2373 }
2374 elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
2375 $matrix = [ [ 0, 1 ] ];
2376 }
2377 elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
2378 $matrix = [ [ 0, 0, 1 ] ];
2379 }
2380 elsif ($opts{preset} eq 'alpha') {
2381 if ($self->getchannels == 2 or $self->getchannels == 4) {
2382 $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
2383 }
2384 else {
2385 # the alpha is just 1 <shrug>
2386 $matrix = [ [ (0) x $self->getchannels, 1 ] ];
2387 }
2388 }
2389 elsif ($opts{preset} eq 'rgb') {
2390 if ($self->getchannels == 1) {
2391 $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
2392 }
2393 elsif ($self->getchannels == 2) {
2394 # preserve the alpha channel
2395 $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
2396 }
2397 else {
2398 $matrix = _identity($self->getchannels);
2399 }
2400 }
2401 elsif ($opts{preset} eq 'addalpha') {
2402 if ($self->getchannels == 1) {
2403 $matrix = _identity(2);
2404 }
2405 elsif ($self->getchannels == 3) {
2406 $matrix = _identity(4);
2407 }
2408 else {
2409 $matrix = _identity($self->getchannels);
2410 }
2411 }
2412 else {
2413 $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
2414 return undef;
2415 }
2416 }
2417 }
2418 else {
2419 $matrix = $opts{matrix};
2420 }
2421
2422 my $new = Imager->new();
2423 $new->{IMG} = i_img_new();
2424 unless (i_convert($new->{IMG}, $self->{IMG}, $matrix)) {
2425 # most likely a bad matrix
2426 $self->{ERRSTR} = _error_as_msg();
2427 return undef;
2428 }
2429 return $new;
2430}
40eba1ea
AMH		 2431
2432
40eba1ea 2433# general function to map an image through lookup tables
9495ee93 2434
40eba1ea
AMH		 2435sub map {
2436 my ($self, %opts) = @_;
9495ee93 2437 my @chlist = qw( red green blue alpha );
40eba1ea
AMH		 2438
2439 if (!exists($opts{'maps'})) {
2440 # make maps from channel maps
2441 my $chnum;
2442 for $chnum (0..$#chlist) {
9495ee93
AMH		 2443 if (exists $opts{$chlist[$chnum]}) {
2444 $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
2445 } elsif (exists $opts{'all'}) {
2446 $opts{'maps'}[$chnum] = $opts{'all'};
2447 }
40eba1ea
AMH		 2448 }
2449 }
2450 if ($opts{'maps'} and $self->{IMG}) {
2451 i_map($self->{IMG}, $opts{'maps'} );
2452 }
2453 return $self;
2454}
2455
dff75dee
TC		 2456sub difference {
2457 my ($self, %opts) = @_;
2458
2459 defined $opts{mindist} or $opts{mindist} = 0;
2460
2461 defined $opts{other}
2462 or return $self->_set_error("No 'other' parameter supplied");
2463 defined $opts{other}{IMG}
2464 or return $self->_set_error("No image data in 'other' image");
2465
2466 $self->{IMG}
2467 or return $self->_set_error("No image data");
2468
2469 my $result = Imager->new;
2470 $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
2471 $opts{mindist})
2472 or return $self->_set_error($self->_error_as_msg());
2473
2474 return $result;
2475}
2476
02d1d628
AMH		 2477# destructive border - image is shrunk by one pixel all around
2478
2479sub border {
2480 my ($self,%opts)=@_;
2481 my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
2482 $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
2483}
2484
2485
2486# Get the width of an image
2487
2488sub getwidth {
2489 my $self = shift;
2490 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2491 return (i_img_info($self->{IMG}))[0];
2492}
2493
2494# Get the height of an image
2495
2496sub getheight {
2497 my $self = shift;
2498 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2499 return (i_img_info($self->{IMG}))[1];
2500}
2501
2502# Get number of channels in an image
2503
2504sub getchannels {
2505 my $self = shift;
2506 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2507 return i_img_getchannels($self->{IMG});
2508}
2509
2510# Get channel mask
2511
2512sub getmask {
2513 my $self = shift;
2514 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2515 return i_img_getmask($self->{IMG});
2516}
2517
2518# Set channel mask
2519
2520sub setmask {
2521 my $self = shift;
2522 my %opts = @_;
2523 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
2524 i_img_setmask( $self->{IMG} , $opts{mask} );
2525}
2526
2527# Get number of colors in an image
2528
2529sub getcolorcount {
2530 my $self=shift;
9d540150 2531 my %opts=('maxcolors'=>2**30,@_);
02d1d628
AMH		 2532 if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
2533 my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
2534 return ($rc==-1? undef : $rc);
2535}
2536
2537# draw string to an image
2538
2539sub string {
2540 my $self = shift;
2541 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2542
2543 my %input=('x'=>0, 'y'=>0, @_);
2544 $input{string}||=$input{text};
2545
2546 unless(exists $input{string}) {
2547 $self->{ERRSTR}="missing required parameter 'string'";
2548 return;
2549 }
2550
2551 unless($input{font}) {
2552 $self->{ERRSTR}="missing required parameter 'font'";
2553 return;
2554 }
2555
faa9b3e7
TC		 2556 unless ($input{font}->draw(image=>$self, %input)) {
2557 $self->{ERRSTR} = $self->_error_as_msg();
2558 return;
2559 }
02d1d628
AMH		 2560
2561 return $self;
2562}
2563
02d1d628
AMH		 2564# Shortcuts that can be exported
2565
2566sub newcolor { Imager::Color->new(@_); }
2567sub newfont { Imager::Font->new(@_); }
2568
2569*NC=*newcolour=*newcolor;
2570*NF=*newfont;
2571
2572*open=\&read;
2573*circle=\&arc;
2574
2575
2576#### Utility routines
2577
faa9b3e7
TC		 2578sub errstr {
2579 ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
2580}
02d1d628 2581
10461f9a
TC		 2582sub _set_error {
2583 my ($self, $msg) = @_;
2584
2585 if (ref $self) {
2586 $self->{ERRSTR} = $msg;
2587 }
2588 else {
2589 $ERRSTR = $msg;
2590 }
dff75dee 2591 return;
10461f9a
TC		 2592}
2593
02d1d628
AMH		 2594# Default guess for the type of an image from extension
2595
2596sub def_guess_type {
2597 my $name=lc(shift);
2598 my $ext;
2599 $ext=($name =~ m/\.([^\.]+)$/)[0];
2600 return 'tiff' if ($ext =~ m/^tiff?$/);
2601 return 'jpeg' if ($ext =~ m/^jpe?g$/);
2602 return 'pnm' if ($ext =~ m/^p[pgb]m$/);
2603 return 'png' if ($ext eq "png");
705fd961 2604 return 'bmp' if ($ext eq "bmp" || $ext eq "dib");
1ec86afa 2605 return 'tga' if ($ext eq "tga");
737a830c 2606 return 'rgb' if ($ext eq "rgb");
02d1d628 2607 return 'gif' if ($ext eq "gif");
10461f9a 2608 return 'raw' if ($ext eq "raw");
02d1d628
AMH		 2609 return ();
2610}
2611
2612# get the minimum of a list
2613
2614sub min {
2615 my $mx=shift;
2616 for(@_) { if ($_<$mx) { $mx=$_; }}
2617 return $mx;
2618}
2619
2620# get the maximum of a list
2621
2622sub max {
2623 my $mx=shift;
2624 for(@_) { if ($_>$mx) { $mx=$_; }}
2625 return $mx;
2626}
2627
2628# string stuff for iptc headers
2629
2630sub clean {
2631 my($str)=$_[0];
2632 $str = substr($str,3);
2633 $str =~ s/[\n\r]//g;
2634 $str =~ s/\s+/ /g;
2635 $str =~ s/^\s//;
2636 $str =~ s/\s$//;
2637 return $str;
2638}
2639
2640# A little hack to parse iptc headers.
2641
2642sub parseiptc {
2643 my $self=shift;
2644 my(@sar,$item,@ar);
2645 my($caption,$photogr,$headln,$credit);
2646
2647 my $str=$self->{IPTCRAW};
2648
2649 #print $str;
2650
2651 @ar=split(/8BIM/,$str);
2652
2653 my $i=0;
2654 foreach (@ar) {
2655 if (/^\004\004/) {
2656 @sar=split(/\034\002/);
2657 foreach $item (@sar) {
cdd23610 2658 if ($item =~ m/^x/) {
02d1d628
AMH		 2659 $caption=&clean($item);
2660 $i++;
2661 }
cdd23610 2662 if ($item =~ m/^P/) {
02d1d628
AMH		 2663 $photogr=&clean($item);
2664 $i++;
2665 }
cdd23610 2666 if ($item =~ m/^i/) {
02d1d628
AMH		 2667 $headln=&clean($item);
2668 $i++;
2669 }
cdd23610 2670 if ($item =~ m/^n/) {
02d1d628
AMH		 2671 $credit=&clean($item);
2672 $i++;
2673 }
2674 }
2675 }
2676 }
2677 return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
2678}
2679
02d1d628
AMH		 2680# Autoload methods go after =cut, and are processed by the autosplit program.
2681
26821;
2683__END__
2684# Below is the stub of documentation for your module. You better edit it!
2685
2686=head1 NAME
2687
2688Imager - Perl extension for Generating 24 bit Images
2689
2690=head1 SYNOPSIS
2691
0e418f1e
AMH		 2692 # Thumbnail example
2693
2694 #!/usr/bin/perl -w
2695 use strict;
10461f9a 2696 use Imager;
02d1d628 2697
0e418f1e
AMH		 2698 die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
2699 my $file = shift;
2700
2701 my $format;
2702
2703 my $img = Imager->new();
e36d02ad
TC		 2704 # see Imager::Files for information on the read() method
2705 $img->read(file=>$file) or die $img->errstr();
0e418f1e
AMH		 2706
2707 $file =~ s/\.[^.]*$//;
2708
2709 # Create smaller version
cf7a7d18 2710 # documented in Imager::Transformations
0e418f1e
AMH		 2711 my $thumb = $img->scale(scalefactor=>.3);
2712
2713 # Autostretch individual channels
2714 $thumb->filter(type=>'autolevels');
2715
2716 # try to save in one of these formats
2717 SAVE:
2718
2719 for $format ( qw( png gif jpg tiff ppm ) ) {
2720 # Check if given format is supported
2721 if ($Imager::formats{$format}) {
2722 $file.="_low.$format";
2723 print "Storing image as: $file\n";
cf7a7d18 2724 # documented in Imager::Files
0e418f1e
AMH		 2725 $thumb->write(file=>$file) or
2726 die $thumb->errstr;
2727 last SAVE;
2728 }
2729 }
2730
02d1d628
AMH		 2731=head1 DESCRIPTION
2732
0e418f1e
AMH		 2733Imager is a module for creating and altering images. It can read and
2734write various image formats, draw primitive shapes like lines,and
2735polygons, blend multiple images together in various ways, scale, crop,
2736render text and more.
02d1d628 2737
5df0fac7
AMH		 2738=head2 Overview of documentation
2739
2740=over
2741
cf7a7d18 2742=item *
5df0fac7 2743
cf7a7d18
TC		 2744Imager - This document - Synopsis Example, Table of Contents and
2745Overview.
5df0fac7 2746
cf7a7d18 2747=item *
5df0fac7 2748
e1d57e9d
TC		 2749L<Imager::Cookbook> - how to do various things with Imager.
2750
2751=item *
2752
cf7a7d18
TC		 2753L<Imager::ImageTypes> - Basics of constructing image objects with
2754C<new()>: Direct type/virtual images, RGB(A)/paletted images,
27558/16/double bits/channel, color maps, channel masks, image tags, color
6d0ed98a 2756quantization. Also discusses basic image information methods.
5df0fac7 2757
cf7a7d18 2758=item *
5df0fac7 2759
cf7a7d18
TC		 2760L<Imager::Files> - IO interaction, reading/writing images, format
2761specific tags.
5df0fac7 2762
cf7a7d18 2763=item *
5df0fac7 2764
cf7a7d18
TC		 2765L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
2766flood fill.
5df0fac7 2767
cf7a7d18 2768=item *
5df0fac7 2769
cf7a7d18 2770L<Imager::Color> - Color specification.
5df0fac7 2771
cf7a7d18 2772=item *
f5fd108b 2773
cf7a7d18 2774L<Imager::Fill> - Fill pattern specification.
f5fd108b 2775
cf7a7d18 2776=item *
5df0fac7 2777
cf7a7d18
TC		 2778L<Imager::Font> - General font rendering, bounding boxes and font
2779metrics.
5df0fac7 2780
cf7a7d18 2781=item *
5df0fac7 2782
cf7a7d18
TC		 2783L<Imager::Transformations> - Copying, scaling, cropping, flipping,
2784blending, pasting, convert and map.
5df0fac7 2785
cf7a7d18 2786=item *
5df0fac7 2787
cf7a7d18
TC		 2788L<Imager::Engines> - Programmable transformations through
2789C<transform()>, C<transform2()> and C<matrix_transform()>.
5df0fac7 2790
cf7a7d18 2791=item *
5df0fac7 2792
cf7a7d18
TC		 2793L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
2794filter plugins.
5df0fac7 2795
cf7a7d18 2796=item *
5df0fac7 2797
cf7a7d18
TC		 2798L<Imager::Expr> - Expressions for evaluation engine used by
2799transform2().
5df0fac7 2800
cf7a7d18 2801=item *
5df0fac7 2802
cf7a7d18 2803L<Imager::Matrix2d> - Helper class for affine transformations.
5df0fac7 2804
cf7a7d18 2805=item *
5df0fac7 2806
cf7a7d18 2807L<Imager::Fountain> - Helper for making gradient profiles.
5df0fac7
AMH		 2808
2809=back
2810
0e418f1e 2811=head2 Basic Overview
02d1d628 2812
55b287f5
AMH		 2813An Image object is created with C<$img = Imager-E<gt>new()>.
2814Examples:
02d1d628 2815
55b287f5 2816 $img=Imager->new(); # create empty image
e36d02ad 2817 $img->read(file=>'lena.png',type=>'png') or # read image from file
55b287f5
AMH		 2818 die $img->errstr(); # give an explanation
2819 # if something failed
02d1d628
AMH		 2820
2821or if you want to create an empty image:
2822
2823 $img=Imager->new(xsize=>400,ysize=>300,channels=>4);
2824
0e418f1e
AMH		 2825This example creates a completely black image of width 400 and height
2826300 and 4 channels.
2827
55b287f5
AMH		 2828When an operation fails which can be directly associated with an image
2829the error message is stored can be retrieved with
2830C<$img-E<gt>errstr()>.
2831
2832In cases where no image object is associated with an operation
2833C<$Imager::ERRSTR> is used to report errors not directly associated
99958502
TC		 2834with an image object. You can also call C<Imager->errstr> to get this
2835value.
55b287f5 2836
cf7a7d18
TC		 2837The C<Imager-E<gt>new> method is described in detail in
2838L<Imager::ImageTypes>.
4b4f5319 2839
13fc481e
TC		 2840=head1 METHOD INDEX
2841
2842Where to find information on methods for Imager class objects.
2843
2844addcolors() - L<Imager::ImageTypes>
2845
2846addtag() - L<Imager::ImageTypes> - add image tags
2847
2848arc() - L<Imager::Draw/arc>
2849
2850bits() - L<Imager::ImageTypes> - number of bits per sample for the
2851image
2852
2853box() - L<Imager::Draw/box>
2854
2855circle() - L<Imager::Draw/circle>
2856
2857convert() - L<Imager::Transformations/"Color transformations"> -
2858transform the color space
2859
2860copy() - L<Imager::Transformations/copy>
2861
2862crop() - L<Imager::Transformations/crop> - extract part of an image
2863
2864deltag() - L<Imager::ImageTypes> - delete image tags
2865
2866difference() - L<Imager::Filters/"Image Difference">
2867
99958502
TC		 2868errstr() - L<Imager/"Basic Overview">
2869
13fc481e
TC		 2870filter() - L<Imager::Filters>
2871
2872findcolor() - L<Imager::ImageTypes> - search the image palette, if it
2873has one
2874
2875flip() - L<Imager::Transformations/flip>
2876
2877flood_fill() - L<Imager::Draw/flood_fill>
2878
2879getchannels() - L<Imager::ImageTypes>
2880
2881getcolorcount() - L<Imager::ImageTypes>
2882
2883getcolors() - L<Imager::ImageTypes> - get colors from the image
2884palette, if it has one
2885
2886getheight() - L<Imager::ImageTypes>
2887
2888getpixel() - L<Imager::Draw/setpixel and getpixel>
2889
2890getwidth() - L<Imager::ImageTypes>
2891
2892img_set() - L<Imager::ImageTypes>
2893
2894line() - L<Imager::Draw/line>
2895
2896map() - L<Imager::Transformations/"Color Mappings"> - remap color
2897channel values
2898
2899masked() - L<Imager::ImageTypes> - make a masked image
2900
2901matrix_transform() - L<Imager::Engines/"Matrix Transformations">
2902
2903new() - L<Imager::ImageTypes>
2904
e36d02ad
TC		 2905open() - L<Imager::Files> - an alias for read()
2906
13fc481e
TC		 2907paste() - L<Imager::Transformations/paste> - draw an image onto an image
2908
2909polygon() - L<Imager::Draw/polygon>
2910
2911polyline() - L<Imager::Draw/polyline>
2912
e36d02ad 2913read() - L<Imager::Files> - read a single image from an image file
13fc481e 2914
e36d02ad
TC		 2915read_multi() - L<Imager::Files> - read multiple images from an image
2916file
13fc481e
TC		 2917
2918rotate() - L<Imager::Transformations/rotate>
2919
2920rubthrough() - L<Imager::Transformations/rubthrough> - draw an image onto an
2921image and use the alpha channel
2922
2923scale() - L<Imager::Transformations/scale>
1adb5500
TC		 2924
2925scaleX() - L<Imager::Transformations/scaleX>
2926
2927scaleY() - L<Imager::Transformations/scaleY>
13fc481e
TC		 2928
2929setcolors() - L<Imager::ImageTypes> - set palette colors in a paletted image
2930
2931setpixel() - L<Imager::Draw/setpixel and getpixel>
2932
2933string() - L<Imager::Font/string> - draw text on an image
2934
2935tags() - L<Imager::ImageTypes> - fetch image tags
2936
2937to_paletted() - L<Imager::ImageTypes>
2938
2939to_rgb8() - L<Imager::ImageTypes>
2940
2941transform() - L<Imager::Engines/"transform">
2942
2943transform2() - L<Imager::Engines/"transform2">
2944
2945type() - L<Imager::ImageTypes> - type of image (direct vs paletted)
2946
2947virtual() - L<Imager::ImageTypes> - whether the image has it's own
2948data
2949
e36d02ad 2950write() - L<Imager::Files> - write an image to a file
13fc481e 2951
e36d02ad
TC		 2952write_multi() - L<Imager::Files> - write multiple image to an image
2953file.
13fc481e 2954
dc67bc2f
TC		 2955=head1 CONCEPT INDEX
2956
2957animated GIF - L<Imager::File/"Writing an animated GIF">
2958
2959aspect ratio - L<Imager::ImageTypes/i_xres>,
2960L<Imager::ImageTypes/i_yres>, L<Imager::ImageTypes/i_aspect_only>
2961
2962blur - L<Imager::Filters/guassian>, L<Imager::Filters/conv>
2963
2964boxes, drawing - L<Imager::Draw/box>
2965
2966color - L<Imager::Color>
2967
2968color names - L<Imager::Color>, L<Imager::Color::Table>
2969
2970combine modes - L<Imager::Fill/combine>
2971
a4e6485d
TC		 2972contrast - L<Imager::Filter/contrast>, L<Imager::Filter/autolevels>
2973
2974convolution - L<Imager::Filter/conv>
2975
dc67bc2f
TC		 2976cropping - L<Imager::Transformations/crop>
2977
2978dpi - L<Imager::ImageTypes/i_xres>
2979
2980drawing boxes - L<Imager::Draw/box>
2981
2982drawing lines - L<Imager::Draw/line>
2983
2984drawing text - L<Imager::Font/string>
2985
2986error message - L<Imager/"Basic Overview">
2987
2988files, font - L<Imager::Font>
2989
2990files, image - L<Imager::Files>
2991
2992filling, types of fill - L<Imager::Fill>
2993
2994filling, boxes - L<Imager::Draw/box>
2995
2996filling, flood fill - L<Imager::Draw/flood_fill>
2997
2998flood fill - L<Imager::Draw/flood_fill>
2999
3000fonts - L<Imager::Font>
3001
3002fonts, drawing with - L<Imager::Font/string>, L<Imager::Font/align>,
3003L<Imager::Font::Wrap>
3004
3005fonts, metrics - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3006
3007fonts, multiple master - L<Imager::Font/"MULTIPLE MASTER FONTS">
3008
3009fountain fill - L<Imager::Fill/"Fountain fills">,
3010L<Imager::Filters/fountain>, L<Imager::Fountain>,
3011L<Imager::Filters/gradgen>
3012
a4e6485d
TC		 3013GIF files - L<Imager::Files/"GIF">
3014
3015GIF files, animated - L<Imager::File/"Writing an animated GIF">
3016
dc67bc2f
TC		 3017gradient fill - L<Imager::Fill/"Fountain fills">,
3018L<Imager::Filters/fountain>, L<Imager::Fountain>,
3019L<Imager::Filters/gradgen>
3020
a4e6485d
TC		 3021guassian blur - L<Imager::Filter/guassian>
3022
dc67bc2f
TC		 3023hatch fills - L<Imager::Fill/"Hatched fills">
3024
a4e6485d
TC		 3025invert image - L<Imager::Filter/hardinvert>
3026
dc67bc2f
TC		 3027JPEG - L<Imager::Files/"JPEG">
3028
3029lines, drawing - L<Imager::Draw/line>
3030
a4e6485d
TC		 3031matrix - L<Imager::Matrix2d>,
3032L<Imager::Transformations/"Matrix Transformations">,
3033L<Imager::Font/transform>
3034
dc67bc2f
TC		 3035metadata, image - L<Imager::ImageTypes/"Tags">
3036
a4e6485d
TC		 3037mosaic - L<Imager::Filter/mosaic>
3038
3039noise, filter - L<Imager::Filter/noise>
3040
3041noise, rendered - L<Imager::Filter/turbnoise>,
3042L<Imager::Filter/radnoise>
3043
3044posterize - L<Imager::Filter/postlevels>
3045
3046png files - L<Imager::Files>, L<Imager::Files/"PNG">
dc67bc2f
TC		 3047
3048pnm - L<Imager::Files/"PNM (Portable aNy Map">
3049
3050rectangles, drawing - L<Imager::Draw/box>
3051
3052resizing an image - L<Imager::Transformations/scale>,
3053L<Imager::Transformations/crop>
3054
3055saving an image - L<Imager::Files>
3056
3057scaling - L<Imager::Transformations/scale>
3058
3059sharpen - L<Imager::Filters/unsharpmask>, L<Imager::Filters/conv>
3060
3061size, image - L<Imager::ImageTypes/getwidth>,
3062L<Imager::ImageTypes/getheight>
3063
3064size, text - L<Imager::Font/bounding_box>
3065
3066text, drawing - L<Imager::Font/string>, L<Imager::Font/align>,
3067L<Imager::Font::Wrap>
3068
3069text, wrapping text in an area - L<Imager::Font::Wrap>
3070
3071text, measuring - L<Imager::Font/bounding_box>, L<Imager::Font::BBox>
3072
a4e6485d
TC		 3073tiles, color - L<Imager::Filter/mosaic>
3074
3075unsharp mask - L<Imager::Filter/unsharpmask>
3076
3077watermark - L<Imager::Filter/watermark>
3078
dc67bc2f
TC		 3079writing an image - L<Imager::Files>
3080
f64132d2 3081=head1 SUPPORT
0e418f1e 3082
f64132d2
TC		 3083You can ask for help, report bugs or express your undying love for
3084Imager on the Imager-devel mailing list.
02d1d628 3085
f64132d2
TC		 3086To subscribe send a message with C<subscribe> in the body to:
3087
3088 imager-devel+request@molar.is
3089
3090or use the form at:
3091
3092 http://www.molar.is/en/lists/imager-devel/
55b287f5 3093 (annonymous is temporarily off due to spam)
f64132d2
TC		 3094
3095where you can also find the mailing list archive.
10461f9a 3096
3ed96cd3 3097If you're into IRC, you can typically find the developers in #Imager
8f22b8d8
TC		 3098on irc.perl.org. As with any IRC channel, the participants could be
3099occupied or asleep, so please be patient.
3100
3101You can report bugs either by sending email to:
3102
3103 bug-Imager@rt.cpan.org
3104
3105or by pointing your browser at:
3106
3107 https://rt.cpan.org/NoAuth/ReportBug.html?Queue=Imager
3108
3109Please remember to include the versions of Imager, perl, supporting
3110libraries, and any relevant code. If you have specific images that
3111cause the problems, please include those too.
3ed96cd3 3112
02d1d628
AMH		 3113=head1 BUGS
3114
0e418f1e 3115Bugs are listed individually for relevant pod pages.
02d1d628
AMH		 3116
3117=head1 AUTHOR
3118
55b287f5 3119Arnar M. Hrafnkelsson (addi@imager.perl.org) and Tony Cook
f64132d2 3120(tony@imager.perl.org) See the README for a complete list.
02d1d628 3121
9495ee93 3122=head1 SEE ALSO
02d1d628 3123
55b287f5
AMH		 3124perl(1), Imager::ImageTypes(3), Imager::Files(3), Imager::Draw(3),
3125Imager::Color(3), Imager::Fill(3), Imager::Font(3),
3126Imager::Transformations(3), Imager::Engines(3), Imager::Filters(3),
3127Imager::Expr(3), Imager::Matrix2d(3), Imager::Fountain(3)
009db950
AMH		 3128
3129Affix::Infix2Postfix(3), Parse::RecDescent(3)
8f22b8d8 3130http://imager.perl.org/
02d1d628
AMH		 3131
3132=cut
Image manipulation for perl