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