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