projects / imager.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
[rt #69147] detect and use snprintf() more
[imager.git] / Imager.pm
CommitLineData
02d1d628
AMH		 1package Imager;
2
02d1d628 3use strict;
50c75381 4use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS %formats $DEBUG %filters %DSOs $ERRSTR %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 21 i_list_formats
dd55acc8 22
02d1d628
AMH		 23 i_color_new
24 i_color_set
25 i_color_info
dd55acc8 26
02d1d628
AMH		 27 i_img_empty
28 i_img_empty_ch
29 i_img_exorcise
30 i_img_destroy
31
32 i_img_info
33
34 i_img_setmask
35 i_img_getmask
36
aa833c97 37 i_line
02d1d628
AMH		 38 i_line_aa
39 i_box
40 i_box_filled
41 i_arc
18063344 42 i_circle_aa
dd55acc8 43
02d1d628
AMH		 44 i_bezier_multi
45 i_poly_aa
43c5dacb 46 i_poly_aa_cfill
02d1d628
AMH		 47
48 i_copyto
49 i_rubthru
50 i_scaleaxis
51 i_scale_nn
52 i_haar
53 i_count_colors
dd55acc8 54
02d1d628
AMH		 55 i_gaussian
56 i_conv
dd55acc8 57
f5991c03 58 i_convert
40eba1ea 59 i_map
dd55acc8 60
02d1d628
AMH		 61 i_img_diff
62
02d1d628
AMH		 63 i_tt_set_aa
64 i_tt_cp
65 i_tt_text
66 i_tt_bbox
67
02d1d628 68 i_readpnm_wiol
067d6bdc 69 i_writeppm_wiol
02d1d628 70
895dbd34
AMH		 71 i_readraw_wiol
72 i_writeraw_wiol
02d1d628
AMH		 73
74 i_contrast
75 i_hardinvert
76 i_noise
77 i_bumpmap
78 i_postlevels
79 i_mosaic
80 i_watermark
dd55acc8 81
02d1d628
AMH		 82 malloc_state
83
84 list_formats
dd55acc8 85
02d1d628
AMH		 86 i_gifquant
87
88 newfont
89 newcolor
90 newcolour
91 NC
92 NF
bd8052a6 93 NCF
02d1d628
AMH		 94);
95
9982a307 96@EXPORT=qw(
02d1d628
AMH		 97 );
98
99%EXPORT_TAGS=
100 (handy => [qw(
101 newfont
102 newcolor
103 NF
104 NC
bd8052a6 105 NCF
02d1d628
AMH		 106 )],
107 all => [@EXPORT_OK],
108 default => [qw(
109 load_plugin
110 unload_plugin
111 )]);
112
53a6bbd4
TC		 113# registered file readers
114my %readers;
115
2b405c9e
TC		 116# registered file writers
117my %writers;
118
53a6bbd4
TC		 119# modules we attempted to autoload
120my %attempted_to_load;
121
5970bd39
TC		 122# errors from loading files
123my %file_load_errors;
124
125# what happened when we tried to load
126my %reader_load_errors;
127my %writer_load_errors;
128
f245645a
TC		 129# library keys that are image file formats
130my %file_formats = map { $_ => 1 } qw/tiff pnm gif png jpeg raw bmp tga/;
131
9b1ec2b8
TC		 132# image pixel combine types
133my @combine_types =
134 qw/none normal multiply dissolve add subtract diff lighten darken
135 hue saturation value color/;
136my %combine_types;
137@combine_types{@combine_types} = 0 .. $#combine_types;
138$combine_types{mult} = $combine_types{multiply};
139$combine_types{'sub'} = $combine_types{subtract};
140$combine_types{sat} = $combine_types{saturation};
141
142# this will be used to store global defaults at some point
143my %defaults;
144
02d1d628
AMH		 145BEGIN {
146 require Exporter;
f10bedbb
TC		 147 my $ex_version = eval $Exporter::VERSION;
148 if ($ex_version < 5.57) {
b1e66a82
TC		 149 @ISA = qw(Exporter);
150 }
fa61d195 151 $VERSION = '0.84_01';
92bda632
TC		 152 eval {
153 require XSLoader;
154 XSLoader::load(Imager => $VERSION);
155 1;
156 } or do {
157 require DynaLoader;
158 push @ISA, 'DynaLoader';
159 bootstrap Imager $VERSION;
160 }
02d1d628
AMH		 161}
162
1d7e3124
TC		 163my %formats_low;
164my %format_classes =
165 (
166 png => "Imager::File::PNG",
167 gif => "Imager::File::GIF",
168 tiff => "Imager::File::TIFF",
169 jpeg => "Imager::File::JPEG",
718b8c97 170 w32 => "Imager::Font::W32",
50c75381 171 ft2 => "Imager::Font::FT2",
a556912d 172 t1 => "Imager::Font::T1",
1d7e3124
TC		 173 );
174
175tie %formats, "Imager::FORMATS", \%formats_low, \%format_classes;
176
02d1d628 177BEGIN {
1d7e3124 178 for(i_list_formats()) { $formats_low{$_}++; }
02d1d628 179
02d1d628
AMH		 180 %OPCODES=(Add=>[0],Sub=>[1],Mult=>[2],Div=>[3],Parm=>[4],'sin'=>[5],'cos'=>[6],'x'=>[4,0],'y'=>[4,1]);
181
182 $DEBUG=0;
183
6607600c
TC		 184 # the members of the subhashes under %filters are:
185 # callseq - a list of the parameters to the underlying filter in the
186 # order they are passed
187 # callsub - a code ref that takes a named parameter list and calls the
188 # underlying filter
189 # defaults - a hash of default values
190 # names - defines names for value of given parameters so if the names
191 # field is foo=> { bar=>1 }, and the user supplies "bar" as the
192 # foo parameter, the filter will receive 1 for the foo
193 # parameter
02d1d628
AMH		 194 $filters{contrast}={
195 callseq => ['image','intensity'],
196 callsub => sub { my %hsh=@_; i_contrast($hsh{image},$hsh{intensity}); }
197 };
198
199 $filters{noise} ={
200 callseq => ['image', 'amount', 'subtype'],
201 defaults => { amount=>3,subtype=>0 },
202 callsub => sub { my %hsh=@_; i_noise($hsh{image},$hsh{amount},$hsh{subtype}); }
203 };
204
205 $filters{hardinvert} ={
206 callseq => ['image'],
207 defaults => { },
208 callsub => sub { my %hsh=@_; i_hardinvert($hsh{image}); }
209 };
210
5558f899
TC		 211 $filters{hardinvertall} =
212 {
213 callseq => ['image'],
214 defaults => { },
215 callsub => sub { my %hsh=@_; i_hardinvertall($hsh{image}); }
216 };
217
02d1d628
AMH		 218 $filters{autolevels} ={
219 callseq => ['image','lsat','usat','skew'],
220 defaults => { lsat=>0.1,usat=>0.1,skew=>0.0 },
221 callsub => sub { my %hsh=@_; i_autolevels($hsh{image},$hsh{lsat},$hsh{usat},$hsh{skew}); }
222 };
223
224 $filters{turbnoise} ={
225 callseq => ['image'],
226 defaults => { xo=>0.0,yo=>0.0,scale=>10.0 },
227 callsub => sub { my %hsh=@_; i_turbnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{scale}); }
228 };
229
230 $filters{radnoise} ={
231 callseq => ['image'],
232 defaults => { xo=>100,yo=>100,ascale=>17.0,rscale=>0.02 },
233 callsub => sub { my %hsh=@_; i_radnoise($hsh{image},$hsh{xo},$hsh{yo},$hsh{rscale},$hsh{ascale}); }
234 };
235
6a3cbaef
TC		 236 $filters{conv} =
237 {
238 callseq => ['image', 'coef'],
239 defaults => { },
240 callsub =>
241 sub {
242 my %hsh=@_;
243 i_conv($hsh{image},$hsh{coef})
244 or die Imager->_error_as_msg() . "\n";
245 }
246 };
02d1d628 247
f0ddaffd
TC		 248 $filters{gradgen} =
249 {
250 callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
251 defaults => { dist => 0 },
252 callsub =>
253 sub {
254 my %hsh=@_;
255 my @colors = @{$hsh{colors}};
256 $_ = _color($_)
257 for @colors;
258 i_gradgen($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors, $hsh{dist});
259 }
260 };
02d1d628 261
e310e5f9
TC		 262 $filters{nearest_color} =
263 {
264 callseq => ['image', 'xo', 'yo', 'colors', 'dist'],
265 defaults => { },
266 callsub =>
267 sub {
268 my %hsh=@_;
269 # make sure the segments are specified with colors
270 my @colors;
271 for my $color (@{$hsh{colors}}) {
272 my $new_color = _color($color)
273 or die $Imager::ERRSTR."\n";
274 push @colors, $new_color;
275 }
276
277 i_nearest_color($hsh{image}, $hsh{xo}, $hsh{yo}, \@colors,
278 $hsh{dist})
279 or die Imager->_error_as_msg() . "\n";
280 },
281 };
faa9b3e7
TC		 282 $filters{gaussian} = {
283 callseq => [ 'image', 'stddev' ],
284 defaults => { },
285 callsub => sub { my %hsh = @_; i_gaussian($hsh{image}, $hsh{stddev}); },
286 };
d08b8f85
TC		 287 $filters{mosaic} =
288 {
289 callseq => [ qw(image size) ],
290 defaults => { size => 20 },
291 callsub => sub { my %hsh = @_; i_mosaic($hsh{image}, $hsh{size}) },
292 };
293 $filters{bumpmap} =
294 {
295 callseq => [ qw(image bump elevation lightx lighty st) ],
296 defaults => { elevation=>0, st=> 2 },
b2778574 297 callsub => sub {
d08b8f85
TC		 298 my %hsh = @_;
299 i_bumpmap($hsh{image}, $hsh{bump}{IMG}, $hsh{elevation},
300 $hsh{lightx}, $hsh{lighty}, $hsh{st});
301 },
302 };
b2778574
AMH		 303 $filters{bumpmap_complex} =
304 {
305 callseq => [ qw(image bump channel tx ty Lx Ly Lz cd cs n Ia Il Is) ],
306 defaults => {
307 channel => 0,
308 tx => 0,
309 ty => 0,
310 Lx => 0.2,
311 Ly => 0.4,
312 Lz => -1.0,
313 cd => 1.0,
314 cs => 40,
315 n => 1.3,
ffddd407
TC		 316 Ia => [0,0,0],
317 Il => [255,255,255],
318 Is => [255,255,255],
b2778574
AMH		 319 },
320 callsub => sub {
321 my %hsh = @_;
ffddd407
TC		 322 for my $cname (qw/Ia Il Is/) {
323 my $old = $hsh{$cname};
324 my $new_color = _color($old)
325 or die $Imager::ERRSTR, "\n";
326 $hsh{$cname} = $new_color;
327 }
b2778574
AMH		 328 i_bumpmap_complex($hsh{image}, $hsh{bump}{IMG}, $hsh{channel},
329 $hsh{tx}, $hsh{ty}, $hsh{Lx}, $hsh{Ly}, $hsh{Lz},
330 $hsh{cd}, $hsh{cs}, $hsh{n}, $hsh{Ia}, $hsh{Il},
331 $hsh{Is});
332 },
333 };
d08b8f85
TC		 334 $filters{postlevels} =
335 {
336 callseq => [ qw(image levels) ],
337 defaults => { levels => 10 },
338 callsub => sub { my %hsh = @_; i_postlevels($hsh{image}, $hsh{levels}); },
339 };
340 $filters{watermark} =
341 {
342 callseq => [ qw(image wmark tx ty pixdiff) ],
343 defaults => { pixdiff=>10, tx=>0, ty=>0 },
344 callsub =>
345 sub {
346 my %hsh = @_;
347 i_watermark($hsh{image}, $hsh{wmark}{IMG}, $hsh{tx}, $hsh{ty},
348 $hsh{pixdiff});
349 },
350 };
6607600c
TC		 351 $filters{fountain} =
352 {
353 callseq => [ qw(image xa ya xb yb ftype repeat combine super_sample ssample_param segments) ],
354 names => {
355 ftype => { linear => 0,
356 bilinear => 1,
357 radial => 2,
358 radial_square => 3,
359 revolution => 4,
360 conical => 5 },
361 repeat => { none => 0,
362 sawtooth => 1,
363 triangle => 2,
364 saw_both => 3,
365 tri_both => 4,
366 },
367 super_sample => {
368 none => 0,
369 grid => 1,
370 random => 2,
371 circle => 3,
372 },
efdc2568
TC		 373 combine => {
374 none => 0,
375 normal => 1,
376 multiply => 2, mult => 2,
377 dissolve => 3,
378 add => 4,
9d540150 379 subtract => 5, 'sub' => 5,
efdc2568
TC		 380 diff => 6,
381 lighten => 7,
382 darken => 8,
383 hue => 9,
384 sat => 10,
385 value => 11,
386 color => 12,
387 },
6607600c
TC		 388 },
389 defaults => { ftype => 0, repeat => 0, combine => 0,
390 super_sample => 0, ssample_param => 4,
391 segments=>[
392 [ 0, 0.5, 1,
ffddd407
TC		 393 [0,0,0],
394 [255, 255, 255],
6607600c
TC		 395 0, 0,
396 ],
397 ],
398 },
399 callsub =>
400 sub {
401 my %hsh = @_;
109bec2d
TC		 402
403 # make sure the segments are specified with colors
404 my @segments;
405 for my $segment (@{$hsh{segments}}) {
406 my @new_segment = @$segment;
407
408 $_ = _color($_) or die $Imager::ERRSTR."\n" for @new_segment[3,4];
409 push @segments, \@new_segment;
410 }
411
6607600c
TC		 412 i_fountain($hsh{image}, $hsh{xa}, $hsh{ya}, $hsh{xb}, $hsh{yb},
413 $hsh{ftype}, $hsh{repeat}, $hsh{combine}, $hsh{super_sample},
e310e5f9
TC		 414 $hsh{ssample_param}, \@segments)
415 or die Imager->_error_as_msg() . "\n";
6607600c
TC		 416 },
417 };
b6381851
TC		 418 $filters{unsharpmask} =
419 {
420 callseq => [ qw(image stddev scale) ],
421 defaults => { stddev=>2.0, scale=>1.0 },
422 callsub =>
423 sub {
424 my %hsh = @_;
425 i_unsharp_mask($hsh{image}, $hsh{stddev}, $hsh{scale});
426 },
427 };
02d1d628
AMH		 428
429 $FORMATGUESS=\&def_guess_type;
97c4effc
TC		 430
431 $warn_obsolete = 1;
02d1d628
AMH		 432}
433
434#
435# Non methods
436#
437
438# initlize Imager
439# NOTE: this might be moved to an import override later on
440
bd8052a6
TC		 441sub import {
442 my $i = 1;
443 while ($i < @_) {
444 if ($_[$i] eq '-log-stderr') {
445 init_log(undef, 4);
446 splice(@_, $i, 1);
447 }
448 else {
449 ++$i;
450 }
451 }
452 goto &Exporter::import;
453}
02d1d628 454
f83bf98a 455sub init_log {
10ea52a3 456 Imager->open_log(log => $_[0], level => $_[1]);
f83bf98a
AMH		 457}
458
459
02d1d628
AMH		 460sub init {
461 my %parms=(loglevel=>1,@_);
462 if ($parms{'log'}) {
10ea52a3 463 Imager->open_log(log => $parms{log}, level => $parms{loglevel});
02d1d628 464 }
f83bf98a 465
97c4effc
TC		 466 if (exists $parms{'warn_obsolete'}) {
467 $warn_obsolete = $parms{'warn_obsolete'};
468 }
02d1d628 469
4cb58f1b 470 if (exists $parms{'t1log'}) {
a556912d
TC		 471 if ($formats{t1}) {
472 Imager::Font::T1::i_init_t1($parms{'t1log'});
473 }
4cb58f1b 474 }
02d1d628
AMH		 475}
476
10ea52a3
TC		 477{
478 my $is_logging = 0;
479
480 sub open_log {
481 my $class = shift;
482 my (%opts) = ( loglevel => 1, @_ );
483
484 $is_logging = i_init_log($opts{log}, $opts{loglevel});
485 unless ($is_logging) {
486 Imager->_set_error(Imager->_error_as_msg());
487 return;
488 }
489
490 Imager->log("Imager $VERSION starting\n", 1);
491
492 return $is_logging;
493 }
494
495 sub close_log {
496 i_init_log(undef, -1);
497 $is_logging = 0;
498 }
499
500 sub log {
501 my ($class, $message, $level) = @_;
502
503 defined $level or $level = 1;
504
505 i_log_entry($message, $level);
506 }
507
508 sub is_logging {
509 return $is_logging;
510 }
511}
512
02d1d628
AMH		 513END {
514 if ($DEBUG) {
515 print "shutdown code\n";
516 # for(keys %instances) { $instances{$_}->DESTROY(); }
517 malloc_state(); # how do decide if this should be used? -- store something from the import
518 print "Imager exiting\n";
519 }
520}
521
522# Load a filter plugin
523
524sub load_plugin {
525 my ($filename)=@_;
526 my $i;
527 my ($DSO_handle,$str)=DSO_open($filename);
528 if (!defined($DSO_handle)) { $Imager::ERRSTR="Couldn't load plugin '$filename'\n"; return undef; }
529 my %funcs=DSO_funclist($DSO_handle);
530 if ($DEBUG) { print "loading module $filename\n"; $i=0; for(keys %funcs) { printf(" %2d: %s\n",$i++,$_); } }
531 $i=0;
532 for(keys %funcs) { if ($filters{$_}) { $ERRSTR="filter '$_' already exists\n"; DSO_close($DSO_handle); return undef; } }
533
534 $DSOs{$filename}=[$DSO_handle,\%funcs];
535
536 for(keys %funcs) {
537 my $evstr="\$filters{'".$_."'}={".$funcs{$_}.'};';
538 $DEBUG && print "eval string:\n",$evstr,"\n";
539 eval $evstr;
540 print $@ if $@;
541 }
542 return 1;
543}
544
545# Unload a plugin
546
547sub unload_plugin {
548 my ($filename)=@_;
549
550 if (!$DSOs{$filename}) { $ERRSTR="plugin '$filename' not loaded."; return undef; }
551 my ($DSO_handle,$funcref)=@{$DSOs{$filename}};
552 for(keys %{$funcref}) {
553 delete $filters{$_};
554 $DEBUG && print "unloading: $_\n";
555 }
556 my $rc=DSO_close($DSO_handle);
557 if (!defined($rc)) { $ERRSTR="unable to unload plugin '$filename'."; return undef; }
558 return 1;
559}
560
64606cc7
TC		 561# take the results of i_error() and make a message out of it
562sub _error_as_msg {
563 return join(": ", map $_->[0], i_errors());
564}
565
3a9a4241
TC		 566# this function tries to DWIM for color parameters
567# color objects are used as is
568# simple scalars are simply treated as single parameters to Imager::Color->new
569# hashrefs are treated as named argument lists to Imager::Color->new
570# arrayrefs are treated as list arguments to Imager::Color->new iff any
571# parameter is > 1
572# other arrayrefs are treated as list arguments to Imager::Color::Float
573
574sub _color {
575 my $arg = shift;
b6cfd214
TC		 576 # perl 5.6.0 seems to do weird things to $arg if we don't make an
577 # explicitly stringified copy
578 # I vaguely remember a bug on this on p5p, but couldn't find it
579 # through bugs.perl.org (I had trouble getting it to find any bugs)
580 my $copy = $arg . "";
3a9a4241
TC		 581 my $result;
582
583 if (ref $arg) {
584 if (UNIVERSAL::isa($arg, "Imager::Color")
585 || UNIVERSAL::isa($arg, "Imager::Color::Float")) {
586 $result = $arg;
587 }
588 else {
b6cfd214 589 if ($copy =~ /^HASH\(/) {
3a9a4241
TC		 590 $result = Imager::Color->new(%$arg);
591 }
b6cfd214 592 elsif ($copy =~ /^ARRAY\(/) {
5daa8f70 593 $result = Imager::Color->new(@$arg);
3a9a4241
TC		 594 }
595 else {
596 $Imager::ERRSTR = "Not a color";
597 }
598 }
599 }
600 else {
601 # assume Imager::Color::new knows how to handle it
602 $result = Imager::Color->new($arg);
603 }
604
605 return $result;
606}
607
9b1ec2b8
TC		 608sub _combine {
609 my ($self, $combine, $default) = @_;
610
611 if (!defined $combine && ref $self) {
612 $combine = $self->{combine};
613 }
614 defined $combine or $combine = $defaults{combine};
615 defined $combine or $combine = $default;
616
617 if (exists $combine_types{$combine}) {
618 $combine = $combine_types{$combine};
619 }
620
621 return $combine;
622}
623
4cda4e76
TC		 624sub _valid_image {
625 my ($self) = @_;
626
627 $self->{IMG} and return 1;
628
629 $self->_set_error('empty input image');
630
631 return;
632}
3a9a4241 633
500888da
TC		 634# returns first defined parameter
635sub _first {
636 for (@_) {
637 return $_ if defined $_;
638 }
639 return undef;
640}
641
02d1d628
AMH		 642#
643# Methods to be called on objects.
644#
645
646# Create a new Imager object takes very few parameters.
647# usually you call this method and then call open from
648# the resulting object
649
650sub new {
651 my $class = shift;
652 my $self ={};
653 my %hsh=@_;
654 bless $self,$class;
655 $self->{IMG}=undef; # Just to indicate what exists
656 $self->{ERRSTR}=undef; #
657 $self->{DEBUG}=$DEBUG;
3c252111
TC		 658 $self->{DEBUG} and print "Initialized Imager\n";
659 if (defined $hsh{xsize} || defined $hsh{ysize}) {
1501d9b3
TC		 660 unless ($self->img_set(%hsh)) {
661 $Imager::ERRSTR = $self->{ERRSTR};
662 return;
663 }
664 }
3c252111
TC		 665 elsif (defined $hsh{file} ||
666 defined $hsh{fh} ||
667 defined $hsh{fd} ||
668 defined $hsh{callback} ||
75812841
TC		 669 defined $hsh{readcb} ||
670 defined $hsh{data}) {
3c252111
TC		 671 # allow $img = Imager->new(file => $filename)
672 my %extras;
673
674 # type is already used as a parameter to new(), rename it for the
675 # call to read()
676 if ($hsh{filetype}) {
677 $extras{type} = $hsh{filetype};
678 }
679 unless ($self->read(%hsh, %extras)) {
680 $Imager::ERRSTR = $self->{ERRSTR};
681 return;
682 }
683 }
684
02d1d628
AMH		 685 return $self;
686}
687
02d1d628
AMH		 688# Copy an entire image with no changes
689# - if an image has magic the copy of it will not be magical
690
691sub copy {
692 my $self = shift;
693 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
694
34b3f7e6
TC		 695 unless (defined wantarray) {
696 my @caller = caller;
697 warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
698 return;
699 }
700
02d1d628 701 my $newcopy=Imager->new();
92bda632 702 $newcopy->{IMG} = i_copy($self->{IMG});
02d1d628
AMH		 703 return $newcopy;
704}
705
706# Paste a region
707
708sub paste {
709 my $self = shift;
92bda632
TC		 710
711 unless ($self->{IMG}) {
712 $self->_set_error('empty input image');
713 return;
714 }
715 my %input=(left=>0, top=>0, src_minx => 0, src_miny => 0, @_);
716 my $src = $input{img} || $input{src};
717 unless($src) {
718 $self->_set_error("no source image");
02d1d628
AMH		 719 return;
720 }
721 $input{left}=0 if $input{left} <= 0;
722 $input{top}=0 if $input{top} <= 0;
92bda632 723
02d1d628 724 my($r,$b)=i_img_info($src->{IMG});
92bda632
TC		 725 my ($src_left, $src_top) = @input{qw/src_minx src_miny/};
726 my ($src_right, $src_bottom);
727 if ($input{src_coords}) {
728 ($src_left, $src_top, $src_right, $src_bottom) = @{$input{src_coords}}
729 }
730 else {
731 if (defined $input{src_maxx}) {
732 $src_right = $input{src_maxx};
733 }
734 elsif (defined $input{width}) {
735 if ($input{width} <= 0) {
736 $self->_set_error("paste: width must me positive");
737 return;
738 }
739 $src_right = $src_left + $input{width};
740 }
741 else {
742 $src_right = $r;
743 }
35029411 744 if (defined $input{src_maxy}) {
92bda632
TC		 745 $src_bottom = $input{src_maxy};
746 }
747 elsif (defined $input{height}) {
748 if ($input{height} < 0) {
749 $self->_set_error("paste: height must be positive");
750 return;
751 }
752 $src_bottom = $src_top + $input{height};
753 }
754 else {
755 $src_bottom = $b;
756 }
757 }
758
759 $src_right > $r and $src_right = $r;
35029411 760 $src_bottom > $b and $src_bottom = $b;
92bda632
TC		 761
762 if ($src_right <= $src_left
763 || $src_bottom < $src_top) {
764 $self->_set_error("nothing to paste");
765 return;
766 }
02d1d628
AMH		 767
768 i_copyto($self->{IMG}, $src->{IMG},
92bda632
TC		 769 $src_left, $src_top, $src_right, $src_bottom,
770 $input{left}, $input{top});
771
02d1d628
AMH		 772 return $self; # What should go here??
773}
774
775# Crop an image - i.e. return a new image that is smaller
776
777sub crop {
778 my $self=shift;
779 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
676d5bb5 780
34b3f7e6
TC		 781 unless (defined wantarray) {
782 my @caller = caller;
783 warn "crop() called in void context - crop() returns the cropped image at $caller[1] line $caller[2]\n";
784 return;
785 }
786
676d5bb5 787 my %hsh=@_;
299a3866 788
676d5bb5
TC		 789 my ($w, $h, $l, $r, $b, $t) =
790 @hsh{qw(width height left right bottom top)};
299a3866 791
676d5bb5
TC		 792 # work through the various possibilities
793 if (defined $l) {
794 if (defined $w) {
795 $r = $l + $w;
796 }
797 elsif (!defined $r) {
798 $r = $self->getwidth;
799 }
800 }
801 elsif (defined $r) {
802 if (defined $w) {
803 $l = $r - $w;
804 }
805 else {
806 $l = 0;
807 }
808 }
809 elsif (defined $w) {
810 $l = int(0.5+($self->getwidth()-$w)/2);
811 $r = $l + $w;
812 }
813 else {
814 $l = 0;
815 $r = $self->getwidth;
816 }
817 if (defined $t) {
818 if (defined $h) {
819 $b = $t + $h;
820 }
821 elsif (!defined $b) {
822 $b = $self->getheight;
823 }
824 }
825 elsif (defined $b) {
826 if (defined $h) {
827 $t = $b - $h;
828 }
829 else {
830 $t = 0;
831 }
832 }
833 elsif (defined $h) {
834 $t=int(0.5+($self->getheight()-$h)/2);
835 $b=$t+$h;
836 }
837 else {
838 $t = 0;
839 $b = $self->getheight;
840 }
02d1d628
AMH		 841
842 ($l,$r)=($r,$l) if $l>$r;
843 ($t,$b)=($b,$t) if $t>$b;
844
676d5bb5
TC		 845 $l < 0 and $l = 0;
846 $r > $self->getwidth and $r = $self->getwidth;
847 $t < 0 and $t = 0;
848 $b > $self->getheight and $b = $self->getheight;
02d1d628 849
676d5bb5
TC		 850 if ($l == $r || $t == $b) {
851 $self->_set_error("resulting image would have no content");
852 return;
853 }
9fc9d0ca
TC		 854 if( $r < $l or $b < $t ) {
855 $self->_set_error("attempting to crop outside of the image");
856 return;
857 }
676d5bb5 858 my $dst = $self->_sametype(xsize=>$r-$l, ysize=>$b-$t);
02d1d628
AMH		 859
860 i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
861 return $dst;
862}
863
ec76939c
TC		 864sub _sametype {
865 my ($self, %opts) = @_;
866
867 $self->{IMG} or return $self->_set_error("Not a valid image");
868
869 my $x = $opts{xsize} || $self->getwidth;
870 my $y = $opts{ysize} || $self->getheight;
871 my $channels = $opts{channels} || $self->getchannels;
872
873 my $out = Imager->new;
874 if ($channels == $self->getchannels) {
875 $out->{IMG} = i_sametype($self->{IMG}, $x, $y);
876 }
877 else {
878 $out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
879 }
880 unless ($out->{IMG}) {
881 $self->{ERRSTR} = $self->_error_as_msg;
882 return;
883 }
884
885 return $out;
886}
887
02d1d628
AMH		 888# Sets an image to a certain size and channel number
889# if there was previously data in the image it is discarded
890
891sub img_set {
892 my $self=shift;
893
faa9b3e7 894 my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
02d1d628
AMH		 895
896 if (defined($self->{IMG})) {
faa9b3e7
TC		 897 # let IIM_DESTROY destroy it, it's possible this image is
898 # referenced from a virtual image (like masked)
899 #i_img_destroy($self->{IMG});
02d1d628
AMH		 900 undef($self->{IMG});
901 }
902
faa9b3e7
TC		 903 if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
904 $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
905 $hsh{maxcolors} || 256);
906 }
365ea842
TC		 907 elsif ($hsh{bits} eq 'double') {
908 $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
909 }
faa9b3e7
TC		 910 elsif ($hsh{bits} == 16) {
911 $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
912 }
913 else {
914 $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'},
915 $hsh{'channels'});
916 }
1501d9b3
TC		 917
918 unless ($self->{IMG}) {
919 $self->{ERRSTR} = Imager->_error_as_msg();
920 return;
921 }
922
923 $self;
faa9b3e7
TC		 924}
925
926# created a masked version of the current image
927sub masked {
928 my $self = shift;
929
930 $self or return undef;
931 my %opts = (left => 0,
932 top => 0,
933 right => $self->getwidth,
934 bottom => $self->getheight,
935 @_);
936 my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
937
938 my $result = Imager->new;
939 $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left},
940 $opts{top}, $opts{right} - $opts{left},
941 $opts{bottom} - $opts{top});
416e9814
TC		 942 unless ($result->{IMG}) {
943 $self->_set_error(Imager->_error_as_msg);
944 return;
945 }
946
faa9b3e7
TC		 947 # keep references to the mask and base images so they don't
948 # disappear on us
949 $result->{DEPENDS} = [ $self->{IMG}, $mask ];
950
416e9814 951 return $result;
faa9b3e7
TC		 952}
953
954# convert an RGB image into a paletted image
955sub to_paletted {
956 my $self = shift;
957 my $opts;
958 if (@_ != 1 && !ref $_[0]) {
959 $opts = { @_ };
960 }
961 else {
962 $opts = shift;
963 }
964
34b3f7e6
TC		 965 unless (defined wantarray) {
966 my @caller = caller;
967 warn "to_paletted() called in void context - to_paletted() returns the converted image at $caller[1] line $caller[2]\n";
968 return;
969 }
970
3bcba6df
TC		 971 $self->_valid_image
972 or return;
faa9b3e7 973
3bcba6df
TC		 974 my $result = Imager->new;
975 unless ($result->{IMG} = i_img_to_pal($self->{IMG}, $opts)) {
976 $self->_set_error(Imager->_error_as_msg);
1501d9b3
TC		 977 return;
978 }
3bcba6df
TC		 979
980 return $result;
faa9b3e7
TC		 981}
982
3bcba6df 983# convert a paletted (or any image) to an 8-bit/channel RGB image
faa9b3e7
TC		 984sub to_rgb8 {
985 my $self = shift;
faa9b3e7 986
34b3f7e6
TC		 987 unless (defined wantarray) {
988 my @caller = caller;
b13bf7e8 989 warn "to_rgb8() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
34b3f7e6
TC		 990 return;
991 }
992
3bcba6df
TC		 993 $self->_valid_image
994 or return;
995
996 my $result = Imager->new;
997 unless ($result->{IMG} = i_img_to_rgb($self->{IMG})) {
998 $self->_set_error(Imager->_error_as_msg());
999 return;
faa9b3e7
TC		 1000 }
1001
1002 return $result;
1003}
1004
3bcba6df 1005# convert a paletted (or any image) to a 16-bit/channel RGB image
837a4b43
TC		 1006sub to_rgb16 {
1007 my $self = shift;
837a4b43
TC		 1008
1009 unless (defined wantarray) {
1010 my @caller = caller;
3bcba6df 1011 warn "to_rgb16() called in void context - to_rgb16() returns the converted image at $caller[1] line $caller[2]\n";
837a4b43
TC		 1012 return;
1013 }
1014
3bcba6df
TC		 1015 $self->_valid_image
1016 or return;
1017
1018 my $result = Imager->new;
1019 unless ($result->{IMG} = i_img_to_rgb16($self->{IMG})) {
1020 $self->_set_error(Imager->_error_as_msg());
1021 return;
837a4b43
TC		 1022 }
1023
1024 return $result;
1025}
1026
bfe6ba3f
TC		 1027# convert a paletted (or any image) to an double/channel RGB image
1028sub to_rgb_double {
1029 my $self = shift;
1030
1031 unless (defined wantarray) {
1032 my @caller = caller;
1033 warn "to_rgb16() called in void context - to_rgb_double() returns the converted image at $caller[1] line $caller[2]\n";
1034 return;
1035 }
1036
1037 $self->_valid_image
1038 or return;
1039
1040 my $result = Imager->new;
1041 unless ($result->{IMG} = i_img_to_drgb($self->{IMG})) {
1042 $self->_set_error(Imager->_error_as_msg());
1043 return;
1044 }
1045
1046 return $result;
1047}
1048
faa9b3e7
TC		 1049sub addcolors {
1050 my $self = shift;
1051 my %opts = (colors=>[], @_);
1052
32b97571
TC		 1053 unless ($self->{IMG}) {
1054 $self->_set_error("empty input image");
1055 return;
1056 }
1057
1058 my @colors = @{$opts{colors}}
1059 or return undef;
faa9b3e7 1060
32b97571
TC		 1061 for my $color (@colors) {
1062 $color = _color($color);
1063 unless ($color) {
1064 $self->_set_error($Imager::ERRSTR);
1065 return;
1066 }
1067 }
1068
1069 return i_addcolors($self->{IMG}, @colors);
faa9b3e7
TC		 1070}
1071
1072sub setcolors {
1073 my $self = shift;
1074 my %opts = (start=>0, colors=>[], @_);
faa9b3e7 1075
32b97571
TC		 1076 unless ($self->{IMG}) {
1077 $self->_set_error("empty input image");
1078 return;
1079 }
1080
1081 my @colors = @{$opts{colors}}
1082 or return undef;
1083
1084 for my $color (@colors) {
1085 $color = _color($color);
1086 unless ($color) {
1087 $self->_set_error($Imager::ERRSTR);
1088 return;
1089 }
1090 }
1091
1092 return i_setcolors($self->{IMG}, $opts{start}, @colors);
faa9b3e7
TC		 1093}
1094
1095sub getcolors {
1096 my $self = shift;
1097 my %opts = @_;
1098 if (!exists $opts{start} && !exists $opts{count}) {
1099 # get them all
1100 $opts{start} = 0;
1101 $opts{count} = $self->colorcount;
1102 }
1103 elsif (!exists $opts{count}) {
1104 $opts{count} = 1;
1105 }
1106 elsif (!exists $opts{start}) {
1107 $opts{start} = 0;
1108 }
1109
1110 $self->{IMG} and
1111 return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
1112}
1113
1114sub colorcount {
1115 i_colorcount($_[0]{IMG});
1116}
1117
1118sub maxcolors {
1119 i_maxcolors($_[0]{IMG});
1120}
1121
1122sub findcolor {
1123 my $self = shift;
1124 my %opts = @_;
1125 $opts{color} or return undef;
1126
1127 $self->{IMG} and i_findcolor($self->{IMG}, $opts{color});
1128}
1129
1130sub bits {
1131 my $self = shift;
af3c2450
TC		 1132 my $bits = $self->{IMG} && i_img_bits($self->{IMG});
1133 if ($bits && $bits == length(pack("d", 1)) * 8) {
1134 $bits = 'double';
1135 }
1136 $bits;
faa9b3e7
TC		 1137}
1138
1139sub type {
1140 my $self = shift;
1141 if ($self->{IMG}) {
1142 return i_img_type($self->{IMG}) ? "paletted" : "direct";
1143 }
1144}
1145
1146sub virtual {
1147 my $self = shift;
1148 $self->{IMG} and i_img_virtual($self->{IMG});
1149}
1150
bd8052a6
TC		 1151sub is_bilevel {
1152 my ($self) = @_;
1153
1154 $self->{IMG} or return;
1155
1156 return i_img_is_monochrome($self->{IMG});
1157}
1158
faa9b3e7
TC		 1159sub tags {
1160 my ($self, %opts) = @_;
1161
1162 $self->{IMG} or return;
1163
1164 if (defined $opts{name}) {
1165 my @result;
1166 my $start = 0;
1167 my $found;
1168 while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
1169 push @result, (i_tags_get($self->{IMG}, $found))[1];
1170 $start = $found+1;
1171 }
1172 return wantarray ? @result : $result[0];
1173 }
1174 elsif (defined $opts{code}) {
1175 my @result;
1176 my $start = 0;
1177 my $found;
1178 while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
1179 push @result, (i_tags_get($self->{IMG}, $found))[1];
1180 $start = $found+1;
1181 }
1182 return @result;
1183 }
1184 else {
1185 if (wantarray) {
1186 return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
1187 }
1188 else {
1189 return i_tags_count($self->{IMG});
1190 }
1191 }
1192}
1193
1194sub addtag {
1195 my $self = shift;
1196 my %opts = @_;
1197
1198 return -1 unless $self->{IMG};
1199 if ($opts{name}) {
1200 if (defined $opts{value}) {
1201 if ($opts{value} =~ /^\d+$/) {
1202 # add as a number
1203 return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
1204 }
1205 else {
1206 return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
1207 }
1208 }
1209 elsif (defined $opts{data}) {
1210 # force addition as a string
1211 return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
1212 }
1213 else {
1214 $self->{ERRSTR} = "No value supplied";
1215 return undef;
1216 }
1217 }
1218 elsif ($opts{code}) {
1219 if (defined $opts{value}) {
1220 if ($opts{value} =~ /^\d+$/) {
1221 # add as a number
1222 return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
1223 }
1224 else {
1225 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
1226 }
1227 }
1228 elsif (defined $opts{data}) {
1229 # force addition as a string
1230 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
1231 }
1232 else {
1233 $self->{ERRSTR} = "No value supplied";
1234 return undef;
1235 }
1236 }
1237 else {
1238 return undef;
1239 }
1240}
1241
1242sub deltag {
1243 my $self = shift;
1244 my %opts = @_;
1245
1246 return 0 unless $self->{IMG};
1247
9d540150
TC		 1248 if (defined $opts{'index'}) {
1249 return i_tags_delete($self->{IMG}, $opts{'index'});
faa9b3e7
TC		 1250 }
1251 elsif (defined $opts{name}) {
1252 return i_tags_delbyname($self->{IMG}, $opts{name});
1253 }
1254 elsif (defined $opts{code}) {
1255 return i_tags_delbycode($self->{IMG}, $opts{code});
1256 }
1257 else {
1258 $self->{ERRSTR} = "Need to supply index, name, or code parameter";
1259 return 0;
1260 }
02d1d628
AMH		 1261}
1262
97c4effc
TC		 1263sub settag {
1264 my ($self, %opts) = @_;
1265
1266 if ($opts{name}) {
1267 $self->deltag(name=>$opts{name});
1268 return $self->addtag(name=>$opts{name}, value=>$opts{value});
1269 }
1270 elsif (defined $opts{code}) {
1271 $self->deltag(code=>$opts{code});
1272 return $self->addtag(code=>$opts{code}, value=>$opts{value});
1273 }
1274 else {
1275 return undef;
1276 }
1277}
1278
10461f9a
TC		 1279
1280sub _get_reader_io {
84e51293 1281 my ($self, $input) = @_;
10461f9a 1282
e7ff1cf7
TC		 1283 if ($input->{io}) {
1284 return $input->{io}, undef;
1285 }
84e51293 1286 elsif ($input->{fd}) {
10461f9a
TC		 1287 return io_new_fd($input->{fd});
1288 }
1289 elsif ($input->{fh}) {
1290 my $fd = fileno($input->{fh});
de470892 1291 unless (defined $fd) {
10461f9a
TC		 1292 $self->_set_error("Handle in fh option not opened");
1293 return;
1294 }
1295 return io_new_fd($fd);
1296 }
1297 elsif ($input->{file}) {
1298 my $file = IO::File->new($input->{file}, "r");
1299 unless ($file) {
1300 $self->_set_error("Could not open $input->{file}: $!");
1301 return;
1302 }
1303 binmode $file;
1304 return (io_new_fd(fileno($file)), $file);
1305 }
1306 elsif ($input->{data}) {
1307 return io_new_buffer($input->{data});
1308 }
1309 elsif ($input->{callback} || $input->{readcb}) {
84e51293
AMH		 1310 if (!$input->{seekcb}) {
1311 $self->_set_error("Need a seekcb parameter");
10461f9a
TC		 1312 }
1313 if ($input->{maxbuffer}) {
1314 return io_new_cb($input->{writecb},
1315 $input->{callback} || $input->{readcb},
1316 $input->{seekcb}, $input->{closecb},
1317 $input->{maxbuffer});
1318 }
1319 else {
1320 return io_new_cb($input->{writecb},
1321 $input->{callback} || $input->{readcb},
1322 $input->{seekcb}, $input->{closecb});
1323 }
1324 }
1325 else {
1326 $self->_set_error("file/fd/fh/data/callback parameter missing");
1327 return;
1328 }
1329}
1330
1331sub _get_writer_io {
5970bd39 1332 my ($self, $input) = @_;
10461f9a 1333
e7ff1cf7
TC		 1334 if ($input->{io}) {
1335 return $input->{io};
1336 }
1337 elsif ($input->{fd}) {
10461f9a
TC		 1338 return io_new_fd($input->{fd});
1339 }
1340 elsif ($input->{fh}) {
1341 my $fd = fileno($input->{fh});
de470892 1342 unless (defined $fd) {
10461f9a
TC		 1343 $self->_set_error("Handle in fh option not opened");
1344 return;
1345 }
9d1c4956
TC		 1346 # flush it
1347 my $oldfh = select($input->{fh});
1348 # flush anything that's buffered, and make sure anything else is flushed
1349 $| = 1;
1350 select($oldfh);
10461f9a
TC		 1351 return io_new_fd($fd);
1352 }
1353 elsif ($input->{file}) {
1354 my $fh = new IO::File($input->{file},"w+");
1355 unless ($fh) {
1356 $self->_set_error("Could not open file $input->{file}: $!");
1357 return;
1358 }
1359 binmode($fh) or die;
1360 return (io_new_fd(fileno($fh)), $fh);
1361 }
1362 elsif ($input->{data}) {
1363 return io_new_bufchain();
1364 }
1365 elsif ($input->{callback} || $input->{writecb}) {
1366 if ($input->{maxbuffer}) {
1367 return io_new_cb($input->{callback} || $input->{writecb},
1368 $input->{readcb},
1369 $input->{seekcb}, $input->{closecb},
1370 $input->{maxbuffer});
1371 }
1372 else {
1373 return io_new_cb($input->{callback} || $input->{writecb},
1374 $input->{readcb},
1375 $input->{seekcb}, $input->{closecb});
1376 }
1377 }
1378 else {
1379 $self->_set_error("file/fd/fh/data/callback parameter missing");
1380 return;
1381 }
1382}
1383
02d1d628
AMH		 1384# Read an image from file
1385
1386sub read {
1387 my $self = shift;
1388 my %input=@_;
02d1d628
AMH		 1389
1390 if (defined($self->{IMG})) {
faa9b3e7
TC		 1391 # let IIM_DESTROY do the destruction, since the image may be
1392 # referenced from elsewhere
1393 #i_img_destroy($self->{IMG});
02d1d628
AMH		 1394 undef($self->{IMG});
1395 }
1396
84e51293
AMH		 1397 my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1398
5970bd39
TC		 1399 my $type = $input{'type'};
1400 unless ($type) {
1401 $type = i_test_format_probe($IO, -1);
66614d6e 1402 }
84e51293 1403
5970bd39
TC		 1404 unless ($type) {
1405 $self->_set_error('type parameter missing and not possible to guess from extension');
10461f9a
TC		 1406 return undef;
1407 }
02d1d628 1408
5970bd39 1409 _reader_autoload($type);
53a6bbd4 1410
5970bd39
TC		 1411 if ($readers{$type} && $readers{$type}{single}) {
1412 return $readers{$type}{single}->($self, $IO, %input);
53a6bbd4
TC		 1413 }
1414
5970bd39 1415 unless ($formats_low{$type}) {
f245645a 1416 my $read_types = join ', ', sort Imager->read_types();
5970bd39 1417 $self->_set_error("format '$type' not supported - formats $read_types available for reading - $reader_load_errors{$type}");
66614d6e
TC		 1418 return;
1419 }
1420
d87dc9a4
TC		 1421 my $allow_incomplete = $input{allow_incomplete};
1422 defined $allow_incomplete or $allow_incomplete = 0;
9c106321 1423
5970bd39 1424 if ( $type eq 'pnm' ) {
d87dc9a4 1425 $self->{IMG}=i_readpnm_wiol( $IO, $allow_incomplete );
2fe0b227 1426 if ( !defined($self->{IMG}) ) {
2691d220
TC		 1427 $self->{ERRSTR}='unable to read pnm image: '._error_as_msg();
1428 return undef;
790923a4 1429 }
2fe0b227
AMH		 1430 $self->{DEBUG} && print "loading a pnm file\n";
1431 return $self;
1432 }
790923a4 1433
5970bd39 1434 if ( $type eq 'bmp' ) {
d87dc9a4 1435 $self->{IMG}=i_readbmp_wiol( $IO, $allow_incomplete );
2fe0b227
AMH		 1436 if ( !defined($self->{IMG}) ) {
1437 $self->{ERRSTR}=$self->_error_as_msg();
1438 return undef;
10461f9a 1439 }
2fe0b227
AMH		 1440 $self->{DEBUG} && print "loading a bmp file\n";
1441 }
10461f9a 1442
5970bd39 1443 if ( $type eq 'gif' ) {
2fe0b227
AMH		 1444 if ($input{colors} && !ref($input{colors})) {
1445 # must be a reference to a scalar that accepts the colour map
1446 $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1447 return undef;
1ec86afa 1448 }
f1adece7
TC		 1449 if ($input{'gif_consolidate'}) {
1450 if ($input{colors}) {
1451 my $colors;
1452 ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1453 if ($colors) {
1454 ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1455 }
1456 }
1457 else {
1458 $self->{IMG} =i_readgif_wiol( $IO );
737a830c 1459 }
737a830c 1460 }
2fe0b227 1461 else {
f1adece7
TC		 1462 my $page = $input{'page'};
1463 defined $page or $page = 0;
1464 $self->{IMG} = i_readgif_single_wiol( $IO, $page );
a5dbf458 1465 if ($self->{IMG} && $input{colors}) {
f1adece7
TC		 1466 ${ $input{colors} } =
1467 [ i_getcolors($self->{IMG}, 0, i_colorcount($self->{IMG})) ];
1468 }
895dbd34 1469 }
f1adece7 1470
2fe0b227
AMH		 1471 if ( !defined($self->{IMG}) ) {
1472 $self->{ERRSTR}=$self->_error_as_msg();
1473 return undef;
895dbd34 1474 }
2fe0b227
AMH		 1475 $self->{DEBUG} && print "loading a gif file\n";
1476 }
895dbd34 1477
5970bd39 1478 if ( $type eq 'tga' ) {
2fe0b227
AMH		 1479 $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1480 if ( !defined($self->{IMG}) ) {
1481 $self->{ERRSTR}=$self->_error_as_msg();
1482 return undef;
895dbd34 1483 }
2fe0b227
AMH		 1484 $self->{DEBUG} && print "loading a tga file\n";
1485 }
02d1d628 1486
5970bd39 1487 if ( $type eq 'raw' ) {
500888da
TC		 1488 unless ( $input{xsize} && $input{ysize} ) {
1489 $self->_set_error('missing xsize or ysize parameter for raw');
2fe0b227 1490 return undef;
895dbd34
AMH		 1491 }
1492
500888da
TC		 1493 my $interleave = _first($input{raw_interleave}, $input{interleave});
1494 unless (defined $interleave) {
1495 my @caller = caller;
1496 warn "read(type => 'raw') $caller[2] line $caller[1]: supply interleave or raw_interleave for future compatibility\n";
1497 $interleave = 1;
1498 }
1499 my $data_ch = _first($input{raw_datachannels}, $input{datachannels}, 3);
1500 my $store_ch = _first($input{raw_storechannels}, $input{storechannels}, 3);
1501
2fe0b227 1502 $self->{IMG} = i_readraw_wiol( $IO,
500888da
TC		 1503 $input{xsize},
1504 $input{ysize},
1505 $data_ch,
1506 $store_ch,
1507 $interleave);
2fe0b227 1508 if ( !defined($self->{IMG}) ) {
5f8f8e17 1509 $self->{ERRSTR}=$self->_error_as_msg();
2fe0b227 1510 return undef;
dd55acc8 1511 }
2fe0b227 1512 $self->{DEBUG} && print "loading a raw file\n";
02d1d628 1513 }
2fe0b227 1514
02d1d628 1515 return $self;
02d1d628
AMH		 1516}
1517
53a6bbd4
TC		 1518sub register_reader {
1519 my ($class, %opts) = @_;
1520
1521 defined $opts{type}
1522 or die "register_reader called with no type parameter\n";
1523
1524 my $type = $opts{type};
1525
1526 defined $opts{single} || defined $opts{multiple}
1527 or die "register_reader called with no single or multiple parameter\n";
1528
1529 $readers{$type} = { };
1530 if ($opts{single}) {
1531 $readers{$type}{single} = $opts{single};
1532 }
1533 if ($opts{multiple}) {
1534 $readers{$type}{multiple} = $opts{multiple};
1535 }
1536
1537 return 1;
1538}
1539
2b405c9e
TC		 1540sub register_writer {
1541 my ($class, %opts) = @_;
1542
1543 defined $opts{type}
1544 or die "register_writer called with no type parameter\n";
1545
1546 my $type = $opts{type};
1547
1548 defined $opts{single} || defined $opts{multiple}
1549 or die "register_writer called with no single or multiple parameter\n";
1550
1551 $writers{$type} = { };
1552 if ($opts{single}) {
1553 $writers{$type}{single} = $opts{single};
1554 }
1555 if ($opts{multiple}) {
1556 $writers{$type}{multiple} = $opts{multiple};
1557 }
1558
1559 return 1;
1560}
1561
f245645a
TC		 1562sub read_types {
1563 my %types =
1564 (
1565 map { $_ => 1 }
1566 keys %readers,
1567 grep($file_formats{$_}, keys %formats),
1568 qw(ico sgi), # formats not handled directly, but supplied with Imager
1569 );
1570
1571 return keys %types;
1572}
1573
1574sub write_types {
1575 my %types =
1576 (
1577 map { $_ => 1 }
1578 keys %writers,
1579 grep($file_formats{$_}, keys %formats),
1580 qw(ico sgi), # formats not handled directly, but supplied with Imager
1581 );
1582
1583 return keys %types;
1584}
1585
5970bd39
TC		 1586sub _load_file {
1587 my ($file, $error) = @_;
1588
1589 if ($attempted_to_load{$file}) {
1590 if ($file_load_errors{$file}) {
1591 $$error = $file_load_errors{$file};
1592 return 0;
1593 }
1594 else {
1595 return 1;
1596 }
1597 }
1598 else {
1599 local $SIG{__DIE__};
1600 my $loaded = eval {
1601 ++$attempted_to_load{$file};
1602 require $file;
1603 return 1;
1604 };
1605 if ($loaded) {
1606 return 1;
1607 }
1608 else {
1609 my $work = $@ || "Unknown error loading $file";
1610 chomp $work;
1611 $work =~ s/\n?Compilation failed in require at .*Imager\.pm line .*\z//m;
1612 $work =~ s/\n/\\n/g;
1613 $file_load_errors{$file} = $work;
1614 $$error = $work;
1615 return 0;
1616 }
1617 }
1618}
1619
53a6bbd4
TC		 1620# probes for an Imager::File::whatever module
1621sub _reader_autoload {
1622 my $type = shift;
1623
1d7e3124 1624 return if $formats_low{$type} || $readers{$type};
53a6bbd4
TC		 1625
1626 return unless $type =~ /^\w+$/;
1627
1628 my $file = "Imager/File/\U$type\E.pm";
1629
5970bd39
TC		 1630 my $error;
1631 my $loaded = _load_file($file, \$error);
1632 if (!$loaded && $error =~ /^Can't locate /) {
1633 my $filer = "Imager/File/\U$type\EReader.pm";
1634 $loaded = _load_file($filer, \$error);
1635 if ($error =~ /^Can't locate /) {
1636 $error = "Can't locate $file or $filer";
2b405c9e
TC		 1637 }
1638 }
5970bd39
TC		 1639 unless ($loaded) {
1640 $reader_load_errors{$type} = $error;
1641 }
2b405c9e
TC		 1642}
1643
1644# probes for an Imager::File::whatever module
1645sub _writer_autoload {
1646 my $type = shift;
1647
5970bd39 1648 return if $formats_low{$type} || $writers{$type};
2b405c9e
TC		 1649
1650 return unless $type =~ /^\w+$/;
1651
1652 my $file = "Imager/File/\U$type\E.pm";
1653
5970bd39
TC		 1654 my $error;
1655 my $loaded = _load_file($file, \$error);
1656 if (!$loaded && $error =~ /^Can't locate /) {
1657 my $filew = "Imager/File/\U$type\EWriter.pm";
1658 $loaded = _load_file($filew, \$error);
1659 if ($error =~ /^Can't locate /) {
1660 $error = "Can't locate $file or $filew";
2b405c9e 1661 }
53a6bbd4 1662 }
5970bd39
TC		 1663 unless ($loaded) {
1664 $writer_load_errors{$type} = $error;
1665 }
53a6bbd4
TC		 1666}
1667
97c4effc
TC		 1668sub _fix_gif_positions {
1669 my ($opts, $opt, $msg, @imgs) = @_;
2fe0b227 1670
97c4effc
TC		 1671 my $positions = $opts->{'gif_positions'};
1672 my $index = 0;
1673 for my $pos (@$positions) {
1674 my ($x, $y) = @$pos;
1675 my $img = $imgs[$index++];
9d1c4956
TC		 1676 $img->settag(name=>'gif_left', value=>$x);
1677 $img->settag(name=>'gif_top', value=>$y) if defined $y;
97c4effc
TC		 1678 }
1679 $$msg .= "replaced with the gif_left and gif_top tags";
1680}
1681
1682my %obsolete_opts =
1683 (
1684 gif_each_palette=>'gif_local_map',
1685 interlace => 'gif_interlace',
1686 gif_delays => 'gif_delay',
1687 gif_positions => \&_fix_gif_positions,
1688 gif_loop_count => 'gif_loop',
1689 );
1690
6e4af7d4
TC		 1691# options that should be converted to colors
1692my %color_opts = map { $_ => 1 } qw/i_background/;
1693
97c4effc
TC		 1694sub _set_opts {
1695 my ($self, $opts, $prefix, @imgs) = @_;
1696
1697 for my $opt (keys %$opts) {
1698 my $tagname = $opt;
1699 if ($obsolete_opts{$opt}) {
1700 my $new = $obsolete_opts{$opt};
1701 my $msg = "Obsolete option $opt ";
1702 if (ref $new) {
1703 $new->($opts, $opt, \$msg, @imgs);
1704 }
1705 else {
1706 $msg .= "replaced with the $new tag ";
1707 $tagname = $new;
1708 }
1709 $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1710 warn $msg if $warn_obsolete && $^W;
1711 }
1712 next unless $tagname =~ /^\Q$prefix/;
1713 my $value = $opts->{$opt};
6e4af7d4
TC		 1714 if ($color_opts{$opt}) {
1715 $value = _color($value);
1716 unless ($value) {
1717 $self->_set_error($Imager::ERRSTR);
1718 return;
1719 }
1720 }
97c4effc
TC		 1721 if (ref $value) {
1722 if (UNIVERSAL::isa($value, "Imager::Color")) {
1723 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1724 for my $img (@imgs) {
1725 $img->settag(name=>$tagname, value=>$tag);
1726 }
1727 }
1728 elsif (ref($value) eq 'ARRAY') {
1729 for my $i (0..$#$value) {
1730 my $val = $value->[$i];
1731 if (ref $val) {
1732 if (UNIVERSAL::isa($val, "Imager::Color")) {
1733 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1734 $i < @imgs and
1735 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1736 }
1737 else {
1738 $self->_set_error("Unknown reference type " . ref($value) .
1739 " supplied in array for $opt");
1740 return;
1741 }
1742 }
1743 else {
1744 $i < @imgs
1745 and $imgs[$i]->settag(name=>$tagname, value=>$val);
1746 }
1747 }
1748 }
1749 else {
1750 $self->_set_error("Unknown reference type " . ref($value) .
1751 " supplied for $opt");
1752 return;
1753 }
1754 }
1755 else {
1756 # set it as a tag for every image
1757 for my $img (@imgs) {
1758 $img->settag(name=>$tagname, value=>$value);
1759 }
1760 }
1761 }
1762
1763 return 1;
1764}
1765
02d1d628 1766# Write an image to file
02d1d628
AMH		 1767sub write {
1768 my $self = shift;
2fe0b227
AMH		 1769 my %input=(jpegquality=>75,
1770 gifquant=>'mc',
1771 lmdither=>6.0,
febba01f
AMH		 1772 lmfixed=>[],
1773 idstring=>"",
1774 compress=>1,
1775 wierdpack=>0,
4c2d6970 1776 fax_fine=>1, @_);
10461f9a 1777 my $rc;
02d1d628 1778
97c4effc
TC		 1779 $self->_set_opts(\%input, "i_", $self)
1780 or return undef;
1781
02d1d628
AMH		 1782 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1783
5970bd39
TC		 1784 my $type = $input{'type'};
1785 if (!$type and $input{file}) {
1786 $type = $FORMATGUESS->($input{file});
9d540150 1787 }
5970bd39 1788 unless ($type) {
9d540150
TC		 1789 $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1790 return undef;
1791 }
02d1d628 1792
5970bd39 1793 _writer_autoload($type);
02d1d628 1794
2b405c9e 1795 my ($IO, $fh);
5970bd39
TC		 1796 if ($writers{$type} && $writers{$type}{single}) {
1797 ($IO, $fh) = $self->_get_writer_io(\%input)
2fe0b227 1798 or return undef;
febba01f 1799
5970bd39 1800 $writers{$type}{single}->($self, $IO, %input, type => $type)
2fe0b227 1801 or return undef;
2b405c9e
TC		 1802 }
1803 else {
5970bd39 1804 if (!$formats_low{$type}) {
f245645a 1805 my $write_types = join ', ', sort Imager->write_types();
5970bd39 1806 $self->_set_error("format '$type' not supported - formats $write_types available for writing - $writer_load_errors{$type}");
2fe0b227 1807 return undef;
930c67c8 1808 }
2b405c9e 1809
5970bd39 1810 ($IO, $fh) = $self->_get_writer_io(\%input, $type)
2fe0b227 1811 or return undef;
5970bd39
TC		 1812
1813 if ( $type eq 'pnm' ) {
2b405c9e
TC		 1814 $self->_set_opts(\%input, "pnm_", $self)
1815 or return undef;
1816 if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1817 $self->{ERRSTR} = $self->_error_as_msg();
1818 return undef;
1819 }
1820 $self->{DEBUG} && print "writing a pnm file\n";
5970bd39
TC		 1821 }
1822 elsif ( $type eq 'raw' ) {
2b405c9e
TC		 1823 $self->_set_opts(\%input, "raw_", $self)
1824 or return undef;
1825 if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1826 $self->{ERRSTR} = $self->_error_as_msg();
1827 return undef;
1828 }
1829 $self->{DEBUG} && print "writing a raw file\n";
5970bd39
TC		 1830 }
1831 elsif ( $type eq 'bmp' ) {
2b405c9e
TC		 1832 $self->_set_opts(\%input, "bmp_", $self)
1833 or return undef;
1834 if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
ae12796a 1835 $self->{ERRSTR} = $self->_error_as_msg;
2b405c9e
TC		 1836 return undef;
1837 }
1838 $self->{DEBUG} && print "writing a bmp file\n";
5970bd39
TC		 1839 }
1840 elsif ( $type eq 'tga' ) {
2b405c9e
TC		 1841 $self->_set_opts(\%input, "tga_", $self)
1842 or return undef;
1843
1844 if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1845 $self->{ERRSTR}=$self->_error_as_msg();
1846 return undef;
1847 }
1848 $self->{DEBUG} && print "writing a tga file\n";
1501d9b3 1849 }
02d1d628 1850 }
10461f9a 1851
2fe0b227
AMH		 1852 if (exists $input{'data'}) {
1853 my $data = io_slurp($IO);
1854 if (!$data) {
1855 $self->{ERRSTR}='Could not slurp from buffer';
1856 return undef;
1857 }
1858 ${$input{data}} = $data;
1859 }
02d1d628
AMH		 1860 return $self;
1861}
1862
1863sub write_multi {
1864 my ($class, $opts, @images) = @_;
1865
2b405c9e
TC		 1866 my $type = $opts->{type};
1867
1868 if (!$type && $opts->{'file'}) {
1869 $type = $FORMATGUESS->($opts->{'file'});
10461f9a 1870 }
2b405c9e 1871 unless ($type) {
10461f9a
TC		 1872 $class->_set_error('type parameter missing and not possible to guess from extension');
1873 return;
1874 }
1875 # translate to ImgRaw
1876 if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1877 $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1878 return 0;
1879 }
97c4effc
TC		 1880 $class->_set_opts($opts, "i_", @images)
1881 or return;
10461f9a 1882 my @work = map $_->{IMG}, @images;
2b405c9e
TC		 1883
1884 _writer_autoload($type);
1885
1886 my ($IO, $file);
1887 if ($writers{$type} && $writers{$type}{multiple}) {
1888 ($IO, $file) = $class->_get_writer_io($opts, $type)
1889 or return undef;
1890
1891 $writers{$type}{multiple}->($class, $IO, $opts, @images)
1892 or return undef;
1893 }
1894 else {
1895 if (!$formats{$type}) {
f245645a
TC		 1896 my $write_types = join ', ', sort Imager->write_types();
1897 $class->_set_error("format '$type' not supported - formats $write_types available for writing");
2b405c9e
TC		 1898 return undef;
1899 }
1900
1901 ($IO, $file) = $class->_get_writer_io($opts, $type)
1902 or return undef;
1903
e5ee047b 1904 if (0) { # eventually PNM in here, now that TIFF/GIF are elsewhere
02d1d628
AMH		 1905 }
1906 else {
e7ff1cf7
TC		 1907 if (@images == 1) {
1908 unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
1909 return 1;
1910 }
1911 }
1912 else {
1913 $ERRSTR = "Sorry, write_multi doesn't support $type yet";
1914 return 0;
1915 }
02d1d628
AMH		 1916 }
1917 }
2b405c9e
TC		 1918
1919 if (exists $opts->{'data'}) {
1920 my $data = io_slurp($IO);
1921 if (!$data) {
1922 Imager->_set_error('Could not slurp from buffer');
1923 return undef;
1924 }
1925 ${$opts->{data}} = $data;
02d1d628 1926 }
2b405c9e 1927 return 1;
02d1d628
AMH		 1928}
1929
faa9b3e7
TC		 1930# read multiple images from a file
1931sub read_multi {
1932 my ($class, %opts) = @_;
1933
53a6bbd4
TC		 1934 my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1935 or return;
1936
1937 my $type = $opts{'type'};
1938 unless ($type) {
1939 $type = i_test_format_probe($IO, -1);
1940 }
1941
1942 if ($opts{file} && !$type) {
faa9b3e7 1943 # guess the type
53a6bbd4 1944 $type = $FORMATGUESS->($opts{file});
faa9b3e7 1945 }
53a6bbd4
TC		 1946
1947 unless ($type) {
faa9b3e7
TC		 1948 $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1949 return;
1950 }
faa9b3e7 1951
53a6bbd4
TC		 1952 _reader_autoload($type);
1953
1954 if ($readers{$type} && $readers{$type}{multiple}) {
1955 return $readers{$type}{multiple}->($IO, %opts);
1956 }
1957
8d46e5da
TC		 1958 unless ($formats{$type}) {
1959 my $read_types = join ', ', sort Imager->read_types();
1960 Imager->_set_error("format '$type' not supported - formats $read_types available for reading");
1961 return;
1962 }
1963
e5ee047b
TC		 1964 my @imgs;
1965 if ($type eq 'pnm') {
2086be61 1966 @imgs = i_readpnm_multi_wiol($IO, $opts{allow_incomplete}||0);
faa9b3e7 1967 }
e7ff1cf7
TC		 1968 else {
1969 my $img = Imager->new;
1970 if ($img->read(%opts, io => $IO, type => $type)) {
1971 return ( $img );
1972 }
f245645a 1973 Imager->_set_error($img->errstr);
2086be61 1974 return;
e7ff1cf7 1975 }
faa9b3e7 1976
2086be61
TC		 1977 if (!@imgs) {
1978 $ERRSTR = _error_as_msg();
faa9b3e7 1979 return;
2086be61
TC		 1980 }
1981 return map {
1982 bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
1983 } @imgs;
faa9b3e7
TC		 1984}
1985
02d1d628
AMH		 1986# Destroy an Imager object
1987
1988sub DESTROY {
1989 my $self=shift;
1990 # delete $instances{$self};
1991 if (defined($self->{IMG})) {
faa9b3e7
TC		 1992 # the following is now handled by the XS DESTROY method for
1993 # Imager::ImgRaw object
1994 # Re-enabling this will break virtual images
1995 # tested for in t/t020masked.t
1996 # i_img_destroy($self->{IMG});
02d1d628
AMH		 1997 undef($self->{IMG});
1998 } else {
1999# print "Destroy Called on an empty image!\n"; # why did I put this here??
2000 }
2001}
2002
2003# Perform an inplace filter of an image
2004# that is the image will be overwritten with the data
2005
2006sub filter {
2007 my $self=shift;
2008 my %input=@_;
2009 my %hsh;
2010 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2011
9d540150 2012 if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
02d1d628 2013
9d540150 2014 if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
02d1d628
AMH		 2015 $self->{ERRSTR}='type parameter not matching any filter'; return undef;
2016 }
2017
9d540150
TC		 2018 if ($filters{$input{'type'}}{names}) {
2019 my $names = $filters{$input{'type'}}{names};
6607600c
TC		 2020 for my $name (keys %$names) {
2021 if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
2022 $input{$name} = $names->{$name}{$input{$name}};
2023 }
2024 }
2025 }
9d540150 2026 if (defined($filters{$input{'type'}}{defaults})) {
7327d4b0
TC		 2027 %hsh=( image => $self->{IMG},
2028 imager => $self,
2029 %{$filters{$input{'type'}}{defaults}},
2030 %input );
02d1d628 2031 } else {
7327d4b0
TC		 2032 %hsh=( image => $self->{IMG},
2033 imager => $self,
2034 %input );
02d1d628
AMH		 2035 }
2036
9d540150 2037 my @cs=@{$filters{$input{'type'}}{callseq}};
02d1d628
AMH		 2038
2039 for(@cs) {
2040 if (!defined($hsh{$_})) {
9d540150 2041 $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
02d1d628
AMH		 2042 }
2043 }
2044
109bec2d
TC		 2045 eval {
2046 local $SIG{__DIE__}; # we don't want this processed by confess, etc
2047 &{$filters{$input{'type'}}{callsub}}(%hsh);
2048 };
2049 if ($@) {
2050 chomp($self->{ERRSTR} = $@);
2051 return;
2052 }
02d1d628
AMH		 2053
2054 my @b=keys %hsh;
2055
2056 $self->{DEBUG} && print "callseq is: @cs\n";
2057 $self->{DEBUG} && print "matching callseq is: @b\n";
2058
2059 return $self;
2060}
2061
92bda632
TC		 2062sub register_filter {
2063 my $class = shift;
2064 my %hsh = ( defaults => {}, @_ );
2065
2066 defined $hsh{type}
2067 or die "register_filter() with no type\n";
2068 defined $hsh{callsub}
2069 or die "register_filter() with no callsub\n";
2070 defined $hsh{callseq}
2071 or die "register_filter() with no callseq\n";
2072
2073 exists $filters{$hsh{type}}
2074 and return;
2075
2076 $filters{$hsh{type}} = \%hsh;
2077
2078 return 1;
2079}
2080
df9aaafb
TC		 2081sub scale_calculate {
2082 my $self = shift;
02d1d628 2083
df9aaafb 2084 my %opts = ('type'=>'max', @_);
4f579313 2085
de470892
TC		 2086 # none of these should be references
2087 for my $name (qw/xpixels ypixels xscalefactor yscalefactor width height/) {
2088 if (defined $opts{$name} && ref $opts{$name}) {
2089 $self->_set_error("scale_calculate: $name parameter cannot be a reference");
2090 return;
2091 }
2092 }
2093
df9aaafb
TC		 2094 my ($x_scale, $y_scale);
2095 my $width = $opts{width};
2096 my $height = $opts{height};
2097 if (ref $self) {
2098 defined $width or $width = $self->getwidth;
2099 defined $height or $height = $self->getheight;
ace46df2 2100 }
df9aaafb
TC		 2101 else {
2102 unless (defined $width && defined $height) {
2103 $self->_set_error("scale_calculate: width and height parameters must be supplied when called as a class method");
2104 return;
2105 }
5168ca3a 2106 }
02d1d628 2107
658f724e
TC		 2108 if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
2109 $x_scale = $opts{'xscalefactor'};
2110 $y_scale = $opts{'yscalefactor'};
2111 }
2112 elsif ($opts{'xscalefactor'}) {
2113 $x_scale = $opts{'xscalefactor'};
2114 $y_scale = $opts{'scalefactor'} || $x_scale;
2115 }
2116 elsif ($opts{'yscalefactor'}) {
2117 $y_scale = $opts{'yscalefactor'};
2118 $x_scale = $opts{'scalefactor'} || $y_scale;
2119 }
2120 else {
2121 $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2122 }
2123
5168ca3a 2124 # work out the scaling
9d540150 2125 if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
df9aaafb
TC		 2126 my ($xpix, $ypix)=( $opts{xpixels} / $width ,
2127 $opts{ypixels} / $height );
5168ca3a 2128 if ($opts{'type'} eq 'min') {
658f724e 2129 $x_scale = $y_scale = _min($xpix,$ypix);
5168ca3a
TC		 2130 }
2131 elsif ($opts{'type'} eq 'max') {
658f724e
TC		 2132 $x_scale = $y_scale = _max($xpix,$ypix);
2133 }
2134 elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2135 $x_scale = $xpix;
2136 $y_scale = $ypix;
5168ca3a
TC		 2137 }
2138 else {
2139 $self->_set_error('invalid value for type parameter');
df9aaafb 2140 return;
5168ca3a
TC		 2141 }
2142 } elsif ($opts{xpixels}) {
df9aaafb 2143 $x_scale = $y_scale = $opts{xpixels} / $width;
5168ca3a
TC		 2144 }
2145 elsif ($opts{ypixels}) {
df9aaafb 2146 $x_scale = $y_scale = $opts{ypixels}/$height;
5168ca3a 2147 }
41c7d053
TC		 2148 elsif ($opts{constrain} && ref $opts{constrain}
2149 && $opts{constrain}->can('constrain')) {
2150 # we've been passed an Image::Math::Constrain object or something
2151 # that looks like one
658f724e 2152 my $scalefactor;
4f579313 2153 (undef, undef, $scalefactor)
41c7d053 2154 = $opts{constrain}->constrain($self->getwidth, $self->getheight);
4f579313 2155 unless ($scalefactor) {
41c7d053 2156 $self->_set_error('constrain method failed on constrain parameter');
df9aaafb 2157 return;
41c7d053 2158 }
658f724e 2159 $x_scale = $y_scale = $scalefactor;
41c7d053 2160 }
02d1d628 2161
df9aaafb
TC		 2162 my $new_width = int($x_scale * $width + 0.5);
2163 $new_width > 0 or $new_width = 1;
2164 my $new_height = int($y_scale * $height + 0.5);
2165 $new_height > 0 or $new_height = 1;
2166
2167 return ($x_scale, $y_scale, $new_width, $new_height);
2168
2169}
2170
2171# Scale an image to requested size and return the scaled version
2172
2173sub scale {
2174 my $self=shift;
2175 my %opts = (qtype=>'normal' ,@_);
2176 my $img = Imager->new();
2177 my $tmp = Imager->new();
2178
2179 unless (defined wantarray) {
2180 my @caller = caller;
2181 warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
2182 return;
2183 }
2184
2185 unless ($self->{IMG}) {
2186 $self->_set_error('empty input image');
2187 return undef;
2188 }
2189
2190 my ($x_scale, $y_scale, $new_width, $new_height) =
2191 $self->scale_calculate(%opts)
2192 or return;
2193
02d1d628 2194 if ($opts{qtype} eq 'normal') {
658f724e 2195 $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
5168ca3a 2196 if ( !defined($tmp->{IMG}) ) {
de470892 2197 $self->{ERRSTR} = 'unable to scale image: ' . $self->_error_as_msg;
5168ca3a
TC		 2198 return undef;
2199 }
658f724e 2200 $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
5168ca3a 2201 if ( !defined($img->{IMG}) ) {
de470892 2202 $self->{ERRSTR}='unable to scale image: ' . $self->_error_as_msg;
5168ca3a
TC		 2203 return undef;
2204 }
2205
02d1d628
AMH		 2206 return $img;
2207 }
5168ca3a 2208 elsif ($opts{'qtype'} eq 'preview') {
658f724e 2209 $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
5168ca3a
TC		 2210 if ( !defined($img->{IMG}) ) {
2211 $self->{ERRSTR}='unable to scale image';
2212 return undef;
2213 }
02d1d628
AMH		 2214 return $img;
2215 }
658f724e 2216 elsif ($opts{'qtype'} eq 'mixing') {
658f724e
TC		 2217 $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2218 unless ($img->{IMG}) {
de470892 2219 $self->_set_error(Imager->_error_as_msg);
658f724e
TC		 2220 return;
2221 }
2222 return $img;
2223 }
5168ca3a
TC		 2224 else {
2225 $self->_set_error('invalid value for qtype parameter');
2226 return undef;
2227 }
02d1d628
AMH		 2228}
2229
2230# Scales only along the X axis
2231
2232sub scaleX {
15327bf5
TC		 2233 my $self = shift;
2234 my %opts = ( scalefactor=>0.5, @_ );
02d1d628 2235
34b3f7e6
TC		 2236 unless (defined wantarray) {
2237 my @caller = caller;
2238 warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2239 return;
2240 }
2241
15327bf5
TC		 2242 unless ($self->{IMG}) {
2243 $self->{ERRSTR} = 'empty input image';
2244 return undef;
2245 }
02d1d628
AMH		 2246
2247 my $img = Imager->new();
2248
15327bf5 2249 my $scalefactor = $opts{scalefactor};
02d1d628 2250
15327bf5
TC		 2251 if ($opts{pixels}) {
2252 $scalefactor = $opts{pixels} / $self->getwidth();
2253 }
2254
2255 unless ($self->{IMG}) {
2256 $self->{ERRSTR}='empty input image';
2257 return undef;
2258 }
2259
2260 $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2261
2262 if ( !defined($img->{IMG}) ) {
2263 $self->{ERRSTR} = 'unable to scale image';
2264 return undef;
2265 }
02d1d628 2266
02d1d628
AMH		 2267 return $img;
2268}
2269
2270# Scales only along the Y axis
2271
2272sub scaleY {
15327bf5
TC		 2273 my $self = shift;
2274 my %opts = ( scalefactor => 0.5, @_ );
02d1d628 2275
34b3f7e6
TC		 2276 unless (defined wantarray) {
2277 my @caller = caller;
2278 warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2279 return;
2280 }
2281
02d1d628
AMH		 2282 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2283
2284 my $img = Imager->new();
2285
15327bf5 2286 my $scalefactor = $opts{scalefactor};
02d1d628 2287
15327bf5
TC		 2288 if ($opts{pixels}) {
2289 $scalefactor = $opts{pixels} / $self->getheight();
2290 }
2291
2292 unless ($self->{IMG}) {
2293 $self->{ERRSTR} = 'empty input image';
2294 return undef;
2295 }
2296 $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2297
2298 if ( !defined($img->{IMG}) ) {
2299 $self->{ERRSTR} = 'unable to scale image';
2300 return undef;
2301 }
02d1d628 2302
02d1d628
AMH		 2303 return $img;
2304}
2305
02d1d628
AMH		 2306# Transform returns a spatial transformation of the input image
2307# this moves pixels to a new location in the returned image.
2308# NOTE - should make a utility function to check transforms for
2309# stack overruns
2310
2311sub transform {
2312 my $self=shift;
2313 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2314 my %opts=@_;
2315 my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2316
2317# print Dumper(\%opts);
2318# xopcopdes
2319
2320 if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2321 if (!$I2P) {
2322 eval ("use Affix::Infix2Postfix;");
2323 print $@;
2324 if ( $@ ) {
2325 $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
2326 return undef;
2327 }
2328 $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2329 {op=>'-',trans=>'Sub'},
2330 {op=>'*',trans=>'Mult'},
2331 {op=>'/',trans=>'Div'},
9d540150 2332 {op=>'-','type'=>'unary',trans=>'u-'},
02d1d628 2333 {op=>'**'},
9d540150 2334 {op=>'func','type'=>'unary'}],
02d1d628
AMH		 2335 'grouping'=>[qw( \( \) )],
2336 'func'=>[qw( sin cos )],
2337 'vars'=>[qw( x y )]
2338 );
2339 }
2340
2341 @xt=$I2P->translate($opts{'xexpr'});
2342 @yt=$I2P->translate($opts{'yexpr'});
2343
2344 $numre=$I2P->{'numre'};
2345 @pt=(0,0);
2346
2347 for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
2348 for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
2349 @{$opts{'parm'}}=@pt;
2350 }
2351
2352# print Dumper(\%opts);
2353
2354 if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
2355 $self->{ERRSTR}='transform: no xopcodes given.';
2356 return undef;
2357 }
2358
2359 @op=@{$opts{'xopcodes'}};
2360 for $iop (@op) {
2361 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2362 $self->{ERRSTR}="transform: illegal opcode '$_'.";
2363 return undef;
2364 }
2365 push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2366 }
2367
2368
2369# yopcopdes
2370
2371 if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
2372 $self->{ERRSTR}='transform: no yopcodes given.';
2373 return undef;
2374 }
2375
2376 @op=@{$opts{'yopcodes'}};
2377 for $iop (@op) {
2378 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2379 $self->{ERRSTR}="transform: illegal opcode '$_'.";
2380 return undef;
2381 }
2382 push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2383 }
2384
2385#parameters
2386
2387 if ( !exists $opts{'parm'}) {
2388 $self->{ERRSTR}='transform: no parameter arg given.';
2389 return undef;
2390 }
2391
2392# print Dumper(\@ropx);
2393# print Dumper(\@ropy);
2394# print Dumper(\@ropy);
2395
2396 my $img = Imager->new();
2397 $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2398 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
2399 return $img;
2400}
2401
2402
bf94b653
TC		 2403sub transform2 {
2404 my ($opts, @imgs) = @_;
2405
2406 require "Imager/Expr.pm";
2407
2408 $opts->{variables} = [ qw(x y) ];
2409 my ($width, $height) = @{$opts}{qw(width height)};
2410 if (@imgs) {
2411 $width ||= $imgs[0]->getwidth();
2412 $height ||= $imgs[0]->getheight();
2413 my $img_num = 1;
2414 for my $img (@imgs) {
2415 $opts->{constants}{"w$img_num"} = $img->getwidth();
2416 $opts->{constants}{"h$img_num"} = $img->getheight();
2417 $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2418 $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2419 ++$img_num;
02d1d628 2420 }
02d1d628 2421 }
bf94b653
TC		 2422 if ($width) {
2423 $opts->{constants}{w} = $width;
2424 $opts->{constants}{cx} = $width/2;
2425 }
2426 else {
2427 $Imager::ERRSTR = "No width supplied";
2428 return;
2429 }
2430 if ($height) {
2431 $opts->{constants}{h} = $height;
2432 $opts->{constants}{cy} = $height/2;
2433 }
2434 else {
2435 $Imager::ERRSTR = "No height supplied";
2436 return;
2437 }
2438 my $code = Imager::Expr->new($opts);
2439 if (!$code) {
2440 $Imager::ERRSTR = Imager::Expr::error();
2441 return;
2442 }
e5744e01
TC		 2443 my $channels = $opts->{channels} || 3;
2444 unless ($channels >= 1 && $channels <= 4) {
2445 return Imager->_set_error("channels must be an integer between 1 and 4");
2446 }
9982a307 2447
bf94b653 2448 my $img = Imager->new();
e5744e01
TC		 2449 $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
2450 $channels, $code->code(),
bf94b653
TC		 2451 $code->nregs(), $code->cregs(),
2452 [ map { $_->{IMG} } @imgs ]);
2453 if (!defined $img->{IMG}) {
2454 $Imager::ERRSTR = Imager->_error_as_msg();
2455 return;
2456 }
9982a307 2457
bf94b653 2458 return $img;
02d1d628
AMH		 2459}
2460
02d1d628
AMH		 2461sub rubthrough {
2462 my $self=shift;
9b1ec2b8 2463 my %opts= @_;
02d1d628 2464
e7b95388
TC		 2465 unless ($self->{IMG}) {
2466 $self->{ERRSTR}='empty input image';
2467 return undef;
2468 }
2469 unless ($opts{src} && $opts{src}->{IMG}) {
2470 $self->{ERRSTR}='empty input image for src';
2471 return undef;
2472 }
02d1d628 2473
71dc4a83
AMH		 2474 %opts = (src_minx => 0,
2475 src_miny => 0,
2476 src_maxx => $opts{src}->getwidth(),
2477 src_maxy => $opts{src}->getheight(),
2478 %opts);
2479
9b1ec2b8
TC		 2480 my $tx = $opts{tx};
2481 defined $tx or $tx = $opts{left};
2482 defined $tx or $tx = 0;
2483
2484 my $ty = $opts{ty};
2485 defined $ty or $ty = $opts{top};
2486 defined $ty or $ty = 0;
2487
2488 unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $tx, $ty,
e7b95388
TC		 2489 $opts{src_minx}, $opts{src_miny},
2490 $opts{src_maxx}, $opts{src_maxy})) {
2491 $self->_set_error($self->_error_as_msg());
faa9b3e7
TC		 2492 return undef;
2493 }
9b1ec2b8 2494
02d1d628
AMH		 2495 return $self;
2496}
2497
9b1ec2b8
TC		 2498sub compose {
2499 my $self = shift;
2500 my %opts =
2501 (
2502 opacity => 1.0,
2503 mask_left => 0,
2504 mask_top => 0,
2505 @_
2506 );
2507
2508 unless ($self->{IMG}) {
2509 $self->_set_error("compose: empty input image");
2510 return;
2511 }
2512
2513 unless ($opts{src}) {
2514 $self->_set_error("compose: src parameter missing");
2515 return;
2516 }
2517
2518 unless ($opts{src}{IMG}) {
2519 $self->_set_error("compose: src parameter empty image");
2520 return;
2521 }
2522 my $src = $opts{src};
2523
2524 my $left = $opts{left};
2525 defined $left or $left = $opts{tx};
2526 defined $left or $left = 0;
2527
2528 my $top = $opts{top};
2529 defined $top or $top = $opts{ty};
2530 defined $top or $top = 0;
2531
2532 my $src_left = $opts{src_left};
2533 defined $src_left or $src_left = $opts{src_minx};
2534 defined $src_left or $src_left = 0;
2535
2536 my $src_top = $opts{src_top};
2537 defined $src_top or $src_top = $opts{src_miny};
2538 defined $src_top or $src_top = 0;
2539
2540 my $width = $opts{width};
2541 if (!defined $width && defined $opts{src_maxx}) {
2542 $width = $opts{src_maxx} - $src_left;
2543 }
2544 defined $width or $width = $src->getwidth() - $src_left;
2545
2546 my $height = $opts{height};
2547 if (!defined $height && defined $opts{src_maxy}) {
2548 $height = $opts{src_maxy} - $src_top;
2549 }
2550 defined $height or $height = $src->getheight() - $src_top;
2551
2552 my $combine = $self->_combine($opts{combine}, 'normal');
2553
2554 if ($opts{mask}) {
2555 unless ($opts{mask}{IMG}) {
2556 $self->_set_error("compose: mask parameter empty image");
2557 return;
2558 }
2559
2560 my $mask_left = $opts{mask_left};
2561 defined $mask_left or $mask_left = $opts{mask_minx};
2562 defined $mask_left or $mask_left = 0;
2563
2564 my $mask_top = $opts{mask_top};
2565 defined $mask_top or $mask_top = $opts{mask_miny};
2566 defined $mask_top or $mask_top = 0;
2567
618a3282 2568 unless (i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
9b1ec2b8
TC		 2569 $left, $top, $src_left, $src_top,
2570 $mask_left, $mask_top, $width, $height,
618a3282
TC		 2571 $combine, $opts{opacity})) {
2572 $self->_set_error(Imager->_error_as_msg);
2573 return;
2574 }
9b1ec2b8
TC		 2575 }
2576 else {
618a3282
TC		 2577 unless (i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
2578 $width, $height, $combine, $opts{opacity})) {
2579 $self->_set_error(Imager->_error_as_msg);
2580 return;
2581 }
9b1ec2b8
TC		 2582 }
2583
2584 return $self;
2585}
02d1d628 2586
142c26ff
AMH		 2587sub flip {
2588 my $self = shift;
2589 my %opts = @_;
9191e525 2590 my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
142c26ff
AMH		 2591 my $dir;
2592 return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2593 $dir = $xlate{$opts{'dir'}};
2594 return $self if i_flipxy($self->{IMG}, $dir);
2595 return ();
2596}
2597
faa9b3e7
TC		 2598sub rotate {
2599 my $self = shift;
2600 my %opts = @_;
34b3f7e6
TC		 2601
2602 unless (defined wantarray) {
2603 my @caller = caller;
2604 warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2605 return;
2606 }
2607
faa9b3e7
TC		 2608 if (defined $opts{right}) {
2609 my $degrees = $opts{right};
2610 if ($degrees < 0) {
2611 $degrees += 360 * int(((-$degrees)+360)/360);
2612 }
2613 $degrees = $degrees % 360;
2614 if ($degrees == 0) {
2615 return $self->copy();
2616 }
2617 elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2618 my $result = Imager->new();
2619 if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2620 return $result;
2621 }
2622 else {
2623 $self->{ERRSTR} = $self->_error_as_msg();
2624 return undef;
2625 }
2626 }
2627 else {
2628 $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2629 return undef;
2630 }
2631 }
2632 elsif (defined $opts{radians} || defined $opts{degrees}) {
2633 my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
2634
7f627571 2635 my $back = $opts{back};
faa9b3e7 2636 my $result = Imager->new;
7f627571
TC		 2637 if ($back) {
2638 $back = _color($back);
2639 unless ($back) {
2640 $self->_set_error(Imager->errstr);
2641 return undef;
2642 }
2643
2644 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
0d3b936e
TC		 2645 }
2646 else {
2647 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2648 }
2649 if ($result->{IMG}) {
faa9b3e7
TC		 2650 return $result;
2651 }
2652 else {
2653 $self->{ERRSTR} = $self->_error_as_msg();
2654 return undef;
2655 }
2656 }
2657 else {
0d3b936e 2658 $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
faa9b3e7
TC		 2659 return undef;
2660 }
2661}
2662
2663sub matrix_transform {
2664 my $self = shift;
2665 my %opts = @_;
2666
34b3f7e6
TC		 2667 unless (defined wantarray) {
2668 my @caller = caller;
2669 warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2670 return;
2671 }
2672
faa9b3e7
TC		 2673 if ($opts{matrix}) {
2674 my $xsize = $opts{xsize} || $self->getwidth;
2675 my $ysize = $opts{ysize} || $self->getheight;
142c26ff 2676
faa9b3e7 2677 my $result = Imager->new;
0d3b936e
TC		 2678 if ($opts{back}) {
2679 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2680 $opts{matrix}, $opts{back})
2681 or return undef;
2682 }
2683 else {
2684 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2685 $opts{matrix})
2686 or return undef;
2687 }
faa9b3e7
TC		 2688
2689 return $result;
2690 }
2691 else {
2692 $self->{ERRSTR} = "matrix parameter required";
2693 return undef;
2694 }
2695}
2696
2697# blame Leolo :)
2698*yatf = \&matrix_transform;
02d1d628
AMH		 2699
2700# These two are supported for legacy code only
2701
2702sub i_color_new {
faa9b3e7 2703 return Imager::Color->new(@_);
02d1d628
AMH		 2704}
2705
2706sub i_color_set {
faa9b3e7 2707 return Imager::Color::set(@_);
02d1d628
AMH		 2708}
2709
02d1d628 2710# Draws a box between the specified corner points.
02d1d628
AMH		 2711sub box {
2712 my $self=shift;
3b000586
TC		 2713 my $raw = $self->{IMG};
2714
2715 unless ($raw) {
2716 $self->{ERRSTR}='empty input image';
2717 return undef;
2718 }
2719
2720 my %opts = @_;
02d1d628 2721
3b000586 2722 my ($xmin, $ymin, $xmax, $ymax);
02d1d628 2723 if (exists $opts{'box'}) {
3b000586
TC		 2724 $xmin = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2725 $xmax = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2726 $ymin = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2727 $ymax = _max($opts{'box'}->[1],$opts{'box'}->[3]);
2728 }
2729 else {
2730 defined($xmin = $opts{xmin}) or $xmin = 0;
2731 defined($xmax = $opts{xmax}) or $xmax = $self->getwidth()-1;
2732 defined($ymin = $opts{ymin}) or $ymin = 0;
2733 defined($ymax = $opts{ymax}) or $ymax = $self->getheight()-1;
02d1d628
AMH		 2734 }
2735
f1ac5027 2736 if ($opts{filled}) {
4dd88895
TC		 2737 my $color = $opts{'color'};
2738
2739 if (defined $color) {
813d4d0a 2740 unless (_is_color_object($color)) {
4dd88895
TC		 2741 $color = _color($color);
2742 unless ($color) {
2743 $self->{ERRSTR} = $Imager::ERRSTR;
2744 return;
2745 }
2746 }
3a9a4241 2747 }
4dd88895
TC		 2748 else {
2749 $color = i_color_new(255,255,255,255);
2750 }
2751
7477ff14
TC		 2752 if ($color->isa("Imager::Color")) {
2753 i_box_filled($raw, $xmin, $ymin,$xmax, $ymax, $color);
2754 }
2755 else {
2756 i_box_filledf($raw, $xmin, $ymin,$xmax, $ymax, $color);
2757 }
f1ac5027
TC		 2758 }
2759 elsif ($opts{fill}) {
2760 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2761 # assume it's a hash ref
2762 require 'Imager/Fill.pm';
141a6114
TC		 2763 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2764 $self->{ERRSTR} = $Imager::ERRSTR;
2765 return undef;
2766 }
f1ac5027 2767 }
3b000586 2768 i_box_cfill($raw, $xmin, $ymin, $xmax, $ymax, $opts{fill}{fill});
f1ac5027 2769 }
cdd23610 2770 else {
4dd88895
TC		 2771 my $color = $opts{'color'};
2772 if (defined $color) {
813d4d0a 2773 unless (_is_color_object($color)) {
4dd88895
TC		 2774 $color = _color($color);
2775 unless ($color) {
2776 $self->{ERRSTR} = $Imager::ERRSTR;
2777 return;
2778 }
2779 }
2780 }
2781 else {
2782 $color = i_color_new(255, 255, 255, 255);
2783 }
3a9a4241 2784 unless ($color) {
cdd23610
AMH		 2785 $self->{ERRSTR} = $Imager::ERRSTR;
2786 return;
3a9a4241 2787 }
3b000586 2788 i_box($raw, $xmin, $ymin, $xmax, $ymax, $color);
f1ac5027 2789 }
3b000586 2790
02d1d628
AMH		 2791 return $self;
2792}
2793
02d1d628
AMH		 2794sub arc {
2795 my $self=shift;
2796 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
40068b33
TC		 2797 my $dflcl= [ 255, 255, 255, 255];
2798 my $good = 1;
2799 my %opts=
2800 (
2801 color=>$dflcl,
2802 'r'=>_min($self->getwidth(),$self->getheight())/3,
2803 'x'=>$self->getwidth()/2,
2804 'y'=>$self->getheight()/2,
2805 'd1'=>0, 'd2'=>361,
2806 filled => 1,
2807 @_,
2808 );
a8652edf
TC		 2809 if ($opts{aa}) {
2810 if ($opts{fill}) {
2811 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2812 # assume it's a hash ref
2813 require 'Imager/Fill.pm';
2814 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2815 $self->{ERRSTR} = $Imager::ERRSTR;
2816 return;
2817 }
2818 }
2819 i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2820 $opts{'d2'}, $opts{fill}{fill});
2821 }
40068b33 2822 elsif ($opts{filled}) {
a8652edf
TC		 2823 my $color = _color($opts{'color'});
2824 unless ($color) {
2825 $self->{ERRSTR} = $Imager::ERRSTR;
2826 return;
2827 }
2828 if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2829 i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2830 $color);
2831 }
2832 else {
2833 i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2834 $opts{'d1'}, $opts{'d2'}, $color);
569795e8 2835 }
f1ac5027 2836 }
40068b33
TC		 2837 else {
2838 my $color = _color($opts{'color'});
2839 if ($opts{d2} - $opts{d1} >= 360) {
2840 $good = i_circle_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $color);
2841 }
2842 else {
2843 $good = i_arc_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $opts{'d1'}, $opts{'d2'}, $color);
2844 }
2845 }
f1ac5027
TC		 2846 }
2847 else {
a8652edf
TC		 2848 if ($opts{fill}) {
2849 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2850 # assume it's a hash ref
2851 require 'Imager/Fill.pm';
2852 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2853 $self->{ERRSTR} = $Imager::ERRSTR;
2854 return;
2855 }
2856 }
2857 i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2858 $opts{'d2'}, $opts{fill}{fill});
0d321238
TC		 2859 }
2860 else {
a8652edf
TC		 2861 my $color = _color($opts{'color'});
2862 unless ($color) {
2863 $self->{ERRSTR} = $Imager::ERRSTR;
40068b33
TC		 2864 return;
2865 }
2866 if ($opts{filled}) {
2867 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2868 $opts{'d1'}, $opts{'d2'}, $color);
2869 }
2870 else {
2871 if ($opts{d1} == 0 && $opts{d2} == 361) {
2872 $good = i_circle_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $color);
2873 }
2874 else {
2875 $good = i_arc_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $opts{d1}, $opts{d2}, $color);
2876 }
a8652edf 2877 }
0d321238 2878 }
f1ac5027 2879 }
40068b33
TC		 2880 unless ($good) {
2881 $self->_set_error($self->_error_as_msg);
2882 return;
2883 }
f1ac5027 2884
02d1d628
AMH		 2885 return $self;
2886}
2887
aa833c97
AMH		 2888# Draws a line from one point to the other
2889# the endpoint is set if the endp parameter is set which it is by default.
2890# to turn of the endpoint being set use endp=>0 when calling line.
02d1d628
AMH		 2891
2892sub line {
2893 my $self=shift;
2894 my $dflcl=i_color_new(0,0,0,0);
aa833c97
AMH		 2895 my %opts=(color=>$dflcl,
2896 endp => 1,
2897 @_);
02d1d628
AMH		 2898 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2899
2900 unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2901 unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2902
3a9a4241 2903 my $color = _color($opts{'color'});
aa833c97
AMH		 2904 unless ($color) {
2905 $self->{ERRSTR} = $Imager::ERRSTR;
2906 return;
3a9a4241 2907 }
aa833c97 2908
3a9a4241 2909 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628 2910 if ($opts{antialias}) {
aa833c97 2911 i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
b437ce0a 2912 $color, $opts{endp});
02d1d628 2913 } else {
aa833c97
AMH		 2914 i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2915 $color, $opts{endp});
02d1d628
AMH		 2916 }
2917 return $self;
2918}
2919
2920# Draws a line between an ordered set of points - It more or less just transforms this
2921# into a list of lines.
2922
2923sub polyline {
2924 my $self=shift;
2925 my ($pt,$ls,@points);
2926 my $dflcl=i_color_new(0,0,0,0);
2927 my %opts=(color=>$dflcl,@_);
2928
2929 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2930
2931 if (exists($opts{points})) { @points=@{$opts{points}}; }
2932 if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2933 @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2934 }
2935
2936# print Dumper(\@points);
2937
3a9a4241
TC		 2938 my $color = _color($opts{'color'});
2939 unless ($color) {
2940 $self->{ERRSTR} = $Imager::ERRSTR;
2941 return;
2942 }
2943 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628
AMH		 2944 if ($opts{antialias}) {
2945 for $pt(@points) {
3a9a4241 2946 if (defined($ls)) {
b437ce0a 2947 i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
3a9a4241 2948 }
02d1d628
AMH		 2949 $ls=$pt;
2950 }
2951 } else {
2952 for $pt(@points) {
3a9a4241 2953 if (defined($ls)) {
aa833c97 2954 i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
3a9a4241 2955 }
02d1d628
AMH		 2956 $ls=$pt;
2957 }
2958 }
2959 return $self;
2960}
2961
d0e7bfee
AMH		 2962sub polygon {
2963 my $self = shift;
2964 my ($pt,$ls,@points);
2965 my $dflcl = i_color_new(0,0,0,0);
2966 my %opts = (color=>$dflcl, @_);
2967
2968 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2969
2970 if (exists($opts{points})) {
2971 $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2972 $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2973 }
2974
2975 if (!exists $opts{'x'} or !exists $opts{'y'}) {
2976 $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2977 }
2978
43c5dacb
TC		 2979 if ($opts{'fill'}) {
2980 unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2981 # assume it's a hash ref
2982 require 'Imager/Fill.pm';
2983 unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2984 $self->{ERRSTR} = $Imager::ERRSTR;
2985 return undef;
2986 }
2987 }
2988 i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2989 $opts{'fill'}{'fill'});
2990 }
2991 else {
3a9a4241
TC		 2992 my $color = _color($opts{'color'});
2993 unless ($color) {
2994 $self->{ERRSTR} = $Imager::ERRSTR;
2995 return;
2996 }
2997 i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
43c5dacb
TC		 2998 }
2999
d0e7bfee
AMH		 3000 return $self;
3001}
3002
3003
3004# this the multipoint bezier curve
02d1d628
AMH		 3005# this is here more for testing that actual usage since
3006# this is not a good algorithm. Usually the curve would be
3007# broken into smaller segments and each done individually.
3008
3009sub polybezier {
3010 my $self=shift;
3011 my ($pt,$ls,@points);
3012 my $dflcl=i_color_new(0,0,0,0);
3013 my %opts=(color=>$dflcl,@_);
3014
3015 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3016
3017 if (exists $opts{points}) {
3018 $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
3019 $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
3020 }
3021
3022 unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
3023 $self->{ERRSTR}='Missing or invalid points.';
3024 return;
3025 }
3026
3a9a4241
TC		 3027 my $color = _color($opts{'color'});
3028 unless ($color) {
3029 $self->{ERRSTR} = $Imager::ERRSTR;
3030 return;
3031 }
3032 i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
02d1d628
AMH		 3033 return $self;
3034}
3035
cc6483e0
TC		 3036sub flood_fill {
3037 my $self = shift;
3038 my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
aa833c97
AMH		 3039 my $rc;
3040
9d540150 3041 unless (exists $opts{'x'} && exists $opts{'y'}) {
cc6483e0
TC		 3042 $self->{ERRSTR} = "missing seed x and y parameters";
3043 return undef;
3044 }
07d70837 3045
3efb0915
TC		 3046 if ($opts{border}) {
3047 my $border = _color($opts{border});
3048 unless ($border) {
3049 $self->_set_error($Imager::ERRSTR);
3050 return;
3051 }
3052 if ($opts{fill}) {
3053 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3054 # assume it's a hash ref
3055 require Imager::Fill;
3056 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3057 $self->{ERRSTR} = $Imager::ERRSTR;
3058 return;
3059 }
569795e8 3060 }
3efb0915
TC		 3061 $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3062 $opts{fill}{fill}, $border);
3063 }
3064 else {
3065 my $color = _color($opts{'color'});
3066 unless ($color) {
3067 $self->{ERRSTR} = $Imager::ERRSTR;
3068 return;
3069 }
3070 $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3071 $color, $border);
3072 }
3073 if ($rc) {
3074 return $self;
3075 }
3076 else {
3077 $self->{ERRSTR} = $self->_error_as_msg();
3078 return;
cc6483e0 3079 }
cc6483e0
TC		 3080 }
3081 else {
3efb0915
TC		 3082 if ($opts{fill}) {
3083 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3084 # assume it's a hash ref
3085 require 'Imager/Fill.pm';
3086 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3087 $self->{ERRSTR} = $Imager::ERRSTR;
3088 return;
3089 }
3090 }
3091 $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3092 }
3093 else {
3094 my $color = _color($opts{'color'});
3095 unless ($color) {
3096 $self->{ERRSTR} = $Imager::ERRSTR;
3097 return;
3098 }
3099 $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3100 }
3101 if ($rc) {
3102 return $self;
3103 }
3104 else {
3105 $self->{ERRSTR} = $self->_error_as_msg();
aa833c97 3106 return;
3a9a4241 3107 }
3efb0915 3108 }
cc6483e0
TC		 3109}
3110
591b5954 3111sub setpixel {
b3cdc973 3112 my ($self, %opts) = @_;
591b5954 3113
b3cdc973
TC		 3114 my $color = $opts{color};
3115 unless (defined $color) {
3116 $color = $self->{fg};
3117 defined $color or $color = NC(255, 255, 255);
3118 }
3119
3120 unless (ref $color && UNIVERSAL::isa($color, "Imager::Color")) {
3121 $color = _color($color)
3122 or return undef;
3123 }
591b5954
TC		 3124
3125 unless (exists $opts{'x'} && exists $opts{'y'}) {
3126 $self->{ERRSTR} = 'missing x and y parameters';
3127 return undef;
3128 }
3129
3130 my $x = $opts{'x'};
3131 my $y = $opts{'y'};
591b5954
TC		 3132 if (ref $x && ref $y) {
3133 unless (@$x == @$y) {
9650c424 3134 $self->{ERRSTR} = 'length of x and y mismatch';
837a4b43 3135 return;
591b5954 3136 }
837a4b43 3137 my $set = 0;
591b5954
TC		 3138 if ($color->isa('Imager::Color')) {
3139 for my $i (0..$#{$opts{'x'}}) {
837a4b43
TC		 3140 i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3141 or ++$set;
591b5954
TC		 3142 }
3143 }
3144 else {
3145 for my $i (0..$#{$opts{'x'}}) {
837a4b43
TC		 3146 i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3147 or ++$set;
591b5954
TC		 3148 }
3149 }
837a4b43
TC		 3150 $set or return;
3151 return $set;
591b5954
TC		 3152 }
3153 else {
3154 if ($color->isa('Imager::Color')) {
837a4b43
TC		 3155 i_ppix($self->{IMG}, $x, $y, $color)
3156 and return;
591b5954
TC		 3157 }
3158 else {
837a4b43
TC		 3159 i_ppixf($self->{IMG}, $x, $y, $color)
3160 and return;
591b5954
TC		 3161 }
3162 }
3163
3164 $self;
3165}
3166
3167sub getpixel {
3168 my $self = shift;
3169
a9fa203f 3170 my %opts = ( "type"=>'8bit', @_);
591b5954
TC		 3171
3172 unless (exists $opts{'x'} && exists $opts{'y'}) {
3173 $self->{ERRSTR} = 'missing x and y parameters';
3174 return undef;
3175 }
3176
3177 my $x = $opts{'x'};
3178 my $y = $opts{'y'};
3179 if (ref $x && ref $y) {
3180 unless (@$x == @$y) {
3181 $self->{ERRSTR} = 'length of x and y mismatch';
3182 return undef;
3183 }
3184 my @result;
a9fa203f 3185 if ($opts{"type"} eq '8bit') {
591b5954
TC		 3186 for my $i (0..$#{$opts{'x'}}) {
3187 push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3188 }
3189 }
3190 else {
3191 for my $i (0..$#{$opts{'x'}}) {
3192 push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3193 }
3194 }
3195 return wantarray ? @result : \@result;
3196 }
3197 else {
a9fa203f 3198 if ($opts{"type"} eq '8bit') {
591b5954
TC		 3199 return i_get_pixel($self->{IMG}, $x, $y);
3200 }
3201 else {
3202 return i_gpixf($self->{IMG}, $x, $y);
3203 }
3204 }
3205
3206 $self;
3207}
3208
ca4d914e
TC		 3209sub getscanline {
3210 my $self = shift;
3211 my %opts = ( type => '8bit', x=>0, @_);
3212
4cda4e76
TC		 3213 $self->_valid_image or return;
3214
ca4d914e
TC		 3215 defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3216
3217 unless (defined $opts{'y'}) {
3218 $self->_set_error("missing y parameter");
3219 return;
3220 }
3221
3222 if ($opts{type} eq '8bit') {
3223 return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
4cda4e76 3224 $opts{'y'});
ca4d914e
TC		 3225 }
3226 elsif ($opts{type} eq 'float') {
3227 return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
4cda4e76
TC		 3228 $opts{'y'});
3229 }
3230 elsif ($opts{type} eq 'index') {
3231 unless (i_img_type($self->{IMG})) {
3232 $self->_set_error("type => index only valid on paletted images");
3233 return;
3234 }
3235 return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3236 $opts{'y'});
ca4d914e
TC		 3237 }
3238 else {
3239 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3240 return;
3241 }
3242}
3243
3244sub setscanline {
3245 my $self = shift;
3246 my %opts = ( x=>0, @_);
3247
4cda4e76
TC		 3248 $self->_valid_image or return;
3249
ca4d914e
TC		 3250 unless (defined $opts{'y'}) {
3251 $self->_set_error("missing y parameter");
3252 return;
3253 }
3254
3255 if (!$opts{type}) {
3256 if (ref $opts{pixels} && @{$opts{pixels}}) {
3257 # try to guess the type
3258 if ($opts{pixels}[0]->isa('Imager::Color')) {
3259 $opts{type} = '8bit';
3260 }
3261 elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3262 $opts{type} = 'float';
3263 }
3264 else {
3265 $self->_set_error("missing type parameter and could not guess from pixels");
3266 return;
3267 }
3268 }
3269 else {
3270 # default
3271 $opts{type} = '8bit';
3272 }
3273 }
3274
3275 if ($opts{type} eq '8bit') {
3276 if (ref $opts{pixels}) {
3277 return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3278 }
3279 else {
3280 return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3281 }
3282 }
3283 elsif ($opts{type} eq 'float') {
3284 if (ref $opts{pixels}) {
3285 return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3286 }
3287 else {
3288 return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3289 }
3290 }
4cda4e76
TC		 3291 elsif ($opts{type} eq 'index') {
3292 if (ref $opts{pixels}) {
3293 return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3294 }
3295 else {
3296 return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3297 }
3298 }
ca4d914e
TC		 3299 else {
3300 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3301 return;
3302 }
3303}
3304
3305sub getsamples {
3306 my $self = shift;
bd8052a6 3307 my %opts = ( type => '8bit', x=>0, offset => 0, @_);
ca4d914e
TC		 3308
3309 defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3310
3311 unless (defined $opts{'y'}) {
3312 $self->_set_error("missing y parameter");
3313 return;
3314 }
3315
3316 unless ($opts{channels}) {
3317 $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3318 }
3319
bd8052a6
TC		 3320 if ($opts{target}) {
3321 my $target = $opts{target};
3322 my $offset = $opts{offset};
3323 if ($opts{type} eq '8bit') {
3324 my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3325 $opts{y}, @{$opts{channels}})
3326 or return;
3327 @{$target}{$offset .. $offset + @samples - 1} = @samples;
3328 return scalar(@samples);
3329 }
3330 elsif ($opts{type} eq 'float') {
3331 my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3332 $opts{y}, @{$opts{channels}});
3333 @{$target}{$offset .. $offset + @samples - 1} = @samples;
3334 return scalar(@samples);
3335 }
3336 elsif ($opts{type} =~ /^(\d+)bit$/) {
3337 my $bits = $1;
3338
3339 my @data;
3340 my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3341 $opts{y}, $bits, $target,
3342 $offset, @{$opts{channels}});
3343 unless (defined $count) {
3344 $self->_set_error(Imager->_error_as_msg);
3345 return;
3346 }
3347
3348 return $count;
3349 }
3350 else {
3351 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3352 return;
3353 }
ca4d914e
TC		 3354 }
3355 else {
bd8052a6
TC		 3356 if ($opts{type} eq '8bit') {
3357 return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3358 $opts{y}, @{$opts{channels}});
3359 }
3360 elsif ($opts{type} eq 'float') {
3361 return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3362 $opts{y}, @{$opts{channels}});
3363 }
3364 elsif ($opts{type} =~ /^(\d+)bit$/) {
3365 my $bits = $1;
3366
3367 my @data;
3368 i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3369 $opts{y}, $bits, \@data, 0, @{$opts{channels}})
3370 or return;
3371 return @data;
3372 }
3373 else {
3374 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3375 return;
3376 }
3377 }
3378}
3379
3380sub setsamples {
3381 my $self = shift;
3382 my %opts = ( x => 0, offset => 0, @_ );
3383
3384 unless ($self->{IMG}) {
3385 $self->_set_error('setsamples: empty input image');
3386 return;
3387 }
3388
3389 unless(defined $opts{data} && ref $opts{data}) {
3390 $self->_set_error('setsamples: data parameter missing or invalid');
ca4d914e
TC		 3391 return;
3392 }
bd8052a6
TC		 3393
3394 unless ($opts{channels}) {
3395 $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3396 }
3397
3398 unless ($opts{type} && $opts{type} =~ /^(\d+)bit$/) {
3399 $self->_set_error('setsamples: type parameter missing or invalid');
3400 return;
3401 }
3402 my $bits = $1;
3403
3404 unless (defined $opts{width}) {
3405 $opts{width} = $self->getwidth() - $opts{x};
3406 }
3407
3408 my $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
3409 $opts{channels}, $opts{data}, $opts{offset},
3410 $opts{width});
3411 unless (defined $count) {
3412 $self->_set_error(Imager->_error_as_msg);
3413 return;
3414 }
3415
3416 return $count;
ca4d914e
TC		 3417}
3418
f5991c03
TC		 3419# make an identity matrix of the given size
3420sub _identity {
3421 my ($size) = @_;
3422
3423 my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3424 for my $c (0 .. ($size-1)) {
3425 $matrix->[$c][$c] = 1;
3426 }
3427 return $matrix;
3428}
3429
3430# general function to convert an image
3431sub convert {
3432 my ($self, %opts) = @_;
3433 my $matrix;
3434
34b3f7e6
TC		 3435 unless (defined wantarray) {
3436 my @caller = caller;
3437 warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3438 return;
3439 }
3440
f5991c03
TC		 3441 # the user can either specify a matrix or preset
3442 # the matrix overrides the preset
3443 if (!exists($opts{matrix})) {
3444 unless (exists($opts{preset})) {
3445 $self->{ERRSTR} = "convert() needs a matrix or preset";
3446 return;
3447 }
3448 else {
3449 if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3450 # convert to greyscale, keeping the alpha channel if any
3451 if ($self->getchannels == 3) {
3452 $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3453 }
3454 elsif ($self->getchannels == 4) {
3455 # preserve the alpha channel
3456 $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3457 [ 0, 0, 0, 1 ] ];
3458 }
3459 else {
3460 # an identity
3461 $matrix = _identity($self->getchannels);
3462 }
3463 }
3464 elsif ($opts{preset} eq 'noalpha') {
3465 # strip the alpha channel
3466 if ($self->getchannels == 2 or $self->getchannels == 4) {
3467 $matrix = _identity($self->getchannels);
3468 pop(@$matrix); # lose the alpha entry
3469 }
3470 else {
3471 $matrix = _identity($self->getchannels);
3472 }
3473 }
3474 elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3475 # extract channel 0
3476 $matrix = [ [ 1 ] ];
3477 }
3478 elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3479 $matrix = [ [ 0, 1 ] ];
3480 }
3481 elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3482 $matrix = [ [ 0, 0, 1 ] ];
3483 }
3484 elsif ($opts{preset} eq 'alpha') {
3485 if ($self->getchannels == 2 or $self->getchannels == 4) {
3486 $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3487 }
3488 else {
3489 # the alpha is just 1 <shrug>
3490 $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3491 }
3492 }
3493 elsif ($opts{preset} eq 'rgb') {
3494 if ($self->getchannels == 1) {
3495 $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3496 }
3497 elsif ($self->getchannels == 2) {
3498 # preserve the alpha channel
3499 $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3500 }
3501 else {
3502 $matrix = _identity($self->getchannels);
3503 }
3504 }
3505 elsif ($opts{preset} eq 'addalpha') {
3506 if ($self->getchannels == 1) {
3507 $matrix = _identity(2);
3508 }
3509 elsif ($self->getchannels == 3) {
3510 $matrix = _identity(4);
3511 }
3512 else {
3513 $matrix = _identity($self->getchannels);
3514 }
3515 }
3516 else {
3517 $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3518 return undef;
3519 }
3520 }
3521 }
3522 else {
3523 $matrix = $opts{matrix};
3524 }
3525
d5477d3d
TC		 3526 my $new = Imager->new;
3527 $new->{IMG} = i_convert($self->{IMG}, $matrix);
3528 unless ($new->{IMG}) {
f5991c03
TC		 3529 # most likely a bad matrix
3530 $self->{ERRSTR} = _error_as_msg();
3531 return undef;
3532 }
3533 return $new;
3534}
40eba1ea 3535
b47464c1
TC		 3536# combine channels from multiple input images, a class method
3537sub combine {
3538 my ($class, %opts) = @_;
3539
3540 my $src = delete $opts{src};
3541 unless ($src) {
3542 $class->_set_error("src parameter missing");
3543 return;
3544 }
3545 my @imgs;
3546 my $index = 0;
3547 for my $img (@$src) {
3548 unless (eval { $img->isa("Imager") }) {
3549 $class->_set_error("src must contain image objects");
3550 return;
3551 }
3552 unless ($img->{IMG}) {
3553 $class->_set_error("empty input image");
3554 return;
3555 }
3556 push @imgs, $img->{IMG};
3557 }
3558 my $result;
3559 if (my $channels = delete $opts{channels}) {
3560 $result = i_combine(\@imgs, $channels);
3561 }
3562 else {
3563 $result = i_combine(\@imgs);
3564 }
3565 unless ($result) {
3566 $class->_set_error($class->_error_as_msg);
3567 return;
3568 }
3569
3570 my $img = $class->new;
3571 $img->{IMG} = $result;
3572
3573 return $img;
3574}
3575
40eba1ea 3576
40eba1ea 3577# general function to map an image through lookup tables
9495ee93 3578
40eba1ea
AMH		 3579sub map {
3580 my ($self, %opts) = @_;
9495ee93 3581 my @chlist = qw( red green blue alpha );
40eba1ea
AMH		 3582
3583 if (!exists($opts{'maps'})) {
3584 # make maps from channel maps
3585 my $chnum;
3586 for $chnum (0..$#chlist) {
9495ee93
AMH		 3587 if (exists $opts{$chlist[$chnum]}) {
3588 $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3589 } elsif (exists $opts{'all'}) {
3590 $opts{'maps'}[$chnum] = $opts{'all'};
3591 }
40eba1ea
AMH		 3592 }
3593 }
3594 if ($opts{'maps'} and $self->{IMG}) {
3595 i_map($self->{IMG}, $opts{'maps'} );
3596 }
3597 return $self;
3598}
3599
dff75dee
TC		 3600sub difference {
3601 my ($self, %opts) = @_;
3602
3603 defined $opts{mindist} or $opts{mindist} = 0;
3604
3605 defined $opts{other}
3606 or return $self->_set_error("No 'other' parameter supplied");
3607 defined $opts{other}{IMG}
3608 or return $self->_set_error("No image data in 'other' image");
3609
3610 $self->{IMG}
3611 or return $self->_set_error("No image data");
3612
3613 my $result = Imager->new;
3614 $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3615 $opts{mindist})
3616 or return $self->_set_error($self->_error_as_msg());
3617
3618 return $result;
3619}
3620
02d1d628
AMH		 3621# destructive border - image is shrunk by one pixel all around
3622
3623sub border {
3624 my ($self,%opts)=@_;
3625 my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3626 $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3627}
3628
3629
3630# Get the width of an image
3631
3632sub getwidth {
3633 my $self = shift;
3b000586
TC		 3634
3635 if (my $raw = $self->{IMG}) {
3636 return i_img_get_width($raw);
3637 }
3638 else {
3639 $self->{ERRSTR} = 'image is empty'; return undef;
3640 }
02d1d628
AMH		 3641}
3642
3643# Get the height of an image
3644
3645sub getheight {
3646 my $self = shift;
3b000586
TC		 3647
3648 if (my $raw = $self->{IMG}) {
3649 return i_img_get_height($raw);
3650 }
3651 else {
3652 $self->{ERRSTR} = 'image is empty'; return undef;
3653 }
02d1d628
AMH		 3654}
3655
3656# Get number of channels in an image
3657
3658sub getchannels {
3659 my $self = shift;
3660 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3661 return i_img_getchannels($self->{IMG});
3662}
3663
3664# Get channel mask
3665
3666sub getmask {
3667 my $self = shift;
3668 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3669 return i_img_getmask($self->{IMG});
3670}
3671
3672# Set channel mask
3673
3674sub setmask {
3675 my $self = shift;
3676 my %opts = @_;
35f40526
TC		 3677 if (!defined($self->{IMG})) {
3678 $self->{ERRSTR} = 'image is empty';
3679 return undef;
3680 }
3681 unless (defined $opts{mask}) {
3682 $self->_set_error("mask parameter required");
3683 return;
3684 }
02d1d628 3685 i_img_setmask( $self->{IMG} , $opts{mask} );
35f40526
TC		 3686
3687 1;
02d1d628
AMH		 3688}
3689
3690# Get number of colors in an image
3691
3692sub getcolorcount {
3693 my $self=shift;
9d540150 3694 my %opts=('maxcolors'=>2**30,@_);
02d1d628
AMH		 3695 if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
3696 my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3697 return ($rc==-1? undef : $rc);
3698}
3699
fe622da1
TC		 3700# Returns a reference to a hash. The keys are colour named (packed) and the
3701# values are the number of pixels in this colour.
3702sub getcolorusagehash {
a60905e4
TC		 3703 my $self = shift;
3704
3705 my %opts = ( maxcolors => 2**30, @_ );
3706 my $max_colors = $opts{maxcolors};
3707 unless (defined $max_colors && $max_colors > 0) {
3708 $self->_set_error('maxcolors must be a positive integer');
3709 return;
3710 }
3711
3712 unless (defined $self->{IMG}) {
3713 $self->_set_error('empty input image');
3714 return;
3715 }
3716
3717 my $channels= $self->getchannels;
3718 # We don't want to look at the alpha channel, because some gifs using it
3719 # doesn't define it for every colour (but only for some)
3720 $channels -= 1 if $channels == 2 or $channels == 4;
3721 my %color_use;
3722 my $height = $self->getheight;
3723 for my $y (0 .. $height - 1) {
3724 my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
3725 while (length $colors) {
3726 $color_use{ substr($colors, 0, $channels, '') }++;
fe622da1 3727 }
a60905e4
TC		 3728 keys %color_use > $max_colors
3729 and return;
3730 }
3731 return \%color_use;
fe622da1
TC		 3732}
3733
3734# This will return a ordered array of the colour usage. Kind of the sorted
3735# version of the values of the hash returned by getcolorusagehash.
3736# You might want to add safety checks and change the names, etc...
3737sub getcolorusage {
a60905e4
TC		 3738 my $self = shift;
3739
3740 my %opts = ( maxcolors => 2**30, @_ );
3741 my $max_colors = $opts{maxcolors};
3742 unless (defined $max_colors && $max_colors > 0) {
3743 $self->_set_error('maxcolors must be a positive integer');
3744 return;
3745 }
3746
3747 unless (defined $self->{IMG}) {
3748 $self->_set_error('empty input image');
3749 return undef;
3750 }
3751
3752 return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
fe622da1
TC		 3753}
3754
02d1d628
AMH		 3755# draw string to an image
3756
3757sub string {
3758 my $self = shift;
3759 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3760
3761 my %input=('x'=>0, 'y'=>0, @_);
4314a320 3762 defined($input{string}) or $input{string} = $input{text};
02d1d628 3763
e922ae66 3764 unless(defined $input{string}) {
02d1d628
AMH		 3765 $self->{ERRSTR}="missing required parameter 'string'";
3766 return;
3767 }
3768
3769 unless($input{font}) {
3770 $self->{ERRSTR}="missing required parameter 'font'";
3771 return;
3772 }
3773
faa9b3e7 3774 unless ($input{font}->draw(image=>$self, %input)) {
faa9b3e7
TC		 3775 return;
3776 }
02d1d628
AMH		 3777
3778 return $self;
3779}
3780
a7ccc5e2
TC		 3781sub align_string {
3782 my $self = shift;
e922ae66
TC		 3783
3784 my $img;
3785 if (ref $self) {
3786 unless ($self->{IMG}) {
3787 $self->{ERRSTR}='empty input image';
3788 return;
3789 }
c9cb3397 3790 $img = $self;
e922ae66
TC		 3791 }
3792 else {
3793 $img = undef;
3794 }
a7ccc5e2
TC		 3795
3796 my %input=('x'=>0, 'y'=>0, @_);
120f4287
TC		 3797 defined $input{string}
3798 or $input{string} = $input{text};
a7ccc5e2
TC		 3799
3800 unless(exists $input{string}) {
e922ae66 3801 $self->_set_error("missing required parameter 'string'");
a7ccc5e2
TC		 3802 return;
3803 }
3804
3805 unless($input{font}) {
e922ae66 3806 $self->_set_error("missing required parameter 'font'");
a7ccc5e2
TC		 3807 return;
3808 }
3809
3810 my @result;
e922ae66 3811 unless (@result = $input{font}->align(image=>$img, %input)) {
a7ccc5e2
TC		 3812 return;
3813 }
3814
3815 return wantarray ? @result : $result[0];
3816}
3817
77157728
TC		 3818my @file_limit_names = qw/width height bytes/;
3819
3820sub set_file_limits {
3821 shift;
3822
3823 my %opts = @_;
3824 my %values;
3825
3826 if ($opts{reset}) {
3827 @values{@file_limit_names} = (0) x @file_limit_names;
3828 }
3829 else {
3830 @values{@file_limit_names} = i_get_image_file_limits();
3831 }
3832
3833 for my $key (keys %values) {
3834 defined $opts{$key} and $values{$key} = $opts{$key};
3835 }
3836
3837 i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3838}
3839
3840sub get_file_limits {
3841 i_get_image_file_limits();
3842}
3843
02d1d628
AMH		 3844# Shortcuts that can be exported
3845
3846sub newcolor { Imager::Color->new(@_); }
3847sub newfont { Imager::Font->new(@_); }
4697b0b9
TC		 3848sub NCF {
3849 require Imager::Color::Float;
3850 return Imager::Color::Float->new(@_);
3851}
02d1d628
AMH		 3852
3853*NC=*newcolour=*newcolor;
3854*NF=*newfont;
3855
3856*open=\&read;
3857*circle=\&arc;
3858
3859
3860#### Utility routines
3861
faa9b3e7
TC		 3862sub errstr {
3863 ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3864}
02d1d628 3865
10461f9a
TC		 3866sub _set_error {
3867 my ($self, $msg) = @_;
3868
3869 if (ref $self) {
3870 $self->{ERRSTR} = $msg;
3871 }
3872 else {
3873 $ERRSTR = $msg;
3874 }
dff75dee 3875 return;
10461f9a
TC		 3876}
3877
02d1d628
AMH		 3878# Default guess for the type of an image from extension
3879
3880sub def_guess_type {
3881 my $name=lc(shift);
3882 my $ext;
3883 $ext=($name =~ m/\.([^\.]+)$/)[0];
3884 return 'tiff' if ($ext =~ m/^tiff?$/);
3885 return 'jpeg' if ($ext =~ m/^jpe?g$/);
3886 return 'pnm' if ($ext =~ m/^p[pgb]m$/);
3887 return 'png' if ($ext eq "png");
705fd961 3888 return 'bmp' if ($ext eq "bmp" || $ext eq "dib");
1ec86afa 3889 return 'tga' if ($ext eq "tga");
d5477d3d 3890 return 'sgi' if ($ext eq "rgb" || $ext eq "bw" || $ext eq "sgi" || $ext eq "rgba");
02d1d628 3891 return 'gif' if ($ext eq "gif");
10461f9a 3892 return 'raw' if ($ext eq "raw");
2b405c9e 3893 return lc $ext; # best guess
02d1d628
AMH		 3894 return ();
3895}
3896
9b1ec2b8
TC		 3897sub combines {
3898 return @combine_types;
3899}
3900
02d1d628
AMH		 3901# get the minimum of a list
3902
bf1573f9 3903sub _min {
02d1d628
AMH		 3904 my $mx=shift;
3905 for(@_) { if ($_<$mx) { $mx=$_; }}
3906 return $mx;
3907}
3908
3909# get the maximum of a list
3910
bf1573f9 3911sub _max {
02d1d628
AMH		 3912 my $mx=shift;
3913 for(@_) { if ($_>$mx) { $mx=$_; }}
3914 return $mx;
3915}
3916
3917# string stuff for iptc headers
3918
bf1573f9 3919sub _clean {
02d1d628
AMH		 3920 my($str)=$_[0];
3921 $str = substr($str,3);
3922 $str =~ s/[\n\r]//g;
3923 $str =~ s/\s+/ /g;
3924 $str =~ s/^\s//;
3925 $str =~ s/\s$//;
3926 return $str;
3927}
3928
3929# A little hack to parse iptc headers.
3930
3931sub parseiptc {
3932 my $self=shift;
3933 my(@sar,$item,@ar);
3934 my($caption,$photogr,$headln,$credit);
3935
3936 my $str=$self->{IPTCRAW};
3937
24ae6325
TC		 3938 defined $str
3939 or return;
02d1d628
AMH		 3940
3941 @ar=split(/8BIM/,$str);
3942
3943 my $i=0;
3944 foreach (@ar) {
3945 if (/^\004\004/) {
3946 @sar=split(/\034\002/);
3947 foreach $item (@sar) {
cdd23610 3948 if ($item =~ m/^x/) {
bf1573f9 3949 $caption = _clean($item);
02d1d628
AMH		 3950 $i++;
3951 }
cdd23610 3952 if ($item =~ m/^P/) {
bf1573f9 3953 $photogr = _clean($item);
02d1d628
AMH		 3954 $i++;
3955 }
cdd23610 3956 if ($item =~ m/^i/) {
bf1573f9 3957 $headln = _clean($item);
02d1d628
AMH		 3958 $i++;
3959 }
cdd23610 3960 if ($item =~ m/^n/) {
bf1573f9 3961 $credit = _clean($item);
02d1d628
AMH		 3962 $i++;
3963 }
3964 }
3965 }
3966 }
3967 return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
3968}
3969
92bda632
TC		 3970sub Inline {
3971 my ($lang) = @_;
3972
3973 $lang eq 'C'
3974 or die "Only C language supported";
3975
3976 require Imager::ExtUtils;
3977 return Imager::ExtUtils->inline_config;
3978}
02d1d628 3979
ffddd407
TC		 3980# threads shouldn't try to close raw Imager objects
3981sub Imager::ImgRaw::CLONE_SKIP { 1 }
3982
2c331f9f
TC		 3983sub preload {
3984 # this serves two purposes:
3985 # - a class method to load the file support modules included with Image
3986 # (or were included, once the library dependent modules are split out)
3987 # - something for Module::ScanDeps to analyze
3988 # https://rt.cpan.org/Ticket/Display.html?id=6566
3989 local $@;
3990 eval { require Imager::File::GIF };
3991 eval { require Imager::File::JPEG };
3992 eval { require Imager::File::PNG };
3993 eval { require Imager::File::SGI };
3994 eval { require Imager::File::TIFF };
3995 eval { require Imager::File::ICO };
3996 eval { require Imager::Font::W32 };
3997 eval { require Imager::Font::FT2 };
3998 eval { require Imager::Font::T1 };
3999}
4000
1d7e3124
TC		 4001# backward compatibility for %formats
4002package Imager::FORMATS;
4003use strict;
4004use constant IX_FORMATS => 0;
4005use constant IX_LIST => 1;
4006use constant IX_INDEX => 2;
4007use constant IX_CLASSES => 3;
4008
4009sub TIEHASH {
4010 my ($class, $formats, $classes) = @_;
4011
4012 return bless [ $formats, [ ], 0, $classes ], $class;
4013}
4014
4015sub _check {
4016 my ($self, $key) = @_;
4017
4018 (my $file = $self->[IX_CLASSES]{$key} . ".pm") =~ s(::)(/)g;
4019 my $value;
5970bd39
TC		 4020 my $error;
4021 my $loaded = Imager::_load_file($file, \$error);
4022 if ($loaded) {
1d7e3124
TC		 4023 $value = 1;
4024 }
4025 else {
5970bd39
TC		 4026 if ($error =~ /^Can't locate /) {
4027 $error = "Can't locate $file";
4028 }
4029 $reader_load_errors{$key} = $writer_load_errors{$key} = $error;
1d7e3124
TC		 4030 $value = undef;
4031 }
4032 $self->[IX_FORMATS]{$key} = $value;
4033
4034 return $value;
4035}
4036
4037sub FETCH {
4038 my ($self, $key) = @_;
4039
4040 exists $self->[IX_FORMATS]{$key} and return $self->[IX_FORMATS]{$key};
4041
4042 $self->[IX_CLASSES]{$key} or return undef;
4043
4044 return $self->_check($key);
4045}
4046
4047sub STORE {
4048 die "%Imager::formats is not user monifiable";
4049}
4050
4051sub DELETE {
4052 die "%Imager::formats is not user monifiable";
4053}
4054
4055sub CLEAR {
4056 die "%Imager::formats is not user monifiable";
4057}
4058
4059sub EXISTS {
4060 my ($self, $key) = @_;
4061
4062 if (exists $self->[IX_FORMATS]{$key}) {
4063 my $value = $self->[IX_FORMATS]{$key}
4064 or return;
4065 return 1;
4066 }
4067
4068 $self->_check($key) or return 1==0;
4069
4070 return 1==1;
4071}
4072
4073sub FIRSTKEY {
4074 my ($self) = @_;
4075
4076 unless (@{$self->[IX_LIST]}) {
4077 # full populate it
d7e4ec85
TC		 4078 @{$self->[IX_LIST]} = grep $self->[IX_FORMATS]{$_},
4079 keys %{$self->[IX_FORMATS]};
1d7e3124
TC		 4080
4081 for my $key (keys %{$self->[IX_CLASSES]}) {
4082 $self->[IX_FORMATS]{$key} and next;
4083 $self->_check($key)
4084 and push @{$self->[IX_LIST]}, $key;
4085 }
4086 }
4087
4088 @{$self->[IX_LIST]} or return;
4089 $self->[IX_INDEX] = 1;
4090 return $self->[IX_LIST][0];
4091}
4092
4093sub NEXTKEY {
4094 my ($self) = @_;
4095
4096 $self->[IX_INDEX] < @{$self->[IX_LIST]}