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