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