projects / imager.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
change note for multi-image pnm read support
[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);
2b98ad88 176 $VERSION = '0.75';
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} ||
75812841
TC		 647 defined $hsh{readcb} ||
648 defined $hsh{data}) {
3c252111
TC		 649 # allow $img = Imager->new(file => $filename)
650 my %extras;
651
652 # type is already used as a parameter to new(), rename it for the
653 # call to read()
654 if ($hsh{filetype}) {
655 $extras{type} = $hsh{filetype};
656 }
657 unless ($self->read(%hsh, %extras)) {
658 $Imager::ERRSTR = $self->{ERRSTR};
659 return;
660 }
661 }
662
02d1d628
AMH		 663 return $self;
664}
665
02d1d628
AMH		 666# Copy an entire image with no changes
667# - if an image has magic the copy of it will not be magical
668
669sub copy {
670 my $self = shift;
671 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
672
34b3f7e6
TC		 673 unless (defined wantarray) {
674 my @caller = caller;
675 warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
676 return;
677 }
678
02d1d628 679 my $newcopy=Imager->new();
92bda632 680 $newcopy->{IMG} = i_copy($self->{IMG});
02d1d628
AMH		 681 return $newcopy;
682}
683
684# Paste a region
685
686sub paste {
687 my $self = shift;
92bda632
TC		 688
689 unless ($self->{IMG}) {
690 $self->_set_error('empty input image');
691 return;
692 }
693 my %input=(left=>0, top=>0, src_minx => 0, src_miny => 0, @_);
694 my $src = $input{img} || $input{src};
695 unless($src) {
696 $self->_set_error("no source image");
02d1d628
AMH		 697 return;
698 }
699 $input{left}=0 if $input{left} <= 0;
700 $input{top}=0 if $input{top} <= 0;
92bda632 701
02d1d628 702 my($r,$b)=i_img_info($src->{IMG});
92bda632
TC		 703 my ($src_left, $src_top) = @input{qw/src_minx src_miny/};
704 my ($src_right, $src_bottom);
705 if ($input{src_coords}) {
706 ($src_left, $src_top, $src_right, $src_bottom) = @{$input{src_coords}}
707 }
708 else {
709 if (defined $input{src_maxx}) {
710 $src_right = $input{src_maxx};
711 }
712 elsif (defined $input{width}) {
713 if ($input{width} <= 0) {
714 $self->_set_error("paste: width must me positive");
715 return;
716 }
717 $src_right = $src_left + $input{width};
718 }
719 else {
720 $src_right = $r;
721 }
35029411 722 if (defined $input{src_maxy}) {
92bda632
TC		 723 $src_bottom = $input{src_maxy};
724 }
725 elsif (defined $input{height}) {
726 if ($input{height} < 0) {
727 $self->_set_error("paste: height must be positive");
728 return;
729 }
730 $src_bottom = $src_top + $input{height};
731 }
732 else {
733 $src_bottom = $b;
734 }
735 }
736
737 $src_right > $r and $src_right = $r;
35029411 738 $src_bottom > $b and $src_bottom = $b;
92bda632
TC		 739
740 if ($src_right <= $src_left
741 || $src_bottom < $src_top) {
742 $self->_set_error("nothing to paste");
743 return;
744 }
02d1d628
AMH		 745
746 i_copyto($self->{IMG}, $src->{IMG},
92bda632
TC		 747 $src_left, $src_top, $src_right, $src_bottom,
748 $input{left}, $input{top});
749
02d1d628
AMH		 750 return $self; # What should go here??
751}
752
753# Crop an image - i.e. return a new image that is smaller
754
755sub crop {
756 my $self=shift;
757 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
676d5bb5 758
34b3f7e6
TC		 759 unless (defined wantarray) {
760 my @caller = caller;
761 warn "crop() called in void context - crop() returns the cropped image at $caller[1] line $caller[2]\n";
762 return;
763 }
764
676d5bb5 765 my %hsh=@_;
299a3866 766
676d5bb5
TC		 767 my ($w, $h, $l, $r, $b, $t) =
768 @hsh{qw(width height left right bottom top)};
299a3866 769
676d5bb5
TC		 770 # work through the various possibilities
771 if (defined $l) {
772 if (defined $w) {
773 $r = $l + $w;
774 }
775 elsif (!defined $r) {
776 $r = $self->getwidth;
777 }
778 }
779 elsif (defined $r) {
780 if (defined $w) {
781 $l = $r - $w;
782 }
783 else {
784 $l = 0;
785 }
786 }
787 elsif (defined $w) {
788 $l = int(0.5+($self->getwidth()-$w)/2);
789 $r = $l + $w;
790 }
791 else {
792 $l = 0;
793 $r = $self->getwidth;
794 }
795 if (defined $t) {
796 if (defined $h) {
797 $b = $t + $h;
798 }
799 elsif (!defined $b) {
800 $b = $self->getheight;
801 }
802 }
803 elsif (defined $b) {
804 if (defined $h) {
805 $t = $b - $h;
806 }
807 else {
808 $t = 0;
809 }
810 }
811 elsif (defined $h) {
812 $t=int(0.5+($self->getheight()-$h)/2);
813 $b=$t+$h;
814 }
815 else {
816 $t = 0;
817 $b = $self->getheight;
818 }
02d1d628
AMH		 819
820 ($l,$r)=($r,$l) if $l>$r;
821 ($t,$b)=($b,$t) if $t>$b;
822
676d5bb5
TC		 823 $l < 0 and $l = 0;
824 $r > $self->getwidth and $r = $self->getwidth;
825 $t < 0 and $t = 0;
826 $b > $self->getheight and $b = $self->getheight;
02d1d628 827
676d5bb5
TC		 828 if ($l == $r || $t == $b) {
829 $self->_set_error("resulting image would have no content");
830 return;
831 }
9fc9d0ca
TC		 832 if( $r < $l or $b < $t ) {
833 $self->_set_error("attempting to crop outside of the image");
834 return;
835 }
676d5bb5 836 my $dst = $self->_sametype(xsize=>$r-$l, ysize=>$b-$t);
02d1d628
AMH		 837
838 i_copyto($dst->{IMG},$self->{IMG},$l,$t,$r,$b,0,0);
839 return $dst;
840}
841
ec76939c
TC		 842sub _sametype {
843 my ($self, %opts) = @_;
844
845 $self->{IMG} or return $self->_set_error("Not a valid image");
846
847 my $x = $opts{xsize} || $self->getwidth;
848 my $y = $opts{ysize} || $self->getheight;
849 my $channels = $opts{channels} || $self->getchannels;
850
851 my $out = Imager->new;
852 if ($channels == $self->getchannels) {
853 $out->{IMG} = i_sametype($self->{IMG}, $x, $y);
854 }
855 else {
856 $out->{IMG} = i_sametype_chans($self->{IMG}, $x, $y, $channels);
857 }
858 unless ($out->{IMG}) {
859 $self->{ERRSTR} = $self->_error_as_msg;
860 return;
861 }
862
863 return $out;
864}
865
02d1d628
AMH		 866# Sets an image to a certain size and channel number
867# if there was previously data in the image it is discarded
868
869sub img_set {
870 my $self=shift;
871
faa9b3e7 872 my %hsh=(xsize=>100, ysize=>100, channels=>3, bits=>8, type=>'direct', @_);
02d1d628
AMH		 873
874 if (defined($self->{IMG})) {
faa9b3e7
TC		 875 # let IIM_DESTROY destroy it, it's possible this image is
876 # referenced from a virtual image (like masked)
877 #i_img_destroy($self->{IMG});
02d1d628
AMH		 878 undef($self->{IMG});
879 }
880
faa9b3e7
TC		 881 if ($hsh{type} eq 'paletted' || $hsh{type} eq 'pseudo') {
882 $self->{IMG} = i_img_pal_new($hsh{xsize}, $hsh{ysize}, $hsh{channels},
883 $hsh{maxcolors} || 256);
884 }
365ea842
TC		 885 elsif ($hsh{bits} eq 'double') {
886 $self->{IMG} = i_img_double_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
887 }
faa9b3e7
TC		 888 elsif ($hsh{bits} == 16) {
889 $self->{IMG} = i_img_16_new($hsh{xsize}, $hsh{ysize}, $hsh{channels});
890 }
891 else {
892 $self->{IMG}=Imager::ImgRaw::new($hsh{'xsize'}, $hsh{'ysize'},
893 $hsh{'channels'});
894 }
1501d9b3
TC		 895
896 unless ($self->{IMG}) {
897 $self->{ERRSTR} = Imager->_error_as_msg();
898 return;
899 }
900
901 $self;
faa9b3e7
TC		 902}
903
904# created a masked version of the current image
905sub masked {
906 my $self = shift;
907
908 $self or return undef;
909 my %opts = (left => 0,
910 top => 0,
911 right => $self->getwidth,
912 bottom => $self->getheight,
913 @_);
914 my $mask = $opts{mask} ? $opts{mask}{IMG} : undef;
915
916 my $result = Imager->new;
917 $result->{IMG} = i_img_masked_new($self->{IMG}, $mask, $opts{left},
918 $opts{top}, $opts{right} - $opts{left},
919 $opts{bottom} - $opts{top});
920 # keep references to the mask and base images so they don't
921 # disappear on us
922 $result->{DEPENDS} = [ $self->{IMG}, $mask ];
923
924 $result;
925}
926
927# convert an RGB image into a paletted image
928sub to_paletted {
929 my $self = shift;
930 my $opts;
931 if (@_ != 1 && !ref $_[0]) {
932 $opts = { @_ };
933 }
934 else {
935 $opts = shift;
936 }
937
34b3f7e6
TC		 938 unless (defined wantarray) {
939 my @caller = caller;
940 warn "to_paletted() called in void context - to_paletted() returns the converted image at $caller[1] line $caller[2]\n";
941 return;
942 }
943
faa9b3e7
TC		 944 my $result = Imager->new;
945 $result->{IMG} = i_img_to_pal($self->{IMG}, $opts);
946
947 #print "Type ", i_img_type($result->{IMG}), "\n";
948
1501d9b3
TC		 949 if ($result->{IMG}) {
950 return $result;
951 }
952 else {
953 $self->{ERRSTR} = $self->_error_as_msg;
954 return;
955 }
faa9b3e7
TC		 956}
957
958# convert a paletted (or any image) to an 8-bit/channel RGB images
959sub to_rgb8 {
960 my $self = shift;
961 my $result;
962
34b3f7e6
TC		 963 unless (defined wantarray) {
964 my @caller = caller;
b13bf7e8 965 warn "to_rgb8() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
34b3f7e6
TC		 966 return;
967 }
968
faa9b3e7
TC		 969 if ($self->{IMG}) {
970 $result = Imager->new;
971 $result->{IMG} = i_img_to_rgb($self->{IMG})
972 or undef $result;
973 }
974
975 return $result;
976}
977
837a4b43
TC		 978# convert a paletted (or any image) to an 8-bit/channel RGB images
979sub to_rgb16 {
980 my $self = shift;
981 my $result;
982
983 unless (defined wantarray) {
984 my @caller = caller;
985 warn "to_rgb16() called in void context - to_rgb8() returns the converted image at $caller[1] line $caller[2]\n";
986 return;
987 }
988
989 if ($self->{IMG}) {
990 $result = Imager->new;
991 $result->{IMG} = i_img_to_rgb16($self->{IMG})
992 or undef $result;
993 }
994
995 return $result;
996}
997
faa9b3e7
TC		 998sub addcolors {
999 my $self = shift;
1000 my %opts = (colors=>[], @_);
1001
32b97571
TC		 1002 unless ($self->{IMG}) {
1003 $self->_set_error("empty input image");
1004 return;
1005 }
1006
1007 my @colors = @{$opts{colors}}
1008 or return undef;
faa9b3e7 1009
32b97571
TC		 1010 for my $color (@colors) {
1011 $color = _color($color);
1012 unless ($color) {
1013 $self->_set_error($Imager::ERRSTR);
1014 return;
1015 }
1016 }
1017
1018 return i_addcolors($self->{IMG}, @colors);
faa9b3e7
TC		 1019}
1020
1021sub setcolors {
1022 my $self = shift;
1023 my %opts = (start=>0, colors=>[], @_);
faa9b3e7 1024
32b97571
TC		 1025 unless ($self->{IMG}) {
1026 $self->_set_error("empty input image");
1027 return;
1028 }
1029
1030 my @colors = @{$opts{colors}}
1031 or return undef;
1032
1033 for my $color (@colors) {
1034 $color = _color($color);
1035 unless ($color) {
1036 $self->_set_error($Imager::ERRSTR);
1037 return;
1038 }
1039 }
1040
1041 return i_setcolors($self->{IMG}, $opts{start}, @colors);
faa9b3e7
TC		 1042}
1043
1044sub getcolors {
1045 my $self = shift;
1046 my %opts = @_;
1047 if (!exists $opts{start} && !exists $opts{count}) {
1048 # get them all
1049 $opts{start} = 0;
1050 $opts{count} = $self->colorcount;
1051 }
1052 elsif (!exists $opts{count}) {
1053 $opts{count} = 1;
1054 }
1055 elsif (!exists $opts{start}) {
1056 $opts{start} = 0;
1057 }
1058
1059 $self->{IMG} and
1060 return i_getcolors($self->{IMG}, $opts{start}, $opts{count});
1061}
1062
1063sub colorcount {
1064 i_colorcount($_[0]{IMG});
1065}
1066
1067sub maxcolors {
1068 i_maxcolors($_[0]{IMG});
1069}
1070
1071sub findcolor {
1072 my $self = shift;
1073 my %opts = @_;
1074 $opts{color} or return undef;
1075
1076 $self->{IMG} and i_findcolor($self->{IMG}, $opts{color});
1077}
1078
1079sub bits {
1080 my $self = shift;
af3c2450
TC		 1081 my $bits = $self->{IMG} && i_img_bits($self->{IMG});
1082 if ($bits && $bits == length(pack("d", 1)) * 8) {
1083 $bits = 'double';
1084 }
1085 $bits;
faa9b3e7
TC		 1086}
1087
1088sub type {
1089 my $self = shift;
1090 if ($self->{IMG}) {
1091 return i_img_type($self->{IMG}) ? "paletted" : "direct";
1092 }
1093}
1094
1095sub virtual {
1096 my $self = shift;
1097 $self->{IMG} and i_img_virtual($self->{IMG});
1098}
1099
bd8052a6
TC		 1100sub is_bilevel {
1101 my ($self) = @_;
1102
1103 $self->{IMG} or return;
1104
1105 return i_img_is_monochrome($self->{IMG});
1106}
1107
faa9b3e7
TC		 1108sub tags {
1109 my ($self, %opts) = @_;
1110
1111 $self->{IMG} or return;
1112
1113 if (defined $opts{name}) {
1114 my @result;
1115 my $start = 0;
1116 my $found;
1117 while (defined($found = i_tags_find($self->{IMG}, $opts{name}, $start))) {
1118 push @result, (i_tags_get($self->{IMG}, $found))[1];
1119 $start = $found+1;
1120 }
1121 return wantarray ? @result : $result[0];
1122 }
1123 elsif (defined $opts{code}) {
1124 my @result;
1125 my $start = 0;
1126 my $found;
1127 while (defined($found = i_tags_findn($self->{IMG}, $opts{code}, $start))) {
1128 push @result, (i_tags_get($self->{IMG}, $found))[1];
1129 $start = $found+1;
1130 }
1131 return @result;
1132 }
1133 else {
1134 if (wantarray) {
1135 return map { [ i_tags_get($self->{IMG}, $_) ] } 0.. i_tags_count($self->{IMG})-1;
1136 }
1137 else {
1138 return i_tags_count($self->{IMG});
1139 }
1140 }
1141}
1142
1143sub addtag {
1144 my $self = shift;
1145 my %opts = @_;
1146
1147 return -1 unless $self->{IMG};
1148 if ($opts{name}) {
1149 if (defined $opts{value}) {
1150 if ($opts{value} =~ /^\d+$/) {
1151 # add as a number
1152 return i_tags_addn($self->{IMG}, $opts{name}, 0, $opts{value});
1153 }
1154 else {
1155 return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{value}, 0);
1156 }
1157 }
1158 elsif (defined $opts{data}) {
1159 # force addition as a string
1160 return i_tags_add($self->{IMG}, $opts{name}, 0, $opts{data}, 0);
1161 }
1162 else {
1163 $self->{ERRSTR} = "No value supplied";
1164 return undef;
1165 }
1166 }
1167 elsif ($opts{code}) {
1168 if (defined $opts{value}) {
1169 if ($opts{value} =~ /^\d+$/) {
1170 # add as a number
1171 return i_tags_addn($self->{IMG}, $opts{code}, 0, $opts{value});
1172 }
1173 else {
1174 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{value}, 0);
1175 }
1176 }
1177 elsif (defined $opts{data}) {
1178 # force addition as a string
1179 return i_tags_add($self->{IMG}, $opts{code}, 0, $opts{data}, 0);
1180 }
1181 else {
1182 $self->{ERRSTR} = "No value supplied";
1183 return undef;
1184 }
1185 }
1186 else {
1187 return undef;
1188 }
1189}
1190
1191sub deltag {
1192 my $self = shift;
1193 my %opts = @_;
1194
1195 return 0 unless $self->{IMG};
1196
9d540150
TC		 1197 if (defined $opts{'index'}) {
1198 return i_tags_delete($self->{IMG}, $opts{'index'});
faa9b3e7
TC		 1199 }
1200 elsif (defined $opts{name}) {
1201 return i_tags_delbyname($self->{IMG}, $opts{name});
1202 }
1203 elsif (defined $opts{code}) {
1204 return i_tags_delbycode($self->{IMG}, $opts{code});
1205 }
1206 else {
1207 $self->{ERRSTR} = "Need to supply index, name, or code parameter";
1208 return 0;
1209 }
02d1d628
AMH		 1210}
1211
97c4effc
TC		 1212sub settag {
1213 my ($self, %opts) = @_;
1214
1215 if ($opts{name}) {
1216 $self->deltag(name=>$opts{name});
1217 return $self->addtag(name=>$opts{name}, value=>$opts{value});
1218 }
1219 elsif (defined $opts{code}) {
1220 $self->deltag(code=>$opts{code});
1221 return $self->addtag(code=>$opts{code}, value=>$opts{value});
1222 }
1223 else {
1224 return undef;
1225 }
1226}
1227
10461f9a
TC		 1228
1229sub _get_reader_io {
84e51293 1230 my ($self, $input) = @_;
10461f9a 1231
e7ff1cf7
TC		 1232 if ($input->{io}) {
1233 return $input->{io}, undef;
1234 }
84e51293 1235 elsif ($input->{fd}) {
10461f9a
TC		 1236 return io_new_fd($input->{fd});
1237 }
1238 elsif ($input->{fh}) {
1239 my $fd = fileno($input->{fh});
de470892 1240 unless (defined $fd) {
10461f9a
TC		 1241 $self->_set_error("Handle in fh option not opened");
1242 return;
1243 }
1244 return io_new_fd($fd);
1245 }
1246 elsif ($input->{file}) {
1247 my $file = IO::File->new($input->{file}, "r");
1248 unless ($file) {
1249 $self->_set_error("Could not open $input->{file}: $!");
1250 return;
1251 }
1252 binmode $file;
1253 return (io_new_fd(fileno($file)), $file);
1254 }
1255 elsif ($input->{data}) {
1256 return io_new_buffer($input->{data});
1257 }
1258 elsif ($input->{callback} || $input->{readcb}) {
84e51293
AMH		 1259 if (!$input->{seekcb}) {
1260 $self->_set_error("Need a seekcb parameter");
10461f9a
TC		 1261 }
1262 if ($input->{maxbuffer}) {
1263 return io_new_cb($input->{writecb},
1264 $input->{callback} || $input->{readcb},
1265 $input->{seekcb}, $input->{closecb},
1266 $input->{maxbuffer});
1267 }
1268 else {
1269 return io_new_cb($input->{writecb},
1270 $input->{callback} || $input->{readcb},
1271 $input->{seekcb}, $input->{closecb});
1272 }
1273 }
1274 else {
1275 $self->_set_error("file/fd/fh/data/callback parameter missing");
1276 return;
1277 }
1278}
1279
1280sub _get_writer_io {
1281 my ($self, $input, $type) = @_;
1282
e7ff1cf7
TC		 1283 if ($input->{io}) {
1284 return $input->{io};
1285 }
1286 elsif ($input->{fd}) {
10461f9a
TC		 1287 return io_new_fd($input->{fd});
1288 }
1289 elsif ($input->{fh}) {
1290 my $fd = fileno($input->{fh});
de470892 1291 unless (defined $fd) {
10461f9a
TC		 1292 $self->_set_error("Handle in fh option not opened");
1293 return;
1294 }
9d1c4956
TC		 1295 # flush it
1296 my $oldfh = select($input->{fh});
1297 # flush anything that's buffered, and make sure anything else is flushed
1298 $| = 1;
1299 select($oldfh);
10461f9a
TC		 1300 return io_new_fd($fd);
1301 }
1302 elsif ($input->{file}) {
1303 my $fh = new IO::File($input->{file},"w+");
1304 unless ($fh) {
1305 $self->_set_error("Could not open file $input->{file}: $!");
1306 return;
1307 }
1308 binmode($fh) or die;
1309 return (io_new_fd(fileno($fh)), $fh);
1310 }
1311 elsif ($input->{data}) {
1312 return io_new_bufchain();
1313 }
1314 elsif ($input->{callback} || $input->{writecb}) {
1315 if ($input->{maxbuffer}) {
1316 return io_new_cb($input->{callback} || $input->{writecb},
1317 $input->{readcb},
1318 $input->{seekcb}, $input->{closecb},
1319 $input->{maxbuffer});
1320 }
1321 else {
1322 return io_new_cb($input->{callback} || $input->{writecb},
1323 $input->{readcb},
1324 $input->{seekcb}, $input->{closecb});
1325 }
1326 }
1327 else {
1328 $self->_set_error("file/fd/fh/data/callback parameter missing");
1329 return;
1330 }
1331}
1332
02d1d628
AMH		 1333# Read an image from file
1334
1335sub read {
1336 my $self = shift;
1337 my %input=@_;
02d1d628
AMH		 1338
1339 if (defined($self->{IMG})) {
faa9b3e7
TC		 1340 # let IIM_DESTROY do the destruction, since the image may be
1341 # referenced from elsewhere
1342 #i_img_destroy($self->{IMG});
02d1d628
AMH		 1343 undef($self->{IMG});
1344 }
1345
84e51293
AMH		 1346 my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
1347
10461f9a 1348 unless ($input{'type'}) {
66614d6e
TC		 1349 $input{'type'} = i_test_format_probe($IO, -1);
1350 }
84e51293
AMH		 1351
1352 unless ($input{'type'}) {
1353 $self->_set_error('type parameter missing and not possible to guess from extension');
10461f9a
TC		 1354 return undef;
1355 }
02d1d628 1356
53a6bbd4
TC		 1357 _reader_autoload($input{type});
1358
1359 if ($readers{$input{type}} && $readers{$input{type}}{single}) {
1360 return $readers{$input{type}}{single}->($self, $IO, %input);
1361 }
1362
66614d6e 1363 unless ($formats{$input{'type'}}) {
f245645a
TC		 1364 my $read_types = join ', ', sort Imager->read_types();
1365 $self->_set_error("format '$input{'type'}' not supported - formats $read_types available for reading");
66614d6e
TC		 1366 return;
1367 }
1368
2fe0b227 1369 # Setup data source
2fe0b227 1370 if ( $input{'type'} eq 'jpeg' ) {
527c0c3e 1371 ($self->{IMG},$self->{IPTCRAW}) = i_readjpeg_wiol( $IO );
2fe0b227 1372 if ( !defined($self->{IMG}) ) {
77157728 1373 $self->{ERRSTR}=$self->_error_as_msg(); return undef;
02d1d628 1374 }
2fe0b227
AMH		 1375 $self->{DEBUG} && print "loading a jpeg file\n";
1376 return $self;
1377 }
02d1d628 1378
d87dc9a4
TC		 1379 my $allow_incomplete = $input{allow_incomplete};
1380 defined $allow_incomplete or $allow_incomplete = 0;
9c106321 1381
2fe0b227 1382 if ( $input{'type'} eq 'tiff' ) {
8f8bd9aa
TC		 1383 my $page = $input{'page'};
1384 defined $page or $page = 0;
d87dc9a4 1385 $self->{IMG}=i_readtiff_wiol( $IO, $allow_incomplete, $page );
2fe0b227
AMH		 1386 if ( !defined($self->{IMG}) ) {
1387 $self->{ERRSTR}=$self->_error_as_msg(); return undef;
02d1d628 1388 }
2fe0b227
AMH		 1389 $self->{DEBUG} && print "loading a tiff file\n";
1390 return $self;
1391 }
02d1d628 1392
2fe0b227 1393 if ( $input{'type'} eq 'pnm' ) {
d87dc9a4 1394 $self->{IMG}=i_readpnm_wiol( $IO, $allow_incomplete );
2fe0b227 1395 if ( !defined($self->{IMG}) ) {
2691d220
TC		 1396 $self->{ERRSTR}='unable to read pnm image: '._error_as_msg();
1397 return undef;
790923a4 1398 }
2fe0b227
AMH		 1399 $self->{DEBUG} && print "loading a pnm file\n";
1400 return $self;
1401 }
790923a4 1402
2fe0b227
AMH		 1403 if ( $input{'type'} eq 'png' ) {
1404 $self->{IMG}=i_readpng_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1405 if ( !defined($self->{IMG}) ) {
77157728 1406 $self->{ERRSTR} = $self->_error_as_msg();
2fe0b227 1407 return undef;
705fd961 1408 }
2fe0b227
AMH		 1409 $self->{DEBUG} && print "loading a png file\n";
1410 }
705fd961 1411
2fe0b227 1412 if ( $input{'type'} eq 'bmp' ) {
d87dc9a4 1413 $self->{IMG}=i_readbmp_wiol( $IO, $allow_incomplete );
2fe0b227
AMH		 1414 if ( !defined($self->{IMG}) ) {
1415 $self->{ERRSTR}=$self->_error_as_msg();
1416 return undef;
10461f9a 1417 }
2fe0b227
AMH		 1418 $self->{DEBUG} && print "loading a bmp file\n";
1419 }
10461f9a 1420
2fe0b227
AMH		 1421 if ( $input{'type'} eq 'gif' ) {
1422 if ($input{colors} && !ref($input{colors})) {
1423 # must be a reference to a scalar that accepts the colour map
1424 $self->{ERRSTR} = "option 'colors' must be a scalar reference";
1425 return undef;
1ec86afa 1426 }
f1adece7
TC		 1427 if ($input{'gif_consolidate'}) {
1428 if ($input{colors}) {
1429 my $colors;
1430 ($self->{IMG}, $colors) =i_readgif_wiol( $IO );
1431 if ($colors) {
1432 ${ $input{colors} } = [ map { NC(@$_) } @$colors ];
1433 }
1434 }
1435 else {
1436 $self->{IMG} =i_readgif_wiol( $IO );
737a830c 1437 }
737a830c 1438 }
2fe0b227 1439 else {
f1adece7
TC		 1440 my $page = $input{'page'};
1441 defined $page or $page = 0;
1442 $self->{IMG} = i_readgif_single_wiol( $IO, $page );
a5dbf458 1443 if ($self->{IMG} && $input{colors}) {
f1adece7
TC		 1444 ${ $input{colors} } =
1445 [ i_getcolors($self->{IMG}, 0, i_colorcount($self->{IMG})) ];
1446 }
895dbd34 1447 }
f1adece7 1448
2fe0b227
AMH		 1449 if ( !defined($self->{IMG}) ) {
1450 $self->{ERRSTR}=$self->_error_as_msg();
1451 return undef;
895dbd34 1452 }
2fe0b227
AMH		 1453 $self->{DEBUG} && print "loading a gif file\n";
1454 }
895dbd34 1455
2fe0b227
AMH		 1456 if ( $input{'type'} eq 'tga' ) {
1457 $self->{IMG}=i_readtga_wiol( $IO, -1 ); # Fixme, check if that length parameter is ever needed
1458 if ( !defined($self->{IMG}) ) {
1459 $self->{ERRSTR}=$self->_error_as_msg();
1460 return undef;
895dbd34 1461 }
2fe0b227
AMH		 1462 $self->{DEBUG} && print "loading a tga file\n";
1463 }
02d1d628 1464
2fe0b227 1465 if ( $input{'type'} eq 'raw' ) {
500888da
TC		 1466 unless ( $input{xsize} && $input{ysize} ) {
1467 $self->_set_error('missing xsize or ysize parameter for raw');
2fe0b227 1468 return undef;
895dbd34
AMH		 1469 }
1470
500888da
TC		 1471 my $interleave = _first($input{raw_interleave}, $input{interleave});
1472 unless (defined $interleave) {
1473 my @caller = caller;
1474 warn "read(type => 'raw') $caller[2] line $caller[1]: supply interleave or raw_interleave for future compatibility\n";
1475 $interleave = 1;
1476 }
1477 my $data_ch = _first($input{raw_datachannels}, $input{datachannels}, 3);
1478 my $store_ch = _first($input{raw_storechannels}, $input{storechannels}, 3);
1479
2fe0b227 1480 $self->{IMG} = i_readraw_wiol( $IO,
500888da
TC		 1481 $input{xsize},
1482 $input{ysize},
1483 $data_ch,
1484 $store_ch,
1485 $interleave);
2fe0b227 1486 if ( !defined($self->{IMG}) ) {
5f8f8e17 1487 $self->{ERRSTR}=$self->_error_as_msg();
2fe0b227 1488 return undef;
dd55acc8 1489 }
2fe0b227 1490 $self->{DEBUG} && print "loading a raw file\n";
02d1d628 1491 }
2fe0b227 1492
02d1d628 1493 return $self;
02d1d628
AMH		 1494}
1495
53a6bbd4
TC		 1496sub register_reader {
1497 my ($class, %opts) = @_;
1498
1499 defined $opts{type}
1500 or die "register_reader called with no type parameter\n";
1501
1502 my $type = $opts{type};
1503
1504 defined $opts{single} || defined $opts{multiple}
1505 or die "register_reader called with no single or multiple parameter\n";
1506
1507 $readers{$type} = { };
1508 if ($opts{single}) {
1509 $readers{$type}{single} = $opts{single};
1510 }
1511 if ($opts{multiple}) {
1512 $readers{$type}{multiple} = $opts{multiple};
1513 }
1514
1515 return 1;
1516}
1517
2b405c9e
TC		 1518sub register_writer {
1519 my ($class, %opts) = @_;
1520
1521 defined $opts{type}
1522 or die "register_writer called with no type parameter\n";
1523
1524 my $type = $opts{type};
1525
1526 defined $opts{single} || defined $opts{multiple}
1527 or die "register_writer called with no single or multiple parameter\n";
1528
1529 $writers{$type} = { };
1530 if ($opts{single}) {
1531 $writers{$type}{single} = $opts{single};
1532 }
1533 if ($opts{multiple}) {
1534 $writers{$type}{multiple} = $opts{multiple};
1535 }
1536
1537 return 1;
1538}
1539
f245645a
TC		 1540sub read_types {
1541 my %types =
1542 (
1543 map { $_ => 1 }
1544 keys %readers,
1545 grep($file_formats{$_}, keys %formats),
1546 qw(ico sgi), # formats not handled directly, but supplied with Imager
1547 );
1548
1549 return keys %types;
1550}
1551
1552sub write_types {
1553 my %types =
1554 (
1555 map { $_ => 1 }
1556 keys %writers,
1557 grep($file_formats{$_}, keys %formats),
1558 qw(ico sgi), # formats not handled directly, but supplied with Imager
1559 );
1560
1561 return keys %types;
1562}
1563
53a6bbd4
TC		 1564# probes for an Imager::File::whatever module
1565sub _reader_autoload {
1566 my $type = shift;
1567
1568 return if $formats{$type} || $readers{$type};
1569
1570 return unless $type =~ /^\w+$/;
1571
1572 my $file = "Imager/File/\U$type\E.pm";
1573
1574 unless ($attempted_to_load{$file}) {
1575 eval {
1576 ++$attempted_to_load{$file};
1577 require $file;
1578 };
2b405c9e
TC		 1579 if ($@) {
1580 # try to get a reader specific module
1581 my $file = "Imager/File/\U$type\EReader.pm";
1582 unless ($attempted_to_load{$file}) {
1583 eval {
1584 ++$attempted_to_load{$file};
1585 require $file;
1586 };
1587 }
1588 }
1589 }
1590}
1591
1592# probes for an Imager::File::whatever module
1593sub _writer_autoload {
1594 my $type = shift;
1595
1596 return if $formats{$type} || $readers{$type};
1597
1598 return unless $type =~ /^\w+$/;
1599
1600 my $file = "Imager/File/\U$type\E.pm";
1601
1602 unless ($attempted_to_load{$file}) {
1603 eval {
1604 ++$attempted_to_load{$file};
1605 require $file;
1606 };
1607 if ($@) {
1608 # try to get a writer specific module
1609 my $file = "Imager/File/\U$type\EWriter.pm";
1610 unless ($attempted_to_load{$file}) {
1611 eval {
1612 ++$attempted_to_load{$file};
1613 require $file;
1614 };
1615 }
1616 }
53a6bbd4
TC		 1617 }
1618}
1619
97c4effc
TC		 1620sub _fix_gif_positions {
1621 my ($opts, $opt, $msg, @imgs) = @_;
2fe0b227 1622
97c4effc
TC		 1623 my $positions = $opts->{'gif_positions'};
1624 my $index = 0;
1625 for my $pos (@$positions) {
1626 my ($x, $y) = @$pos;
1627 my $img = $imgs[$index++];
9d1c4956
TC		 1628 $img->settag(name=>'gif_left', value=>$x);
1629 $img->settag(name=>'gif_top', value=>$y) if defined $y;
97c4effc
TC		 1630 }
1631 $$msg .= "replaced with the gif_left and gif_top tags";
1632}
1633
1634my %obsolete_opts =
1635 (
1636 gif_each_palette=>'gif_local_map',
1637 interlace => 'gif_interlace',
1638 gif_delays => 'gif_delay',
1639 gif_positions => \&_fix_gif_positions,
1640 gif_loop_count => 'gif_loop',
1641 );
1642
6e4af7d4
TC		 1643# options that should be converted to colors
1644my %color_opts = map { $_ => 1 } qw/i_background/;
1645
97c4effc
TC		 1646sub _set_opts {
1647 my ($self, $opts, $prefix, @imgs) = @_;
1648
1649 for my $opt (keys %$opts) {
1650 my $tagname = $opt;
1651 if ($obsolete_opts{$opt}) {
1652 my $new = $obsolete_opts{$opt};
1653 my $msg = "Obsolete option $opt ";
1654 if (ref $new) {
1655 $new->($opts, $opt, \$msg, @imgs);
1656 }
1657 else {
1658 $msg .= "replaced with the $new tag ";
1659 $tagname = $new;
1660 }
1661 $msg .= "line ".(caller(2))[2]." of file ".(caller(2))[1];
1662 warn $msg if $warn_obsolete && $^W;
1663 }
1664 next unless $tagname =~ /^\Q$prefix/;
1665 my $value = $opts->{$opt};
6e4af7d4
TC		 1666 if ($color_opts{$opt}) {
1667 $value = _color($value);
1668 unless ($value) {
1669 $self->_set_error($Imager::ERRSTR);
1670 return;
1671 }
1672 }
97c4effc
TC		 1673 if (ref $value) {
1674 if (UNIVERSAL::isa($value, "Imager::Color")) {
1675 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1676 for my $img (@imgs) {
1677 $img->settag(name=>$tagname, value=>$tag);
1678 }
1679 }
1680 elsif (ref($value) eq 'ARRAY') {
1681 for my $i (0..$#$value) {
1682 my $val = $value->[$i];
1683 if (ref $val) {
1684 if (UNIVERSAL::isa($val, "Imager::Color")) {
1685 my $tag = sprintf("color(%d,%d,%d,%d)", $value->rgba);
1686 $i < @imgs and
1687 $imgs[$i]->settag(name=>$tagname, value=>$tag);
1688 }
1689 else {
1690 $self->_set_error("Unknown reference type " . ref($value) .
1691 " supplied in array for $opt");
1692 return;
1693 }
1694 }
1695 else {
1696 $i < @imgs
1697 and $imgs[$i]->settag(name=>$tagname, value=>$val);
1698 }
1699 }
1700 }
1701 else {
1702 $self->_set_error("Unknown reference type " . ref($value) .
1703 " supplied for $opt");
1704 return;
1705 }
1706 }
1707 else {
1708 # set it as a tag for every image
1709 for my $img (@imgs) {
1710 $img->settag(name=>$tagname, value=>$value);
1711 }
1712 }
1713 }
1714
1715 return 1;
1716}
1717
02d1d628 1718# Write an image to file
02d1d628
AMH		 1719sub write {
1720 my $self = shift;
2fe0b227
AMH		 1721 my %input=(jpegquality=>75,
1722 gifquant=>'mc',
1723 lmdither=>6.0,
febba01f
AMH		 1724 lmfixed=>[],
1725 idstring=>"",
1726 compress=>1,
1727 wierdpack=>0,
4c2d6970 1728 fax_fine=>1, @_);
10461f9a 1729 my $rc;
02d1d628 1730
97c4effc
TC		 1731 $self->_set_opts(\%input, "i_", $self)
1732 or return undef;
1733
02d1d628
AMH		 1734 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
1735
9d540150
TC		 1736 if (!$input{'type'} and $input{file}) {
1737 $input{'type'}=$FORMATGUESS->($input{file});
1738 }
1739 if (!$input{'type'}) {
1740 $self->{ERRSTR}='type parameter missing and not possible to guess from extension';
1741 return undef;
1742 }
02d1d628 1743
2b405c9e 1744 _writer_autoload($input{type});
02d1d628 1745
2b405c9e
TC		 1746 my ($IO, $fh);
1747 if ($writers{$input{type}} && $writers{$input{type}}{single}) {
1748 ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
2fe0b227 1749 or return undef;
febba01f 1750
2b405c9e 1751 $writers{$input{type}}{single}->($self, $IO, %input)
2fe0b227 1752 or return undef;
2b405c9e
TC		 1753 }
1754 else {
1755 if (!$formats{$input{'type'}}) {
f245645a
TC		 1756 my $write_types = join ', ', sort Imager->write_types();
1757 $self->_set_error("format '$input{'type'}' not supported - formats $write_types available for writing");
2fe0b227 1758 return undef;
930c67c8 1759 }
2b405c9e
TC		 1760
1761 ($IO, $fh) = $self->_get_writer_io(\%input, $input{'type'})
2fe0b227 1762 or return undef;
2b405c9e
TC		 1763
1764 if ($input{'type'} eq 'tiff') {
1765 $self->_set_opts(\%input, "tiff_", $self)
1766 or return undef;
1767 $self->_set_opts(\%input, "exif_", $self)
1768 or return undef;
1769
1770 if (defined $input{class} && $input{class} eq 'fax') {
1771 if (!i_writetiff_wiol_faxable($self->{IMG}, $IO, $input{fax_fine})) {
1772 $self->{ERRSTR} = $self->_error_as_msg();
1773 return undef;
1774 }
1775 } else {
1776 if (!i_writetiff_wiol($self->{IMG}, $IO)) {
1777 $self->{ERRSTR} = $self->_error_as_msg();
1778 return undef;
1779 }
1780 }
1781 } elsif ( $input{'type'} eq 'pnm' ) {
1782 $self->_set_opts(\%input, "pnm_", $self)
1783 or return undef;
1784 if ( ! i_writeppm_wiol($self->{IMG},$IO) ) {
1785 $self->{ERRSTR} = $self->_error_as_msg();
1786 return undef;
1787 }
1788 $self->{DEBUG} && print "writing a pnm file\n";
1789 } elsif ( $input{'type'} eq 'raw' ) {
1790 $self->_set_opts(\%input, "raw_", $self)
1791 or return undef;
1792 if ( !i_writeraw_wiol($self->{IMG},$IO) ) {
1793 $self->{ERRSTR} = $self->_error_as_msg();
1794 return undef;
1795 }
1796 $self->{DEBUG} && print "writing a raw file\n";
1797 } elsif ( $input{'type'} eq 'png' ) {
1798 $self->_set_opts(\%input, "png_", $self)
1799 or return undef;
1800 if ( !i_writepng_wiol($self->{IMG}, $IO) ) {
1801 $self->{ERRSTR}='unable to write png image';
1802 return undef;
1803 }
1804 $self->{DEBUG} && print "writing a png file\n";
1805 } elsif ( $input{'type'} eq 'jpeg' ) {
1806 $self->_set_opts(\%input, "jpeg_", $self)
1807 or return undef;
1808 $self->_set_opts(\%input, "exif_", $self)
1809 or return undef;
1810 if ( !i_writejpeg_wiol($self->{IMG}, $IO, $input{jpegquality})) {
1811 $self->{ERRSTR} = $self->_error_as_msg();
1812 return undef;
1813 }
1814 $self->{DEBUG} && print "writing a jpeg file\n";
1815 } elsif ( $input{'type'} eq 'bmp' ) {
1816 $self->_set_opts(\%input, "bmp_", $self)
1817 or return undef;
1818 if ( !i_writebmp_wiol($self->{IMG}, $IO) ) {
ae12796a 1819 $self->{ERRSTR} = $self->_error_as_msg;
2b405c9e
TC		 1820 return undef;
1821 }
1822 $self->{DEBUG} && print "writing a bmp file\n";
1823 } elsif ( $input{'type'} eq 'tga' ) {
1824 $self->_set_opts(\%input, "tga_", $self)
1825 or return undef;
1826
1827 if ( !i_writetga_wiol($self->{IMG}, $IO, $input{wierdpack}, $input{compress}, $input{idstring}) ) {
1828 $self->{ERRSTR}=$self->_error_as_msg();
1829 return undef;
1830 }
1831 $self->{DEBUG} && print "writing a tga file\n";
1832 } elsif ( $input{'type'} eq 'gif' ) {
1833 $self->_set_opts(\%input, "gif_", $self)
1834 or return undef;
1835 # compatibility with the old interfaces
1836 if ($input{gifquant} eq 'lm') {
1837 $input{make_colors} = 'addi';
1838 $input{translate} = 'perturb';
1839 $input{perturb} = $input{lmdither};
1840 } elsif ($input{gifquant} eq 'gen') {
1841 # just pass options through
1842 } else {
1843 $input{make_colors} = 'webmap'; # ignored
1844 $input{translate} = 'giflib';
1845 }
1846 if (!i_writegif_wiol($IO, \%input, $self->{IMG})) {
1847 $self->{ERRSTR} = $self->_error_as_msg;
1848 return;
1849 }
1501d9b3 1850 }
02d1d628 1851 }
10461f9a 1852
2fe0b227
AMH		 1853 if (exists $input{'data'}) {
1854 my $data = io_slurp($IO);
1855 if (!$data) {
1856 $self->{ERRSTR}='Could not slurp from buffer';
1857 return undef;
1858 }
1859 ${$input{data}} = $data;
1860 }
02d1d628
AMH		 1861 return $self;
1862}
1863
1864sub write_multi {
1865 my ($class, $opts, @images) = @_;
1866
2b405c9e
TC		 1867 my $type = $opts->{type};
1868
1869 if (!$type && $opts->{'file'}) {
1870 $type = $FORMATGUESS->($opts->{'file'});
10461f9a 1871 }
2b405c9e 1872 unless ($type) {
10461f9a
TC		 1873 $class->_set_error('type parameter missing and not possible to guess from extension');
1874 return;
1875 }
1876 # translate to ImgRaw
1877 if (grep !UNIVERSAL::isa($_, 'Imager') || !$_->{IMG}, @images) {
1878 $class->_set_error('Usage: Imager->write_multi({ options }, @images)');
1879 return 0;
1880 }
97c4effc
TC		 1881 $class->_set_opts($opts, "i_", @images)
1882 or return;
10461f9a 1883 my @work = map $_->{IMG}, @images;
2b405c9e
TC		 1884
1885 _writer_autoload($type);
1886
1887 my ($IO, $file);
1888 if ($writers{$type} && $writers{$type}{multiple}) {
1889 ($IO, $file) = $class->_get_writer_io($opts, $type)
1890 or return undef;
1891
1892 $writers{$type}{multiple}->($class, $IO, $opts, @images)
1893 or return undef;
1894 }
1895 else {
1896 if (!$formats{$type}) {
f245645a
TC		 1897 my $write_types = join ', ', sort Imager->write_types();
1898 $class->_set_error("format '$type' not supported - formats $write_types available for writing");
2b405c9e
TC		 1899 return undef;
1900 }
1901
1902 ($IO, $file) = $class->_get_writer_io($opts, $type)
1903 or return undef;
1904
1905 if ($type eq 'gif') {
1906 $class->_set_opts($opts, "gif_", @images)
1907 or return;
1908 my $gif_delays = $opts->{gif_delays};
1909 local $opts->{gif_delays} = $gif_delays;
1910 if ($opts->{gif_delays} && !ref $opts->{gif_delays}) {
1911 # assume the caller wants the same delay for each frame
1912 $opts->{gif_delays} = [ ($gif_delays) x @images ];
1913 }
1914 unless (i_writegif_wiol($IO, $opts, @work)) {
1915 $class->_set_error($class->_error_as_msg());
1916 return undef;
1917 }
1918 }
1919 elsif ($type eq 'tiff') {
1920 $class->_set_opts($opts, "tiff_", @images)
1921 or return;
1922 $class->_set_opts($opts, "exif_", @images)
1923 or return;
1924 my $res;
1925 $opts->{fax_fine} = 1 unless exists $opts->{fax_fine};
1926 if ($opts->{'class'} && $opts->{'class'} eq 'fax') {
1927 $res = i_writetiff_multi_wiol_faxable($IO, $opts->{fax_fine}, @work);
1928 }
1929 else {
1930 $res = i_writetiff_multi_wiol($IO, @work);
1931 }
1932 unless ($res) {
1933 $class->_set_error($class->_error_as_msg());
1934 return undef;
1935 }
02d1d628
AMH		 1936 }
1937 else {
e7ff1cf7
TC		 1938 if (@images == 1) {
1939 unless ($images[0]->write(%$opts, io => $IO, type => $type)) {
1940 return 1;
1941 }
1942 }
1943 else {
1944 $ERRSTR = "Sorry, write_multi doesn't support $type yet";
1945 return 0;
1946 }
02d1d628
AMH		 1947 }
1948 }
2b405c9e
TC		 1949
1950 if (exists $opts->{'data'}) {
1951 my $data = io_slurp($IO);
1952 if (!$data) {
1953 Imager->_set_error('Could not slurp from buffer');
1954 return undef;
1955 }
1956 ${$opts->{data}} = $data;
02d1d628 1957 }
2b405c9e 1958 return 1;
02d1d628
AMH		 1959}
1960
faa9b3e7
TC		 1961# read multiple images from a file
1962sub read_multi {
1963 my ($class, %opts) = @_;
1964
53a6bbd4
TC		 1965 my ($IO, $file) = $class->_get_reader_io(\%opts, $opts{'type'})
1966 or return;
1967
1968 my $type = $opts{'type'};
1969 unless ($type) {
1970 $type = i_test_format_probe($IO, -1);
1971 }
1972
1973 if ($opts{file} && !$type) {
faa9b3e7 1974 # guess the type
53a6bbd4 1975 $type = $FORMATGUESS->($opts{file});
faa9b3e7 1976 }
53a6bbd4
TC		 1977
1978 unless ($type) {
faa9b3e7
TC		 1979 $ERRSTR = "No type parameter supplied and it couldn't be guessed";
1980 return;
1981 }
faa9b3e7 1982
53a6bbd4
TC		 1983 _reader_autoload($type);
1984
1985 if ($readers{$type} && $readers{$type}{multiple}) {
1986 return $readers{$type}{multiple}->($IO, %opts);
1987 }
1988
8d46e5da
TC		 1989 unless ($formats{$type}) {
1990 my $read_types = join ', ', sort Imager->read_types();
1991 Imager->_set_error("format '$type' not supported - formats $read_types available for reading");
1992 return;
1993 }
1994
faa9b3e7 1995 my @imgs;
2086be61 1996 if ($type eq 'gif') {
10461f9a 1997 @imgs = i_readgif_multi_wiol($IO);
10461f9a 1998 }
53a6bbd4 1999 elsif ($type eq 'tiff') {
2086be61 2000 @imgs = i_readtiff_multi_wiol($IO, -1);
faa9b3e7 2001 }
2086be61
TC		 2002 elsif ($type eq 'pnm') {
2003 @imgs = i_readpnm_multi_wiol($IO, $opts{allow_incomplete}||0);
faa9b3e7 2004 }
e7ff1cf7
TC		 2005 else {
2006 my $img = Imager->new;
2007 if ($img->read(%opts, io => $IO, type => $type)) {
2008 return ( $img );
2009 }
f245645a 2010 Imager->_set_error($img->errstr);
2086be61 2011 return;
e7ff1cf7 2012 }
faa9b3e7 2013
2086be61
TC		 2014 if (!@imgs) {
2015 $ERRSTR = _error_as_msg();
faa9b3e7 2016 return;
2086be61
TC		 2017 }
2018 return map {
2019 bless { IMG=>$_, DEBUG=>$DEBUG, ERRSTR=>undef }, 'Imager'
2020 } @imgs;
faa9b3e7
TC		 2021}
2022
02d1d628
AMH		 2023# Destroy an Imager object
2024
2025sub DESTROY {
2026 my $self=shift;
2027 # delete $instances{$self};
2028 if (defined($self->{IMG})) {
faa9b3e7
TC		 2029 # the following is now handled by the XS DESTROY method for
2030 # Imager::ImgRaw object
2031 # Re-enabling this will break virtual images
2032 # tested for in t/t020masked.t
2033 # i_img_destroy($self->{IMG});
02d1d628
AMH		 2034 undef($self->{IMG});
2035 } else {
2036# print "Destroy Called on an empty image!\n"; # why did I put this here??
2037 }
2038}
2039
2040# Perform an inplace filter of an image
2041# that is the image will be overwritten with the data
2042
2043sub filter {
2044 my $self=shift;
2045 my %input=@_;
2046 my %hsh;
2047 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2048
9d540150 2049 if (!$input{'type'}) { $self->{ERRSTR}='type parameter missing'; return undef; }
02d1d628 2050
9d540150 2051 if ( (grep { $_ eq $input{'type'} } keys %filters) != 1) {
02d1d628
AMH		 2052 $self->{ERRSTR}='type parameter not matching any filter'; return undef;
2053 }
2054
9d540150
TC		 2055 if ($filters{$input{'type'}}{names}) {
2056 my $names = $filters{$input{'type'}}{names};
6607600c
TC		 2057 for my $name (keys %$names) {
2058 if (defined $input{$name} && exists $names->{$name}{$input{$name}}) {
2059 $input{$name} = $names->{$name}{$input{$name}};
2060 }
2061 }
2062 }
9d540150 2063 if (defined($filters{$input{'type'}}{defaults})) {
7327d4b0
TC		 2064 %hsh=( image => $self->{IMG},
2065 imager => $self,
2066 %{$filters{$input{'type'}}{defaults}},
2067 %input );
02d1d628 2068 } else {
7327d4b0
TC		 2069 %hsh=( image => $self->{IMG},
2070 imager => $self,
2071 %input );
02d1d628
AMH		 2072 }
2073
9d540150 2074 my @cs=@{$filters{$input{'type'}}{callseq}};
02d1d628
AMH		 2075
2076 for(@cs) {
2077 if (!defined($hsh{$_})) {
9d540150 2078 $self->{ERRSTR}="missing parameter '$_' for filter ".$input{'type'}; return undef;
02d1d628
AMH		 2079 }
2080 }
2081
109bec2d
TC		 2082 eval {
2083 local $SIG{__DIE__}; # we don't want this processed by confess, etc
2084 &{$filters{$input{'type'}}{callsub}}(%hsh);
2085 };
2086 if ($@) {
2087 chomp($self->{ERRSTR} = $@);
2088 return;
2089 }
02d1d628
AMH		 2090
2091 my @b=keys %hsh;
2092
2093 $self->{DEBUG} && print "callseq is: @cs\n";
2094 $self->{DEBUG} && print "matching callseq is: @b\n";
2095
2096 return $self;
2097}
2098
92bda632
TC		 2099sub register_filter {
2100 my $class = shift;
2101 my %hsh = ( defaults => {}, @_ );
2102
2103 defined $hsh{type}
2104 or die "register_filter() with no type\n";
2105 defined $hsh{callsub}
2106 or die "register_filter() with no callsub\n";
2107 defined $hsh{callseq}
2108 or die "register_filter() with no callseq\n";
2109
2110 exists $filters{$hsh{type}}
2111 and return;
2112
2113 $filters{$hsh{type}} = \%hsh;
2114
2115 return 1;
2116}
2117
df9aaafb
TC		 2118sub scale_calculate {
2119 my $self = shift;
02d1d628 2120
df9aaafb 2121 my %opts = ('type'=>'max', @_);
4f579313 2122
de470892
TC		 2123 # none of these should be references
2124 for my $name (qw/xpixels ypixels xscalefactor yscalefactor width height/) {
2125 if (defined $opts{$name} && ref $opts{$name}) {
2126 $self->_set_error("scale_calculate: $name parameter cannot be a reference");
2127 return;
2128 }
2129 }
2130
df9aaafb
TC		 2131 my ($x_scale, $y_scale);
2132 my $width = $opts{width};
2133 my $height = $opts{height};
2134 if (ref $self) {
2135 defined $width or $width = $self->getwidth;
2136 defined $height or $height = $self->getheight;
ace46df2 2137 }
df9aaafb
TC		 2138 else {
2139 unless (defined $width && defined $height) {
2140 $self->_set_error("scale_calculate: width and height parameters must be supplied when called as a class method");
2141 return;
2142 }
5168ca3a 2143 }
02d1d628 2144
658f724e
TC		 2145 if ($opts{'xscalefactor'} && $opts{'yscalefactor'}) {
2146 $x_scale = $opts{'xscalefactor'};
2147 $y_scale = $opts{'yscalefactor'};
2148 }
2149 elsif ($opts{'xscalefactor'}) {
2150 $x_scale = $opts{'xscalefactor'};
2151 $y_scale = $opts{'scalefactor'} || $x_scale;
2152 }
2153 elsif ($opts{'yscalefactor'}) {
2154 $y_scale = $opts{'yscalefactor'};
2155 $x_scale = $opts{'scalefactor'} || $y_scale;
2156 }
2157 else {
2158 $x_scale = $y_scale = $opts{'scalefactor'} || 0.5;
2159 }
2160
5168ca3a 2161 # work out the scaling
9d540150 2162 if ($opts{xpixels} and $opts{ypixels} and $opts{'type'}) {
df9aaafb
TC		 2163 my ($xpix, $ypix)=( $opts{xpixels} / $width ,
2164 $opts{ypixels} / $height );
5168ca3a 2165 if ($opts{'type'} eq 'min') {
658f724e 2166 $x_scale = $y_scale = _min($xpix,$ypix);
5168ca3a
TC		 2167 }
2168 elsif ($opts{'type'} eq 'max') {
658f724e
TC		 2169 $x_scale = $y_scale = _max($xpix,$ypix);
2170 }
2171 elsif ($opts{'type'} eq 'nonprop' || $opts{'type'} eq 'non-proportional') {
2172 $x_scale = $xpix;
2173 $y_scale = $ypix;
5168ca3a
TC		 2174 }
2175 else {
2176 $self->_set_error('invalid value for type parameter');
df9aaafb 2177 return;
5168ca3a
TC		 2178 }
2179 } elsif ($opts{xpixels}) {
df9aaafb 2180 $x_scale = $y_scale = $opts{xpixels} / $width;
5168ca3a
TC		 2181 }
2182 elsif ($opts{ypixels}) {
df9aaafb 2183 $x_scale = $y_scale = $opts{ypixels}/$height;
5168ca3a 2184 }
41c7d053
TC		 2185 elsif ($opts{constrain} && ref $opts{constrain}
2186 && $opts{constrain}->can('constrain')) {
2187 # we've been passed an Image::Math::Constrain object or something
2188 # that looks like one
658f724e 2189 my $scalefactor;
4f579313 2190 (undef, undef, $scalefactor)
41c7d053 2191 = $opts{constrain}->constrain($self->getwidth, $self->getheight);
4f579313 2192 unless ($scalefactor) {
41c7d053 2193 $self->_set_error('constrain method failed on constrain parameter');
df9aaafb 2194 return;
41c7d053 2195 }
658f724e 2196 $x_scale = $y_scale = $scalefactor;
41c7d053 2197 }
02d1d628 2198
df9aaafb
TC		 2199 my $new_width = int($x_scale * $width + 0.5);
2200 $new_width > 0 or $new_width = 1;
2201 my $new_height = int($y_scale * $height + 0.5);
2202 $new_height > 0 or $new_height = 1;
2203
2204 return ($x_scale, $y_scale, $new_width, $new_height);
2205
2206}
2207
2208# Scale an image to requested size and return the scaled version
2209
2210sub scale {
2211 my $self=shift;
2212 my %opts = (qtype=>'normal' ,@_);
2213 my $img = Imager->new();
2214 my $tmp = Imager->new();
2215
2216 unless (defined wantarray) {
2217 my @caller = caller;
2218 warn "scale() called in void context - scale() returns the scaled image at $caller[1] line $caller[2]\n";
2219 return;
2220 }
2221
2222 unless ($self->{IMG}) {
2223 $self->_set_error('empty input image');
2224 return undef;
2225 }
2226
2227 my ($x_scale, $y_scale, $new_width, $new_height) =
2228 $self->scale_calculate(%opts)
2229 or return;
2230
02d1d628 2231 if ($opts{qtype} eq 'normal') {
658f724e 2232 $tmp->{IMG} = i_scaleaxis($self->{IMG}, $x_scale, 0);
5168ca3a 2233 if ( !defined($tmp->{IMG}) ) {
de470892 2234 $self->{ERRSTR} = 'unable to scale image: ' . $self->_error_as_msg;
5168ca3a
TC		 2235 return undef;
2236 }
658f724e 2237 $img->{IMG}=i_scaleaxis($tmp->{IMG}, $y_scale, 1);
5168ca3a 2238 if ( !defined($img->{IMG}) ) {
de470892 2239 $self->{ERRSTR}='unable to scale image: ' . $self->_error_as_msg;
5168ca3a
TC		 2240 return undef;
2241 }
2242
02d1d628
AMH		 2243 return $img;
2244 }
5168ca3a 2245 elsif ($opts{'qtype'} eq 'preview') {
658f724e 2246 $img->{IMG} = i_scale_nn($self->{IMG}, $x_scale, $y_scale);
5168ca3a
TC		 2247 if ( !defined($img->{IMG}) ) {
2248 $self->{ERRSTR}='unable to scale image';
2249 return undef;
2250 }
02d1d628
AMH		 2251 return $img;
2252 }
658f724e 2253 elsif ($opts{'qtype'} eq 'mixing') {
658f724e
TC		 2254 $img->{IMG} = i_scale_mixing($self->{IMG}, $new_width, $new_height);
2255 unless ($img->{IMG}) {
de470892 2256 $self->_set_error(Imager->_error_as_msg);
658f724e
TC		 2257 return;
2258 }
2259 return $img;
2260 }
5168ca3a
TC		 2261 else {
2262 $self->_set_error('invalid value for qtype parameter');
2263 return undef;
2264 }
02d1d628
AMH		 2265}
2266
2267# Scales only along the X axis
2268
2269sub scaleX {
15327bf5
TC		 2270 my $self = shift;
2271 my %opts = ( scalefactor=>0.5, @_ );
02d1d628 2272
34b3f7e6
TC		 2273 unless (defined wantarray) {
2274 my @caller = caller;
2275 warn "scaleX() called in void context - scaleX() returns the scaled image at $caller[1] line $caller[2]\n";
2276 return;
2277 }
2278
15327bf5
TC		 2279 unless ($self->{IMG}) {
2280 $self->{ERRSTR} = 'empty input image';
2281 return undef;
2282 }
02d1d628
AMH		 2283
2284 my $img = Imager->new();
2285
15327bf5 2286 my $scalefactor = $opts{scalefactor};
02d1d628 2287
15327bf5
TC		 2288 if ($opts{pixels}) {
2289 $scalefactor = $opts{pixels} / $self->getwidth();
2290 }
2291
2292 unless ($self->{IMG}) {
2293 $self->{ERRSTR}='empty input image';
2294 return undef;
2295 }
2296
2297 $img->{IMG} = i_scaleaxis($self->{IMG}, $scalefactor, 0);
2298
2299 if ( !defined($img->{IMG}) ) {
2300 $self->{ERRSTR} = 'unable to scale image';
2301 return undef;
2302 }
02d1d628 2303
02d1d628
AMH		 2304 return $img;
2305}
2306
2307# Scales only along the Y axis
2308
2309sub scaleY {
15327bf5
TC		 2310 my $self = shift;
2311 my %opts = ( scalefactor => 0.5, @_ );
02d1d628 2312
34b3f7e6
TC		 2313 unless (defined wantarray) {
2314 my @caller = caller;
2315 warn "scaleY() called in void context - scaleY() returns the scaled image at $caller[1] line $caller[2]\n";
2316 return;
2317 }
2318
02d1d628
AMH		 2319 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2320
2321 my $img = Imager->new();
2322
15327bf5 2323 my $scalefactor = $opts{scalefactor};
02d1d628 2324
15327bf5
TC		 2325 if ($opts{pixels}) {
2326 $scalefactor = $opts{pixels} / $self->getheight();
2327 }
2328
2329 unless ($self->{IMG}) {
2330 $self->{ERRSTR} = 'empty input image';
2331 return undef;
2332 }
2333 $img->{IMG}=i_scaleaxis($self->{IMG}, $scalefactor, 1);
2334
2335 if ( !defined($img->{IMG}) ) {
2336 $self->{ERRSTR} = 'unable to scale image';
2337 return undef;
2338 }
02d1d628 2339
02d1d628
AMH		 2340 return $img;
2341}
2342
02d1d628
AMH		 2343# Transform returns a spatial transformation of the input image
2344# this moves pixels to a new location in the returned image.
2345# NOTE - should make a utility function to check transforms for
2346# stack overruns
2347
2348sub transform {
2349 my $self=shift;
2350 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2351 my %opts=@_;
2352 my (@op,@ropx,@ropy,$iop,$or,@parm,$expr,@xt,@yt,@pt,$numre);
2353
2354# print Dumper(\%opts);
2355# xopcopdes
2356
2357 if ( $opts{'xexpr'} and $opts{'yexpr'} ) {
2358 if (!$I2P) {
2359 eval ("use Affix::Infix2Postfix;");
2360 print $@;
2361 if ( $@ ) {
2362 $self->{ERRSTR}='transform: expr given and Affix::Infix2Postfix is not avaliable.';
2363 return undef;
2364 }
2365 $I2P=Affix::Infix2Postfix->new('ops'=>[{op=>'+',trans=>'Add'},
2366 {op=>'-',trans=>'Sub'},
2367 {op=>'*',trans=>'Mult'},
2368 {op=>'/',trans=>'Div'},
9d540150 2369 {op=>'-','type'=>'unary',trans=>'u-'},
02d1d628 2370 {op=>'**'},
9d540150 2371 {op=>'func','type'=>'unary'}],
02d1d628
AMH		 2372 'grouping'=>[qw( \( \) )],
2373 'func'=>[qw( sin cos )],
2374 'vars'=>[qw( x y )]
2375 );
2376 }
2377
2378 @xt=$I2P->translate($opts{'xexpr'});
2379 @yt=$I2P->translate($opts{'yexpr'});
2380
2381 $numre=$I2P->{'numre'};
2382 @pt=(0,0);
2383
2384 for(@xt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'xopcodes'}},'Parm',$#pt); } else { push(@{$opts{'xopcodes'}},$_); } }
2385 for(@yt) { if (/$numre/) { push(@pt,$_); push(@{$opts{'yopcodes'}},'Parm',$#pt); } else { push(@{$opts{'yopcodes'}},$_); } }
2386 @{$opts{'parm'}}=@pt;
2387 }
2388
2389# print Dumper(\%opts);
2390
2391 if ( !exists $opts{'xopcodes'} or @{$opts{'xopcodes'}}==0) {
2392 $self->{ERRSTR}='transform: no xopcodes given.';
2393 return undef;
2394 }
2395
2396 @op=@{$opts{'xopcodes'}};
2397 for $iop (@op) {
2398 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2399 $self->{ERRSTR}="transform: illegal opcode '$_'.";
2400 return undef;
2401 }
2402 push(@ropx,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2403 }
2404
2405
2406# yopcopdes
2407
2408 if ( !exists $opts{'yopcodes'} or @{$opts{'yopcodes'}}==0) {
2409 $self->{ERRSTR}='transform: no yopcodes given.';
2410 return undef;
2411 }
2412
2413 @op=@{$opts{'yopcodes'}};
2414 for $iop (@op) {
2415 if (!defined ($OPCODES{$iop}) and ($iop !~ /^\d+$/) ) {
2416 $self->{ERRSTR}="transform: illegal opcode '$_'.";
2417 return undef;
2418 }
2419 push(@ropy,(exists $OPCODES{$iop}) ? @{$OPCODES{$iop}} : $iop );
2420 }
2421
2422#parameters
2423
2424 if ( !exists $opts{'parm'}) {
2425 $self->{ERRSTR}='transform: no parameter arg given.';
2426 return undef;
2427 }
2428
2429# print Dumper(\@ropx);
2430# print Dumper(\@ropy);
2431# print Dumper(\@ropy);
2432
2433 my $img = Imager->new();
2434 $img->{IMG}=i_transform($self->{IMG},\@ropx,\@ropy,$opts{'parm'});
2435 if ( !defined($img->{IMG}) ) { $self->{ERRSTR}='transform: failed'; return undef; }
2436 return $img;
2437}
2438
2439
bf94b653
TC		 2440sub transform2 {
2441 my ($opts, @imgs) = @_;
2442
2443 require "Imager/Expr.pm";
2444
2445 $opts->{variables} = [ qw(x y) ];
2446 my ($width, $height) = @{$opts}{qw(width height)};
2447 if (@imgs) {
2448 $width ||= $imgs[0]->getwidth();
2449 $height ||= $imgs[0]->getheight();
2450 my $img_num = 1;
2451 for my $img (@imgs) {
2452 $opts->{constants}{"w$img_num"} = $img->getwidth();
2453 $opts->{constants}{"h$img_num"} = $img->getheight();
2454 $opts->{constants}{"cx$img_num"} = $img->getwidth()/2;
2455 $opts->{constants}{"cy$img_num"} = $img->getheight()/2;
2456 ++$img_num;
02d1d628 2457 }
02d1d628 2458 }
bf94b653
TC		 2459 if ($width) {
2460 $opts->{constants}{w} = $width;
2461 $opts->{constants}{cx} = $width/2;
2462 }
2463 else {
2464 $Imager::ERRSTR = "No width supplied";
2465 return;
2466 }
2467 if ($height) {
2468 $opts->{constants}{h} = $height;
2469 $opts->{constants}{cy} = $height/2;
2470 }
2471 else {
2472 $Imager::ERRSTR = "No height supplied";
2473 return;
2474 }
2475 my $code = Imager::Expr->new($opts);
2476 if (!$code) {
2477 $Imager::ERRSTR = Imager::Expr::error();
2478 return;
2479 }
e5744e01
TC		 2480 my $channels = $opts->{channels} || 3;
2481 unless ($channels >= 1 && $channels <= 4) {
2482 return Imager->_set_error("channels must be an integer between 1 and 4");
2483 }
9982a307 2484
bf94b653 2485 my $img = Imager->new();
e5744e01
TC		 2486 $img->{IMG} = i_transform2($opts->{width}, $opts->{height},
2487 $channels, $code->code(),
bf94b653
TC		 2488 $code->nregs(), $code->cregs(),
2489 [ map { $_->{IMG} } @imgs ]);
2490 if (!defined $img->{IMG}) {
2491 $Imager::ERRSTR = Imager->_error_as_msg();
2492 return;
2493 }
9982a307 2494
bf94b653 2495 return $img;
02d1d628
AMH		 2496}
2497
02d1d628
AMH		 2498sub rubthrough {
2499 my $self=shift;
9b1ec2b8 2500 my %opts= @_;
02d1d628 2501
e7b95388
TC		 2502 unless ($self->{IMG}) {
2503 $self->{ERRSTR}='empty input image';
2504 return undef;
2505 }
2506 unless ($opts{src} && $opts{src}->{IMG}) {
2507 $self->{ERRSTR}='empty input image for src';
2508 return undef;
2509 }
02d1d628 2510
71dc4a83
AMH		 2511 %opts = (src_minx => 0,
2512 src_miny => 0,
2513 src_maxx => $opts{src}->getwidth(),
2514 src_maxy => $opts{src}->getheight(),
2515 %opts);
2516
9b1ec2b8
TC		 2517 my $tx = $opts{tx};
2518 defined $tx or $tx = $opts{left};
2519 defined $tx or $tx = 0;
2520
2521 my $ty = $opts{ty};
2522 defined $ty or $ty = $opts{top};
2523 defined $ty or $ty = 0;
2524
2525 unless (i_rubthru($self->{IMG}, $opts{src}->{IMG}, $tx, $ty,
e7b95388
TC		 2526 $opts{src_minx}, $opts{src_miny},
2527 $opts{src_maxx}, $opts{src_maxy})) {
2528 $self->_set_error($self->_error_as_msg());
faa9b3e7
TC		 2529 return undef;
2530 }
9b1ec2b8 2531
02d1d628
AMH		 2532 return $self;
2533}
2534
9b1ec2b8
TC		 2535sub compose {
2536 my $self = shift;
2537 my %opts =
2538 (
2539 opacity => 1.0,
2540 mask_left => 0,
2541 mask_top => 0,
2542 @_
2543 );
2544
2545 unless ($self->{IMG}) {
2546 $self->_set_error("compose: empty input image");
2547 return;
2548 }
2549
2550 unless ($opts{src}) {
2551 $self->_set_error("compose: src parameter missing");
2552 return;
2553 }
2554
2555 unless ($opts{src}{IMG}) {
2556 $self->_set_error("compose: src parameter empty image");
2557 return;
2558 }
2559 my $src = $opts{src};
2560
2561 my $left = $opts{left};
2562 defined $left or $left = $opts{tx};
2563 defined $left or $left = 0;
2564
2565 my $top = $opts{top};
2566 defined $top or $top = $opts{ty};
2567 defined $top or $top = 0;
2568
2569 my $src_left = $opts{src_left};
2570 defined $src_left or $src_left = $opts{src_minx};
2571 defined $src_left or $src_left = 0;
2572
2573 my $src_top = $opts{src_top};
2574 defined $src_top or $src_top = $opts{src_miny};
2575 defined $src_top or $src_top = 0;
2576
2577 my $width = $opts{width};
2578 if (!defined $width && defined $opts{src_maxx}) {
2579 $width = $opts{src_maxx} - $src_left;
2580 }
2581 defined $width or $width = $src->getwidth() - $src_left;
2582
2583 my $height = $opts{height};
2584 if (!defined $height && defined $opts{src_maxy}) {
2585 $height = $opts{src_maxy} - $src_top;
2586 }
2587 defined $height or $height = $src->getheight() - $src_top;
2588
2589 my $combine = $self->_combine($opts{combine}, 'normal');
2590
2591 if ($opts{mask}) {
2592 unless ($opts{mask}{IMG}) {
2593 $self->_set_error("compose: mask parameter empty image");
2594 return;
2595 }
2596
2597 my $mask_left = $opts{mask_left};
2598 defined $mask_left or $mask_left = $opts{mask_minx};
2599 defined $mask_left or $mask_left = 0;
2600
2601 my $mask_top = $opts{mask_top};
2602 defined $mask_top or $mask_top = $opts{mask_miny};
2603 defined $mask_top or $mask_top = 0;
2604
2605 i_compose_mask($self->{IMG}, $src->{IMG}, $opts{mask}{IMG},
2606 $left, $top, $src_left, $src_top,
2607 $mask_left, $mask_top, $width, $height,
2608 $combine, $opts{opacity})
2609 or return;
2610 }
2611 else {
2612 i_compose($self->{IMG}, $src->{IMG}, $left, $top, $src_left, $src_top,
2613 $width, $height, $combine, $opts{opacity})
2614 or return;
2615 }
2616
2617 return $self;
2618}
02d1d628 2619
142c26ff
AMH		 2620sub flip {
2621 my $self = shift;
2622 my %opts = @_;
9191e525 2623 my %xlate = (h=>0, v=>1, hv=>2, vh=>2);
142c26ff
AMH		 2624 my $dir;
2625 return () unless defined $opts{'dir'} and defined $xlate{$opts{'dir'}};
2626 $dir = $xlate{$opts{'dir'}};
2627 return $self if i_flipxy($self->{IMG}, $dir);
2628 return ();
2629}
2630
faa9b3e7
TC		 2631sub rotate {
2632 my $self = shift;
2633 my %opts = @_;
34b3f7e6
TC		 2634
2635 unless (defined wantarray) {
2636 my @caller = caller;
2637 warn "rotate() called in void context - rotate() returns the rotated image at $caller[1] line $caller[2]\n";
2638 return;
2639 }
2640
faa9b3e7
TC		 2641 if (defined $opts{right}) {
2642 my $degrees = $opts{right};
2643 if ($degrees < 0) {
2644 $degrees += 360 * int(((-$degrees)+360)/360);
2645 }
2646 $degrees = $degrees % 360;
2647 if ($degrees == 0) {
2648 return $self->copy();
2649 }
2650 elsif ($degrees == 90 || $degrees == 180 || $degrees == 270) {
2651 my $result = Imager->new();
2652 if ($result->{IMG} = i_rotate90($self->{IMG}, $degrees)) {
2653 return $result;
2654 }
2655 else {
2656 $self->{ERRSTR} = $self->_error_as_msg();
2657 return undef;
2658 }
2659 }
2660 else {
2661 $self->{ERRSTR} = "Parameter 'right' must be a multiple of 90 degrees";
2662 return undef;
2663 }
2664 }
2665 elsif (defined $opts{radians} || defined $opts{degrees}) {
2666 my $amount = $opts{radians} || $opts{degrees} * 3.1415926535 / 180;
2667
7f627571 2668 my $back = $opts{back};
faa9b3e7 2669 my $result = Imager->new;
7f627571
TC		 2670 if ($back) {
2671 $back = _color($back);
2672 unless ($back) {
2673 $self->_set_error(Imager->errstr);
2674 return undef;
2675 }
2676
2677 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount, $back);
0d3b936e
TC		 2678 }
2679 else {
2680 $result->{IMG} = i_rotate_exact($self->{IMG}, $amount);
2681 }
2682 if ($result->{IMG}) {
faa9b3e7
TC		 2683 return $result;
2684 }
2685 else {
2686 $self->{ERRSTR} = $self->_error_as_msg();
2687 return undef;
2688 }
2689 }
2690 else {
0d3b936e 2691 $self->{ERRSTR} = "Only the 'right', 'radians' and 'degrees' parameters are available";
faa9b3e7
TC		 2692 return undef;
2693 }
2694}
2695
2696sub matrix_transform {
2697 my $self = shift;
2698 my %opts = @_;
2699
34b3f7e6
TC		 2700 unless (defined wantarray) {
2701 my @caller = caller;
2702 warn "copy() called in void context - copy() returns the copied image at $caller[1] line $caller[2]\n";
2703 return;
2704 }
2705
faa9b3e7
TC		 2706 if ($opts{matrix}) {
2707 my $xsize = $opts{xsize} || $self->getwidth;
2708 my $ysize = $opts{ysize} || $self->getheight;
142c26ff 2709
faa9b3e7 2710 my $result = Imager->new;
0d3b936e
TC		 2711 if ($opts{back}) {
2712 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2713 $opts{matrix}, $opts{back})
2714 or return undef;
2715 }
2716 else {
2717 $result->{IMG} = i_matrix_transform($self->{IMG}, $xsize, $ysize,
2718 $opts{matrix})
2719 or return undef;
2720 }
faa9b3e7
TC		 2721
2722 return $result;
2723 }
2724 else {
2725 $self->{ERRSTR} = "matrix parameter required";
2726 return undef;
2727 }
2728}
2729
2730# blame Leolo :)
2731*yatf = \&matrix_transform;
02d1d628
AMH		 2732
2733# These two are supported for legacy code only
2734
2735sub i_color_new {
faa9b3e7 2736 return Imager::Color->new(@_);
02d1d628
AMH		 2737}
2738
2739sub i_color_set {
faa9b3e7 2740 return Imager::Color::set(@_);
02d1d628
AMH		 2741}
2742
02d1d628 2743# Draws a box between the specified corner points.
02d1d628
AMH		 2744sub box {
2745 my $self=shift;
2746 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2747 my $dflcl=i_color_new(255,255,255,255);
2748 my %opts=(color=>$dflcl,xmin=>0,ymin=>0,xmax=>$self->getwidth()-1,ymax=>$self->getheight()-1,@_);
2749
2750 if (exists $opts{'box'}) {
bf1573f9
TC		 2751 $opts{'xmin'} = _min($opts{'box'}->[0],$opts{'box'}->[2]);
2752 $opts{'xmax'} = _max($opts{'box'}->[0],$opts{'box'}->[2]);
2753 $opts{'ymin'} = _min($opts{'box'}->[1],$opts{'box'}->[3]);
2754 $opts{'ymax'} = _max($opts{'box'}->[1],$opts{'box'}->[3]);
02d1d628
AMH		 2755 }
2756
f1ac5027 2757 if ($opts{filled}) {
3a9a4241
TC		 2758 my $color = _color($opts{'color'});
2759 unless ($color) {
2760 $self->{ERRSTR} = $Imager::ERRSTR;
2761 return;
2762 }
f1ac5027 2763 i_box_filled($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
3a9a4241 2764 $opts{ymax}, $color);
f1ac5027
TC		 2765 }
2766 elsif ($opts{fill}) {
2767 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2768 # assume it's a hash ref
2769 require 'Imager/Fill.pm';
141a6114
TC		 2770 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2771 $self->{ERRSTR} = $Imager::ERRSTR;
2772 return undef;
2773 }
f1ac5027
TC		 2774 }
2775 i_box_cfill($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},
2776 $opts{ymax},$opts{fill}{fill});
2777 }
cdd23610 2778 else {
3a9a4241
TC		 2779 my $color = _color($opts{'color'});
2780 unless ($color) {
cdd23610
AMH		 2781 $self->{ERRSTR} = $Imager::ERRSTR;
2782 return;
3a9a4241
TC		 2783 }
2784 i_box($self->{IMG},$opts{xmin},$opts{ymin},$opts{xmax},$opts{ymax},
2785 $color);
f1ac5027 2786 }
02d1d628
AMH		 2787 return $self;
2788}
2789
02d1d628
AMH		 2790sub arc {
2791 my $self=shift;
2792 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
40068b33
TC		 2793 my $dflcl= [ 255, 255, 255, 255];
2794 my $good = 1;
2795 my %opts=
2796 (
2797 color=>$dflcl,
2798 'r'=>_min($self->getwidth(),$self->getheight())/3,
2799 'x'=>$self->getwidth()/2,
2800 'y'=>$self->getheight()/2,
2801 'd1'=>0, 'd2'=>361,
2802 filled => 1,
2803 @_,
2804 );
a8652edf
TC		 2805 if ($opts{aa}) {
2806 if ($opts{fill}) {
2807 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2808 # assume it's a hash ref
2809 require 'Imager/Fill.pm';
2810 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2811 $self->{ERRSTR} = $Imager::ERRSTR;
2812 return;
2813 }
2814 }
2815 i_arc_aa_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2816 $opts{'d2'}, $opts{fill}{fill});
2817 }
40068b33 2818 elsif ($opts{filled}) {
a8652edf
TC		 2819 my $color = _color($opts{'color'});
2820 unless ($color) {
2821 $self->{ERRSTR} = $Imager::ERRSTR;
2822 return;
2823 }
2824 if ($opts{d1} == 0 && $opts{d2} == 361 && $opts{aa}) {
2825 i_circle_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'},
2826 $color);
2827 }
2828 else {
2829 i_arc_aa($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2830 $opts{'d1'}, $opts{'d2'}, $color);
569795e8 2831 }
f1ac5027 2832 }
40068b33
TC		 2833 else {
2834 my $color = _color($opts{'color'});
2835 if ($opts{d2} - $opts{d1} >= 360) {
2836 $good = i_circle_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $color);
2837 }
2838 else {
2839 $good = i_arc_out_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{'r'}, $opts{'d1'}, $opts{'d2'}, $color);
2840 }
2841 }
f1ac5027
TC		 2842 }
2843 else {
a8652edf
TC		 2844 if ($opts{fill}) {
2845 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
2846 # assume it's a hash ref
2847 require 'Imager/Fill.pm';
2848 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
2849 $self->{ERRSTR} = $Imager::ERRSTR;
2850 return;
2851 }
2852 }
2853 i_arc_cfill($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},$opts{'d1'},
2854 $opts{'d2'}, $opts{fill}{fill});
0d321238
TC		 2855 }
2856 else {
a8652edf
TC		 2857 my $color = _color($opts{'color'});
2858 unless ($color) {
2859 $self->{ERRSTR} = $Imager::ERRSTR;
40068b33
TC		 2860 return;
2861 }
2862 if ($opts{filled}) {
2863 i_arc($self->{IMG},$opts{'x'},$opts{'y'},$opts{'r'},
2864 $opts{'d1'}, $opts{'d2'}, $color);
2865 }
2866 else {
2867 if ($opts{d1} == 0 && $opts{d2} == 361) {
2868 $good = i_circle_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $color);
2869 }
2870 else {
2871 $good = i_arc_out($self->{IMG}, $opts{x}, $opts{y}, $opts{r}, $opts{d1}, $opts{d2}, $color);
2872 }
a8652edf 2873 }
0d321238 2874 }
f1ac5027 2875 }
40068b33
TC		 2876 unless ($good) {
2877 $self->_set_error($self->_error_as_msg);
2878 return;
2879 }
f1ac5027 2880
02d1d628
AMH		 2881 return $self;
2882}
2883
aa833c97
AMH		 2884# Draws a line from one point to the other
2885# the endpoint is set if the endp parameter is set which it is by default.
2886# to turn of the endpoint being set use endp=>0 when calling line.
02d1d628
AMH		 2887
2888sub line {
2889 my $self=shift;
2890 my $dflcl=i_color_new(0,0,0,0);
aa833c97
AMH		 2891 my %opts=(color=>$dflcl,
2892 endp => 1,
2893 @_);
02d1d628
AMH		 2894 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2895
2896 unless (exists $opts{x1} and exists $opts{y1}) { $self->{ERRSTR}='missing begining coord'; return undef; }
2897 unless (exists $opts{x2} and exists $opts{y2}) { $self->{ERRSTR}='missing ending coord'; return undef; }
2898
3a9a4241 2899 my $color = _color($opts{'color'});
aa833c97
AMH		 2900 unless ($color) {
2901 $self->{ERRSTR} = $Imager::ERRSTR;
2902 return;
3a9a4241 2903 }
aa833c97 2904
3a9a4241 2905 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628 2906 if ($opts{antialias}) {
aa833c97 2907 i_line_aa($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
b437ce0a 2908 $color, $opts{endp});
02d1d628 2909 } else {
aa833c97
AMH		 2910 i_line($self->{IMG},$opts{x1}, $opts{y1}, $opts{x2}, $opts{y2},
2911 $color, $opts{endp});
02d1d628
AMH		 2912 }
2913 return $self;
2914}
2915
2916# Draws a line between an ordered set of points - It more or less just transforms this
2917# into a list of lines.
2918
2919sub polyline {
2920 my $self=shift;
2921 my ($pt,$ls,@points);
2922 my $dflcl=i_color_new(0,0,0,0);
2923 my %opts=(color=>$dflcl,@_);
2924
2925 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2926
2927 if (exists($opts{points})) { @points=@{$opts{points}}; }
2928 if (!exists($opts{points}) and exists($opts{'x'}) and exists($opts{'y'}) ) {
2929 @points=map { [ $opts{'x'}->[$_],$opts{'y'}->[$_] ] } (0..(scalar @{$opts{'x'}}-1));
2930 }
2931
2932# print Dumper(\@points);
2933
3a9a4241
TC		 2934 my $color = _color($opts{'color'});
2935 unless ($color) {
2936 $self->{ERRSTR} = $Imager::ERRSTR;
2937 return;
2938 }
2939 $opts{antialias} = $opts{aa} if defined $opts{aa};
02d1d628
AMH		 2940 if ($opts{antialias}) {
2941 for $pt(@points) {
3a9a4241 2942 if (defined($ls)) {
b437ce0a 2943 i_line_aa($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color, 1);
3a9a4241 2944 }
02d1d628
AMH		 2945 $ls=$pt;
2946 }
2947 } else {
2948 for $pt(@points) {
3a9a4241 2949 if (defined($ls)) {
aa833c97 2950 i_line($self->{IMG},$ls->[0],$ls->[1],$pt->[0],$pt->[1],$color,1);
3a9a4241 2951 }
02d1d628
AMH		 2952 $ls=$pt;
2953 }
2954 }
2955 return $self;
2956}
2957
d0e7bfee
AMH		 2958sub polygon {
2959 my $self = shift;
2960 my ($pt,$ls,@points);
2961 my $dflcl = i_color_new(0,0,0,0);
2962 my %opts = (color=>$dflcl, @_);
2963
2964 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
2965
2966 if (exists($opts{points})) {
2967 $opts{'x'} = [ map { $_->[0] } @{$opts{points}} ];
2968 $opts{'y'} = [ map { $_->[1] } @{$opts{points}} ];
2969 }
2970
2971 if (!exists $opts{'x'} or !exists $opts{'y'}) {
2972 $self->{ERRSTR} = 'no points array, or x and y arrays.'; return undef;
2973 }
2974
43c5dacb
TC		 2975 if ($opts{'fill'}) {
2976 unless (UNIVERSAL::isa($opts{'fill'}, 'Imager::Fill')) {
2977 # assume it's a hash ref
2978 require 'Imager/Fill.pm';
2979 unless ($opts{'fill'} = Imager::Fill->new(%{$opts{'fill'}})) {
2980 $self->{ERRSTR} = $Imager::ERRSTR;
2981 return undef;
2982 }
2983 }
2984 i_poly_aa_cfill($self->{IMG}, $opts{'x'}, $opts{'y'},
2985 $opts{'fill'}{'fill'});
2986 }
2987 else {
3a9a4241
TC		 2988 my $color = _color($opts{'color'});
2989 unless ($color) {
2990 $self->{ERRSTR} = $Imager::ERRSTR;
2991 return;
2992 }
2993 i_poly_aa($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
43c5dacb
TC		 2994 }
2995
d0e7bfee
AMH		 2996 return $self;
2997}
2998
2999
3000# this the multipoint bezier curve
02d1d628
AMH		 3001# this is here more for testing that actual usage since
3002# this is not a good algorithm. Usually the curve would be
3003# broken into smaller segments and each done individually.
3004
3005sub polybezier {
3006 my $self=shift;
3007 my ($pt,$ls,@points);
3008 my $dflcl=i_color_new(0,0,0,0);
3009 my %opts=(color=>$dflcl,@_);
3010
3011 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3012
3013 if (exists $opts{points}) {
3014 $opts{'x'}=map { $_->[0]; } @{$opts{'points'}};
3015 $opts{'y'}=map { $_->[1]; } @{$opts{'points'}};
3016 }
3017
3018 unless ( @{$opts{'x'}} and @{$opts{'x'}} == @{$opts{'y'}} ) {
3019 $self->{ERRSTR}='Missing or invalid points.';
3020 return;
3021 }
3022
3a9a4241
TC		 3023 my $color = _color($opts{'color'});
3024 unless ($color) {
3025 $self->{ERRSTR} = $Imager::ERRSTR;
3026 return;
3027 }
3028 i_bezier_multi($self->{IMG},$opts{'x'},$opts{'y'},$color);
02d1d628
AMH		 3029 return $self;
3030}
3031
cc6483e0
TC		 3032sub flood_fill {
3033 my $self = shift;
3034 my %opts = ( color=>Imager::Color->new(255, 255, 255), @_ );
aa833c97
AMH		 3035 my $rc;
3036
9d540150 3037 unless (exists $opts{'x'} && exists $opts{'y'}) {
cc6483e0
TC		 3038 $self->{ERRSTR} = "missing seed x and y parameters";
3039 return undef;
3040 }
07d70837 3041
3efb0915
TC		 3042 if ($opts{border}) {
3043 my $border = _color($opts{border});
3044 unless ($border) {
3045 $self->_set_error($Imager::ERRSTR);
3046 return;
3047 }
3048 if ($opts{fill}) {
3049 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3050 # assume it's a hash ref
3051 require Imager::Fill;
3052 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3053 $self->{ERRSTR} = $Imager::ERRSTR;
3054 return;
3055 }
569795e8 3056 }
3efb0915
TC		 3057 $rc = i_flood_cfill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3058 $opts{fill}{fill}, $border);
3059 }
3060 else {
3061 my $color = _color($opts{'color'});
3062 unless ($color) {
3063 $self->{ERRSTR} = $Imager::ERRSTR;
3064 return;
3065 }
3066 $rc = i_flood_fill_border($self->{IMG}, $opts{'x'}, $opts{'y'},
3067 $color, $border);
3068 }
3069 if ($rc) {
3070 return $self;
3071 }
3072 else {
3073 $self->{ERRSTR} = $self->_error_as_msg();
3074 return;
cc6483e0 3075 }
cc6483e0
TC		 3076 }
3077 else {
3efb0915
TC		 3078 if ($opts{fill}) {
3079 unless (UNIVERSAL::isa($opts{fill}, 'Imager::Fill')) {
3080 # assume it's a hash ref
3081 require 'Imager/Fill.pm';
3082 unless ($opts{fill} = Imager::Fill->new(%{$opts{fill}})) {
3083 $self->{ERRSTR} = $Imager::ERRSTR;
3084 return;
3085 }
3086 }
3087 $rc = i_flood_cfill($self->{IMG}, $opts{'x'}, $opts{'y'}, $opts{fill}{fill});
3088 }
3089 else {
3090 my $color = _color($opts{'color'});
3091 unless ($color) {
3092 $self->{ERRSTR} = $Imager::ERRSTR;
3093 return;
3094 }
3095 $rc = i_flood_fill($self->{IMG}, $opts{'x'}, $opts{'y'}, $color);
3096 }
3097 if ($rc) {
3098 return $self;
3099 }
3100 else {
3101 $self->{ERRSTR} = $self->_error_as_msg();
aa833c97 3102 return;
3a9a4241 3103 }
3efb0915 3104 }
cc6483e0
TC		 3105}
3106
591b5954
TC		 3107sub setpixel {
3108 my $self = shift;
3109
3110 my %opts = ( color=>$self->{fg} || NC(255, 255, 255), @_);
3111
3112 unless (exists $opts{'x'} && exists $opts{'y'}) {
3113 $self->{ERRSTR} = 'missing x and y parameters';
3114 return undef;
3115 }
3116
3117 my $x = $opts{'x'};
3118 my $y = $opts{'y'};
3119 my $color = _color($opts{color})
3120 or return undef;
3121 if (ref $x && ref $y) {
3122 unless (@$x == @$y) {
9650c424 3123 $self->{ERRSTR} = 'length of x and y mismatch';
837a4b43 3124 return;
591b5954 3125 }
837a4b43 3126 my $set = 0;
591b5954
TC		 3127 if ($color->isa('Imager::Color')) {
3128 for my $i (0..$#{$opts{'x'}}) {
837a4b43
TC		 3129 i_ppix($self->{IMG}, $x->[$i], $y->[$i], $color)
3130 or ++$set;
591b5954
TC		 3131 }
3132 }
3133 else {
3134 for my $i (0..$#{$opts{'x'}}) {
837a4b43
TC		 3135 i_ppixf($self->{IMG}, $x->[$i], $y->[$i], $color)
3136 or ++$set;
591b5954
TC		 3137 }
3138 }
837a4b43
TC		 3139 $set or return;
3140 return $set;
591b5954
TC		 3141 }
3142 else {
3143 if ($color->isa('Imager::Color')) {
837a4b43
TC		 3144 i_ppix($self->{IMG}, $x, $y, $color)
3145 and return;
591b5954
TC		 3146 }
3147 else {
837a4b43
TC		 3148 i_ppixf($self->{IMG}, $x, $y, $color)
3149 and return;
591b5954
TC		 3150 }
3151 }
3152
3153 $self;
3154}
3155
3156sub getpixel {
3157 my $self = shift;
3158
a9fa203f 3159 my %opts = ( "type"=>'8bit', @_);
591b5954
TC		 3160
3161 unless (exists $opts{'x'} && exists $opts{'y'}) {
3162 $self->{ERRSTR} = 'missing x and y parameters';
3163 return undef;
3164 }
3165
3166 my $x = $opts{'x'};
3167 my $y = $opts{'y'};
3168 if (ref $x && ref $y) {
3169 unless (@$x == @$y) {
3170 $self->{ERRSTR} = 'length of x and y mismatch';
3171 return undef;
3172 }
3173 my @result;
a9fa203f 3174 if ($opts{"type"} eq '8bit') {
591b5954
TC		 3175 for my $i (0..$#{$opts{'x'}}) {
3176 push(@result, i_get_pixel($self->{IMG}, $x->[$i], $y->[$i]));
3177 }
3178 }
3179 else {
3180 for my $i (0..$#{$opts{'x'}}) {
3181 push(@result, i_gpixf($self->{IMG}, $x->[$i], $y->[$i]));
3182 }
3183 }
3184 return wantarray ? @result : \@result;
3185 }
3186 else {
a9fa203f 3187 if ($opts{"type"} eq '8bit') {
591b5954
TC		 3188 return i_get_pixel($self->{IMG}, $x, $y);
3189 }
3190 else {
3191 return i_gpixf($self->{IMG}, $x, $y);
3192 }
3193 }
3194
3195 $self;
3196}
3197
ca4d914e
TC		 3198sub getscanline {
3199 my $self = shift;
3200 my %opts = ( type => '8bit', x=>0, @_);
3201
4cda4e76
TC		 3202 $self->_valid_image or return;
3203
ca4d914e
TC		 3204 defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3205
3206 unless (defined $opts{'y'}) {
3207 $self->_set_error("missing y parameter");
3208 return;
3209 }
3210
3211 if ($opts{type} eq '8bit') {
3212 return i_glin($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
4cda4e76 3213 $opts{'y'});
ca4d914e
TC		 3214 }
3215 elsif ($opts{type} eq 'float') {
3216 return i_glinf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
4cda4e76
TC		 3217 $opts{'y'});
3218 }
3219 elsif ($opts{type} eq 'index') {
3220 unless (i_img_type($self->{IMG})) {
3221 $self->_set_error("type => index only valid on paletted images");
3222 return;
3223 }
3224 return i_gpal($self->{IMG}, $opts{x}, $opts{x} + $opts{width},
3225 $opts{'y'});
ca4d914e
TC		 3226 }
3227 else {
3228 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3229 return;
3230 }
3231}
3232
3233sub setscanline {
3234 my $self = shift;
3235 my %opts = ( x=>0, @_);
3236
4cda4e76
TC		 3237 $self->_valid_image or return;
3238
ca4d914e
TC		 3239 unless (defined $opts{'y'}) {
3240 $self->_set_error("missing y parameter");
3241 return;
3242 }
3243
3244 if (!$opts{type}) {
3245 if (ref $opts{pixels} && @{$opts{pixels}}) {
3246 # try to guess the type
3247 if ($opts{pixels}[0]->isa('Imager::Color')) {
3248 $opts{type} = '8bit';
3249 }
3250 elsif ($opts{pixels}[0]->isa('Imager::Color::Float')) {
3251 $opts{type} = 'float';
3252 }
3253 else {
3254 $self->_set_error("missing type parameter and could not guess from pixels");
3255 return;
3256 }
3257 }
3258 else {
3259 # default
3260 $opts{type} = '8bit';
3261 }
3262 }
3263
3264 if ($opts{type} eq '8bit') {
3265 if (ref $opts{pixels}) {
3266 return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3267 }
3268 else {
3269 return i_plin($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3270 }
3271 }
3272 elsif ($opts{type} eq 'float') {
3273 if (ref $opts{pixels}) {
3274 return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3275 }
3276 else {
3277 return i_plinf($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3278 }
3279 }
4cda4e76
TC		 3280 elsif ($opts{type} eq 'index') {
3281 if (ref $opts{pixels}) {
3282 return i_ppal($self->{IMG}, $opts{x}, $opts{'y'}, @{$opts{pixels}});
3283 }
3284 else {
3285 return i_ppal_p($self->{IMG}, $opts{x}, $opts{'y'}, $opts{pixels});
3286 }
3287 }
ca4d914e
TC		 3288 else {
3289 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3290 return;
3291 }
3292}
3293
3294sub getsamples {
3295 my $self = shift;
bd8052a6 3296 my %opts = ( type => '8bit', x=>0, offset => 0, @_);
ca4d914e
TC		 3297
3298 defined $opts{width} or $opts{width} = $self->getwidth - $opts{x};
3299
3300 unless (defined $opts{'y'}) {
3301 $self->_set_error("missing y parameter");
3302 return;
3303 }
3304
3305 unless ($opts{channels}) {
3306 $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3307 }
3308
bd8052a6
TC		 3309 if ($opts{target}) {
3310 my $target = $opts{target};
3311 my $offset = $opts{offset};
3312 if ($opts{type} eq '8bit') {
3313 my @samples = i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3314 $opts{y}, @{$opts{channels}})
3315 or return;
3316 @{$target}{$offset .. $offset + @samples - 1} = @samples;
3317 return scalar(@samples);
3318 }
3319 elsif ($opts{type} eq 'float') {
3320 my @samples = i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3321 $opts{y}, @{$opts{channels}});
3322 @{$target}{$offset .. $offset + @samples - 1} = @samples;
3323 return scalar(@samples);
3324 }
3325 elsif ($opts{type} =~ /^(\d+)bit$/) {
3326 my $bits = $1;
3327
3328 my @data;
3329 my $count = i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3330 $opts{y}, $bits, $target,
3331 $offset, @{$opts{channels}});
3332 unless (defined $count) {
3333 $self->_set_error(Imager->_error_as_msg);
3334 return;
3335 }
3336
3337 return $count;
3338 }
3339 else {
3340 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3341 return;
3342 }
ca4d914e
TC		 3343 }
3344 else {
bd8052a6
TC		 3345 if ($opts{type} eq '8bit') {
3346 return i_gsamp($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3347 $opts{y}, @{$opts{channels}});
3348 }
3349 elsif ($opts{type} eq 'float') {
3350 return i_gsampf($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3351 $opts{y}, @{$opts{channels}});
3352 }
3353 elsif ($opts{type} =~ /^(\d+)bit$/) {
3354 my $bits = $1;
3355
3356 my @data;
3357 i_gsamp_bits($self->{IMG}, $opts{x}, $opts{x}+$opts{width},
3358 $opts{y}, $bits, \@data, 0, @{$opts{channels}})
3359 or return;
3360 return @data;
3361 }
3362 else {
3363 $self->_set_error("invalid type parameter - must be '8bit' or 'float'");
3364 return;
3365 }
3366 }
3367}
3368
3369sub setsamples {
3370 my $self = shift;
3371 my %opts = ( x => 0, offset => 0, @_ );
3372
3373 unless ($self->{IMG}) {
3374 $self->_set_error('setsamples: empty input image');
3375 return;
3376 }
3377
3378 unless(defined $opts{data} && ref $opts{data}) {
3379 $self->_set_error('setsamples: data parameter missing or invalid');
ca4d914e
TC		 3380 return;
3381 }
bd8052a6
TC		 3382
3383 unless ($opts{channels}) {
3384 $opts{channels} = [ 0 .. $self->getchannels()-1 ];
3385 }
3386
3387 unless ($opts{type} && $opts{type} =~ /^(\d+)bit$/) {
3388 $self->_set_error('setsamples: type parameter missing or invalid');
3389 return;
3390 }
3391 my $bits = $1;
3392
3393 unless (defined $opts{width}) {
3394 $opts{width} = $self->getwidth() - $opts{x};
3395 }
3396
3397 my $count = i_psamp_bits($self->{IMG}, $opts{x}, $opts{y}, $bits,
3398 $opts{channels}, $opts{data}, $opts{offset},
3399 $opts{width});
3400 unless (defined $count) {
3401 $self->_set_error(Imager->_error_as_msg);
3402 return;
3403 }
3404
3405 return $count;
ca4d914e
TC		 3406}
3407
f5991c03
TC		 3408# make an identity matrix of the given size
3409sub _identity {
3410 my ($size) = @_;
3411
3412 my $matrix = [ map { [ (0) x $size ] } 1..$size ];
3413 for my $c (0 .. ($size-1)) {
3414 $matrix->[$c][$c] = 1;
3415 }
3416 return $matrix;
3417}
3418
3419# general function to convert an image
3420sub convert {
3421 my ($self, %opts) = @_;
3422 my $matrix;
3423
34b3f7e6
TC		 3424 unless (defined wantarray) {
3425 my @caller = caller;
3426 warn "convert() called in void context - convert() returns the converted image at $caller[1] line $caller[2]\n";
3427 return;
3428 }
3429
f5991c03
TC		 3430 # the user can either specify a matrix or preset
3431 # the matrix overrides the preset
3432 if (!exists($opts{matrix})) {
3433 unless (exists($opts{preset})) {
3434 $self->{ERRSTR} = "convert() needs a matrix or preset";
3435 return;
3436 }
3437 else {
3438 if ($opts{preset} eq 'gray' || $opts{preset} eq 'grey') {
3439 # convert to greyscale, keeping the alpha channel if any
3440 if ($self->getchannels == 3) {
3441 $matrix = [ [ 0.222, 0.707, 0.071 ] ];
3442 }
3443 elsif ($self->getchannels == 4) {
3444 # preserve the alpha channel
3445 $matrix = [ [ 0.222, 0.707, 0.071, 0 ],
3446 [ 0, 0, 0, 1 ] ];
3447 }
3448 else {
3449 # an identity
3450 $matrix = _identity($self->getchannels);
3451 }
3452 }
3453 elsif ($opts{preset} eq 'noalpha') {
3454 # strip the alpha channel
3455 if ($self->getchannels == 2 or $self->getchannels == 4) {
3456 $matrix = _identity($self->getchannels);
3457 pop(@$matrix); # lose the alpha entry
3458 }
3459 else {
3460 $matrix = _identity($self->getchannels);
3461 }
3462 }
3463 elsif ($opts{preset} eq 'red' || $opts{preset} eq 'channel0') {
3464 # extract channel 0
3465 $matrix = [ [ 1 ] ];
3466 }
3467 elsif ($opts{preset} eq 'green' || $opts{preset} eq 'channel1') {
3468 $matrix = [ [ 0, 1 ] ];
3469 }
3470 elsif ($opts{preset} eq 'blue' || $opts{preset} eq 'channel2') {
3471 $matrix = [ [ 0, 0, 1 ] ];
3472 }
3473 elsif ($opts{preset} eq 'alpha') {
3474 if ($self->getchannels == 2 or $self->getchannels == 4) {
3475 $matrix = [ [ (0) x ($self->getchannels-1), 1 ] ];
3476 }
3477 else {
3478 # the alpha is just 1 <shrug>
3479 $matrix = [ [ (0) x $self->getchannels, 1 ] ];
3480 }
3481 }
3482 elsif ($opts{preset} eq 'rgb') {
3483 if ($self->getchannels == 1) {
3484 $matrix = [ [ 1 ], [ 1 ], [ 1 ] ];
3485 }
3486 elsif ($self->getchannels == 2) {
3487 # preserve the alpha channel
3488 $matrix = [ [ 1, 0 ], [ 1, 0 ], [ 1, 0 ], [ 0, 1 ] ];
3489 }
3490 else {
3491 $matrix = _identity($self->getchannels);
3492 }
3493 }
3494 elsif ($opts{preset} eq 'addalpha') {
3495 if ($self->getchannels == 1) {
3496 $matrix = _identity(2);
3497 }
3498 elsif ($self->getchannels == 3) {
3499 $matrix = _identity(4);
3500 }
3501 else {
3502 $matrix = _identity($self->getchannels);
3503 }
3504 }
3505 else {
3506 $self->{ERRSTR} = "Unknown convert preset $opts{preset}";
3507 return undef;
3508 }
3509 }
3510 }
3511 else {
3512 $matrix = $opts{matrix};
3513 }
3514
d5477d3d
TC		 3515 my $new = Imager->new;
3516 $new->{IMG} = i_convert($self->{IMG}, $matrix);
3517 unless ($new->{IMG}) {
f5991c03
TC		 3518 # most likely a bad matrix
3519 $self->{ERRSTR} = _error_as_msg();
3520 return undef;
3521 }
3522 return $new;
3523}
40eba1ea
AMH		 3524
3525
40eba1ea 3526# general function to map an image through lookup tables
9495ee93 3527
40eba1ea
AMH		 3528sub map {
3529 my ($self, %opts) = @_;
9495ee93 3530 my @chlist = qw( red green blue alpha );
40eba1ea
AMH		 3531
3532 if (!exists($opts{'maps'})) {
3533 # make maps from channel maps
3534 my $chnum;
3535 for $chnum (0..$#chlist) {
9495ee93
AMH		 3536 if (exists $opts{$chlist[$chnum]}) {
3537 $opts{'maps'}[$chnum] = $opts{$chlist[$chnum]};
3538 } elsif (exists $opts{'all'}) {
3539 $opts{'maps'}[$chnum] = $opts{'all'};
3540 }
40eba1ea
AMH		 3541 }
3542 }
3543 if ($opts{'maps'} and $self->{IMG}) {
3544 i_map($self->{IMG}, $opts{'maps'} );
3545 }
3546 return $self;
3547}
3548
dff75dee
TC		 3549sub difference {
3550 my ($self, %opts) = @_;
3551
3552 defined $opts{mindist} or $opts{mindist} = 0;
3553
3554 defined $opts{other}
3555 or return $self->_set_error("No 'other' parameter supplied");
3556 defined $opts{other}{IMG}
3557 or return $self->_set_error("No image data in 'other' image");
3558
3559 $self->{IMG}
3560 or return $self->_set_error("No image data");
3561
3562 my $result = Imager->new;
3563 $result->{IMG} = i_diff_image($self->{IMG}, $opts{other}{IMG},
3564 $opts{mindist})
3565 or return $self->_set_error($self->_error_as_msg());
3566
3567 return $result;
3568}
3569
02d1d628
AMH		 3570# destructive border - image is shrunk by one pixel all around
3571
3572sub border {
3573 my ($self,%opts)=@_;
3574 my($tx,$ty)=($self->getwidth()-1,$self->getheight()-1);
3575 $self->polyline('x'=>[0,$tx,$tx,0,0],'y'=>[0,0,$ty,$ty,0],%opts);
3576}
3577
3578
3579# Get the width of an image
3580
3581sub getwidth {
3582 my $self = shift;
3583 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3584 return (i_img_info($self->{IMG}))[0];
3585}
3586
3587# Get the height of an image
3588
3589sub getheight {
3590 my $self = shift;
3591 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3592 return (i_img_info($self->{IMG}))[1];
3593}
3594
3595# Get number of channels in an image
3596
3597sub getchannels {
3598 my $self = shift;
3599 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3600 return i_img_getchannels($self->{IMG});
3601}
3602
3603# Get channel mask
3604
3605sub getmask {
3606 my $self = shift;
3607 if (!defined($self->{IMG})) { $self->{ERRSTR} = 'image is empty'; return undef; }
3608 return i_img_getmask($self->{IMG});
3609}
3610
3611# Set channel mask
3612
3613sub setmask {
3614 my $self = shift;
3615 my %opts = @_;
35f40526
TC		 3616 if (!defined($self->{IMG})) {
3617 $self->{ERRSTR} = 'image is empty';
3618 return undef;
3619 }
3620 unless (defined $opts{mask}) {
3621 $self->_set_error("mask parameter required");
3622 return;
3623 }
02d1d628 3624 i_img_setmask( $self->{IMG} , $opts{mask} );
35f40526
TC		 3625
3626 1;
02d1d628
AMH		 3627}
3628
3629# Get number of colors in an image
3630
3631sub getcolorcount {
3632 my $self=shift;
9d540150 3633 my %opts=('maxcolors'=>2**30,@_);
02d1d628
AMH		 3634 if (!defined($self->{IMG})) { $self->{ERRSTR}='image is empty'; return undef; }
3635 my $rc=i_count_colors($self->{IMG},$opts{'maxcolors'});
3636 return ($rc==-1? undef : $rc);
3637}
3638
fe622da1
TC		 3639# Returns a reference to a hash. The keys are colour named (packed) and the
3640# values are the number of pixels in this colour.
3641sub getcolorusagehash {
a60905e4
TC		 3642 my $self = shift;
3643
3644 my %opts = ( maxcolors => 2**30, @_ );
3645 my $max_colors = $opts{maxcolors};
3646 unless (defined $max_colors && $max_colors > 0) {
3647 $self->_set_error('maxcolors must be a positive integer');
3648 return;
3649 }
3650
3651 unless (defined $self->{IMG}) {
3652 $self->_set_error('empty input image');
3653 return;
3654 }
3655
3656 my $channels= $self->getchannels;
3657 # We don't want to look at the alpha channel, because some gifs using it
3658 # doesn't define it for every colour (but only for some)
3659 $channels -= 1 if $channels == 2 or $channels == 4;
3660 my %color_use;
3661 my $height = $self->getheight;
3662 for my $y (0 .. $height - 1) {
3663 my $colors = $self->getsamples('y' => $y, channels => [ 0 .. $channels - 1 ]);
3664 while (length $colors) {
3665 $color_use{ substr($colors, 0, $channels, '') }++;
fe622da1 3666 }
a60905e4
TC		 3667 keys %color_use > $max_colors
3668 and return;
3669 }
3670 return \%color_use;
fe622da1
TC		 3671}
3672
3673# This will return a ordered array of the colour usage. Kind of the sorted
3674# version of the values of the hash returned by getcolorusagehash.
3675# You might want to add safety checks and change the names, etc...
3676sub getcolorusage {
a60905e4
TC		 3677 my $self = shift;
3678
3679 my %opts = ( maxcolors => 2**30, @_ );
3680 my $max_colors = $opts{maxcolors};
3681 unless (defined $max_colors && $max_colors > 0) {
3682 $self->_set_error('maxcolors must be a positive integer');
3683 return;
3684 }
3685
3686 unless (defined $self->{IMG}) {
3687 $self->_set_error('empty input image');
3688 return undef;
3689 }
3690
3691 return i_get_anonymous_color_histo($self->{IMG}, $max_colors);
fe622da1
TC		 3692}
3693
02d1d628
AMH		 3694# draw string to an image
3695
3696sub string {
3697 my $self = shift;
3698 unless ($self->{IMG}) { $self->{ERRSTR}='empty input image'; return undef; }
3699
3700 my %input=('x'=>0, 'y'=>0, @_);
4314a320 3701 defined($input{string}) or $input{string} = $input{text};
02d1d628 3702
e922ae66 3703 unless(defined $input{string}) {
02d1d628
AMH		 3704 $self->{ERRSTR}="missing required parameter 'string'";
3705 return;
3706 }
3707
3708 unless($input{font}) {
3709 $self->{ERRSTR}="missing required parameter 'font'";
3710 return;
3711 }
3712
faa9b3e7 3713 unless ($input{font}->draw(image=>$self, %input)) {
faa9b3e7
TC		 3714 return;
3715 }
02d1d628
AMH		 3716
3717 return $self;
3718}
3719
a7ccc5e2
TC		 3720sub align_string {
3721 my $self = shift;
e922ae66
TC		 3722
3723 my $img;
3724 if (ref $self) {
3725 unless ($self->{IMG}) {
3726 $self->{ERRSTR}='empty input image';
3727 return;
3728 }
c9cb3397 3729 $img = $self;
e922ae66
TC		 3730 }
3731 else {
3732 $img = undef;
3733 }
a7ccc5e2
TC		 3734
3735 my %input=('x'=>0, 'y'=>0, @_);
3736 $input{string}||=$input{text};
3737
3738 unless(exists $input{string}) {
e922ae66 3739 $self->_set_error("missing required parameter 'string'");
a7ccc5e2
TC		 3740 return;
3741 }
3742
3743 unless($input{font}) {
e922ae66 3744 $self->_set_error("missing required parameter 'font'");
a7ccc5e2
TC		 3745 return;
3746 }
3747
3748 my @result;
e922ae66 3749 unless (@result = $input{font}->align(image=>$img, %input)) {
a7ccc5e2
TC		 3750 return;
3751 }
3752
3753 return wantarray ? @result : $result[0];
3754}
3755
77157728
TC		 3756my @file_limit_names = qw/width height bytes/;
3757
3758sub set_file_limits {
3759 shift;
3760
3761 my %opts = @_;
3762 my %values;
3763
3764 if ($opts{reset}) {
3765 @values{@file_limit_names} = (0) x @file_limit_names;
3766 }
3767 else {
3768 @values{@file_limit_names} = i_get_image_file_limits();
3769 }
3770
3771 for my $key (keys %values) {
3772 defined $opts{$key} and $values{$key} = $opts{$key};
3773 }
3774
3775 i_set_image_file_limits($values{width}, $values{height}, $values{bytes});
3776}
3777
3778sub get_file_limits {
3779 i_get_image_file_limits();
3780}
3781
02d1d628
AMH		 3782# Shortcuts that can be exported
3783
3784sub newcolor { Imager::Color->new(@_); }
3785sub newfont { Imager::Font->new(@_); }
bd8052a6 3786sub NCF { Imager::Color::Float->new(@_) }
02d1d628
AMH		 3787
3788*NC=*newcolour=*newcolor;
3789*NF=*newfont;
3790
3791*open=\&read;
3792*circle=\&arc;
3793
3794
3795#### Utility routines
3796
faa9b3e7
TC		 3797sub errstr {
3798 ref $_[0] ? $_[0]->{ERRSTR} : $ERRSTR
3799}
02d1d628 3800
10461f9a
TC		 3801sub _set_error {
3802 my ($self, $msg) = @_;
3803
3804 if (ref $self) {
3805 $self->{ERRSTR} = $msg;
3806 }
3807 else {
3808 $ERRSTR = $msg;
3809 }
dff75dee 3810 return;
10461f9a
TC		 3811}
3812
02d1d628
AMH		 3813# Default guess for the type of an image from extension
3814
3815sub def_guess_type {
3816 my $name=lc(shift);
3817 my $ext;
3818 $ext=($name =~ m/\.([^\.]+)$/)[0];
3819 return 'tiff' if ($ext =~ m/^tiff?$/);
3820 return 'jpeg' if ($ext =~ m/^jpe?g$/);
3821 return 'pnm' if ($ext =~ m/^p[pgb]m$/);
3822 return 'png' if ($ext eq "png");
705fd961 3823 return 'bmp' if ($ext eq "bmp" || $ext eq "dib");
1ec86afa 3824 return 'tga' if ($ext eq "tga");
d5477d3d 3825 return 'sgi' if ($ext eq "rgb" || $ext eq "bw" || $ext eq "sgi" || $ext eq "rgba");
02d1d628 3826 return 'gif' if ($ext eq "gif");
10461f9a 3827 return 'raw' if ($ext eq "raw");
2b405c9e 3828 return lc $ext; # best guess
02d1d628
AMH		 3829 return ();
3830}
3831
9b1ec2b8
TC		 3832sub combines {
3833 return @combine_types;
3834}
3835
02d1d628
AMH		 3836# get the minimum of a list
3837
bf1573f9 3838sub _min {
02d1d628
AMH		 3839 my $mx=shift;
3840 for(@_) { if ($_<$mx) { $mx=$_; }}
3841 return $mx;
3842}
3843
3844# get the maximum of a list
3845
bf1573f9 3846sub _max {
02d1d628
AMH		 3847 my $mx=shift;
3848 for(@_) { if ($_>$mx) { $mx=$_; }}
3849 return $mx;
3850}
3851
3852# string stuff for iptc headers
3853
bf1573f9 3854sub _clean {
02d1d628
AMH		 3855 my($str)=$_[0];
3856 $str = substr($str,3);
3857 $str =~ s/[\n\r]//g;
3858 $str =~ s/\s+/ /g;
3859 $str =~ s/^\s//;
3860 $str =~ s/\s$//;
3861 return $str;
3862}
3863
3864# A little hack to parse iptc headers.
3865
3866sub parseiptc {
3867 my $self=shift;
3868 my(@sar,$item,@ar);
3869 my($caption,$photogr,$headln,$credit);
3870
3871 my $str=$self->{IPTCRAW};
3872
24ae6325
TC		 3873 defined $str
3874 or return;
02d1d628
AMH		 3875
3876 @ar=split(/8BIM/,$str);
3877
3878 my $i=0;
3879 foreach (@ar) {
3880 if (/^\004\004/) {
3881 @sar=split(/\034\002/);
3882 foreach $item (@sar) {
cdd23610 3883 if ($item =~ m/^x/) {
bf1573f9 3884 $caption = _clean($item);
02d1d628
AMH		 3885 $i++;
3886 }
cdd23610 3887 if ($item =~ m/^P/) {
bf1573f9 3888 $photogr = _clean($item);
02d1d628
AMH		 3889 $i++;
3890 }
cdd23610 3891 if ($item =~ m/^i/) {
bf1573f9 3892 $headln = _clean($item);
02d1d628
AMH		 3893 $i++;
3894 }
cdd23610 3895 if ($item =~ m/^n/) {
bf1573f9 3896 $credit = _clean($item);
02d1d628
AMH		 3897 $i++;
3898 }
3899 }
3900 }
3901 }
3902 return (caption=>$caption,photogr=>$photogr,headln=>$headln,credit=>$credit);
3903}
3904
92bda632
TC		 3905sub Inline {
3906 my ($lang) = @_;
3907
3908 $lang eq 'C'
3909 or die "Only C language supported";
3910
3911 require Imager::ExtUtils;
3912 return Imager::ExtUtils->inline_config;
3913}
02d1d628 3914
ffddd407
TC		 3915# threads shouldn't try to close raw Imager objects
3916sub Imager::ImgRaw::CLONE_SKIP { 1 }
3917
02d1d628
AMH		 39181;
3919__END__
3920# Below is the stub of documentation for your module. You better edit it!
3921
3922=head1 NAME
3923
3924Imager - Perl extension for Generating 24 bit Images
3925
3926=head1 SYNOPSIS
3927
0e418f1e
AMH		 3928 # Thumbnail example
3929
3930 #!/usr/bin/perl -w
3931 use strict;
10461f9a 3932 use Imager;
02d1d628 3933
0e418f1e
AMH		 3934 die "Usage: thumbmake.pl filename\n" if !-f $ARGV[0];
3935 my $file = shift;
3936
3937 my $format;
3938
e36d02ad 3939 # see Imager::Files for information on the read() method
2f2a6e54
TC		 3940 my $im = Imager->new(file=>$file)
3941 or die Imager->errstr();
0e418f1e
AMH		 3942
3943 $file =~ s/\.[^.]*$//;
3944
3945 # Create smaller version
cf7a7d18 3946 # documented in Imager::Transformations
0e418f1e
AMH		 3947 my $thumb = $img->scale(scalefactor=>.3);
3948
3949 # Autostretch individual channels
3950 $thumb->filter(type=>'autolevels');
3951
3952 # try to save in one of these formats
3953 SAVE:
3954
c3be83fe 3955 for $format ( qw( png gif jpeg tiff ppm ) ) {
0e418f1e
AMH		 3956 # Check if given format is supported
3957 if ($Imager::formats{$format}) {
3958 $file.="_low.$format";
3959 print "Storing image as: $file\n";
cf7a7d18 3960 # documented in Imager::Files
0e418f1e
AMH		 3961 $thumb->write(file=>$file) or
3962 die $thumb->errstr;
3963 last SAVE;
3964 }
3965 }
3966
02d1d628
AMH		 3967=head1 DESCRIPTION
3968
0e418f1e
AMH		 3969Imager is a module for creating and altering images. It can read and
3970write various image formats, draw primitive shapes like lines,and
3971polygons, blend multiple images together in various ways, scale, crop,
3972render text and more.
02d1d628 3973
5df0fac7
AMH		 3974=head2 Overview of documentation
3975
3976=over
3977
cf7a7d18 3978=item *
5df0fac7 3979
d5556805 3980Imager - This document - Synopsis, Example, Table of Contents and
cf7a7d18 3981Overview.
5df0fac7 3982
cf7a7d18 3983=item *
5df0fac7 3984
985bda61
TC		 3985L<Imager::Tutorial> - a brief introduction to Imager.
3986
3987=item *
3988
e1d57e9d
TC		 3989L<Imager::Cookbook> - how to do various things with Imager.
3990
3991=item *
3992
cf7a7d18
TC		 3993L<Imager::ImageTypes> - Basics of constructing image objects with
3994C<new()>: Direct type/virtual images, RGB(A)/paletted images,
39958/16/double bits/channel, color maps, channel masks, image tags, color
6d0ed98a 3996quantization. Also discusses basic image information methods.
5df0fac7 3997
cf7a7d18 3998=item *
5df0fac7 3999
cf7a7d18
TC		 4000L<Imager::Files> - IO interaction, reading/writing images, format
4001specific tags.
5df0fac7 4002
cf7a7d18 4003=item *
5df0fac7 4004
cf7a7d18
TC		 4005L<Imager::Draw> - Drawing Primitives, lines, boxes, circles, arcs,
4006flood fill.
5df0fac7 4007
cf7a7d18 4008=item *
5df0fac7 4009
cf7a7d18 4010L<Imager::Color> - Color specification.
5df0fac7 4011
cf7a7d18 4012=item *
f5fd108b 4013
cf7a7d18 4014L<Imager::Fill> - Fill pattern specification.
f5fd108b 4015
cf7a7d18 4016=item *
5df0fac7 4017
cf7a7d18
TC		 4018L<Imager::Font> - General font rendering, bounding boxes and font
4019metrics.
5df0fac7 4020
cf7a7d18 4021=item *
5df0fac7 4022
cf7a7d18
TC		 4023L<Imager::Transformations> - Copying, scaling, cropping, flipping,
4024blending, pasting, convert and map.
5df0fac7 4025
cf7a7d18 4026=item *
5df0fac7 4027
cf7a7d18
TC		 4028L<Imager::Engines> - Programmable transformations through
4029C<transform()>, C<transform2()> and C<matrix_transform()>.
5df0fac7 4030
cf7a7d18 4031=item *
5df0fac7 4032
cf7a7d18 4033L<Imager::Filters> - Filters, sharpen, blur, noise, convolve etc. and
5715f7c3 4034filter plug-ins.
5df0fac7 4035
cf7a7d18 4036=item *
5df0fac7 4037
cf7a7d18
TC		 4038L<Imager::Expr> - Expressions for evaluation engine used by
4039transform2().
5df0fac7 4040
cf7a7d18 4041=item *
5df0fac7 4042
cf7a7d18 4043L<Imager::Matrix2d> - Helper class for affine transformations.
5df0fac7 4044
cf7a7d18 4045=item *
5df0fac7 4046
cf7a7d18 4047L<Imager::Fountain> - Helper for making gradient profiles.
5df0fac7 4048
92bda632
TC		 4049=item *
4050
4051L<Imager::API> - using Imager's C API
4052
4053=item *
4054
4055L<Imager::APIRef> - API function reference
4056
4057=item *
4058
4059L<Imager::Inline> - using Imager's C API from Inline::C
4060
4061=item *
4062
4063L<Imager::ExtUtils> - tools to get access to Imager's C API.
4064
5df0fac7
AMH		 4065=back
4066
0e418f1e 4067=head2 Basic Overview
02d1d628 4068
55b287f5
AMH		 4069An Image object is created with C<$img = Imager-E<gt>new()>.
4070Examples:
02d1d628 4071
55b287f5 4072 $img=Imager->new(); # create empty image
e36d02ad 4073 $img->read(file=>'lena.png',type=>'png') or # read image from file