use
Symbol
'gensym'
,
'qualify_to_ref'
;
$VERSION
=
'2.83'
;
*stringTTF
= \
&GD::Image::stringFT
;
sub
_make_filehandle {
shift
;
no
strict
'refs'
;
my
$thing
=
shift
;
return
$thing
if
defined
(
fileno
$thing
);
my
$fh
;
{
local
$^W = 0;
my
$pkg
=
caller
(2);
$pkg
=
"main"
unless
defined
$pkg
;;
$fh
= qualify_to_ref(
$thing
,
$pkg
);
}
return
$fh
if
defined
(
fileno
$fh
);
$fh
= gensym;
if
(!
open
(
$fh
,
$thing
)) {
die
"$thing not found: $!"
;
return
undef
;
}
return
$fh
;
}
sub
new {
my
$pack
=
shift
;
if
(
@_
== 1) {
if
(
my
$type
= _image_type(
$_
[0])) {
my
$method
=
"newFrom${type}Data"
;
return
unless
$pack
->can(
$method
);
return
$pack
->
$method
(
$_
[0]);
}
elsif
(-f
$_
[0] and
$_
[0] =~ /\.gd$/) {
my
$type
=
'Gd'
;
return
unless
my
$fh
=
$pack
->_make_filehandle(
$_
[0]);
my
$method
=
"newFrom${type}"
;
return
unless
$pack
->can(
$method
);
return
$pack
->
$method
(
$fh
);
}
elsif
(-f
$_
[0] and
$_
[0] =~ /\.gd2$/) {
my
$type
=
'Gd2'
;
return
unless
my
$fh
=
$pack
->_make_filehandle(
$_
[0]);
my
$method
=
"newFrom${type}"
;
return
unless
$pack
->can(
$method
);
return
$pack
->
$method
(
$fh
);
}
elsif
(-f
$_
[0] and
$_
[0] =~ /\.wbmp$/) {
my
$type
=
'WBMP'
;
return
unless
my
$fh
=
$pack
->_make_filehandle(
$_
[0]);
my
$method
=
"newFrom${type}"
;
return
unless
$pack
->can(
$method
);
return
$pack
->
$method
(
$fh
);
}
elsif
(-f
$_
[0] and
$_
[0] =~ /\.xpm$/) {
my
$type
=
'Xpm'
;
my
$method
=
"newFrom${type}"
;
return
unless
$pack
->can(
$method
);
return
$pack
->
$method
(
$_
[0]);
}
return
unless
my
$fh
=
$pack
->_make_filehandle(
$_
[0]);
my
$magic
;
return
unless
read
(
$fh
,
$magic
,64);
return
unless
my
$type
= _image_type(
$magic
);
seek
(
$fh
,0,0);
my
$method
=
"newFrom${type}"
;
if
(
$type
eq
'Xpm'
) {
return
$pack
->
$method
(
$_
[0]);
}
else
{
return
$pack
->
$method
(
$fh
);
}
}
return
$pack
->_new(
@_
);
}
sub
newTrueColor {
my
$pack
=
shift
;
return
$pack
->_new(
@_
, 1);
}
sub
newPalette {
my
$pack
=
shift
;
return
$pack
->_new(
@_
, 0);
}
sub
ellipse ($$$$$) {
my
(
$self
,
$cx
,
$cy
,
$width
,
$height
,
$color
) =
@_
;
$self
->arc(
$cx
,
$cy
,
$width
,
$height
,0,360,
$color
);
}
sub
polygon {
my
$self
=
shift
;
my
(
$p
,
$c
) =
@_
;
$self
->openPolygon(
$p
,
$c
);
$self
->line( @{
$p
->{
'points'
}->[0]},
@{
$p
->{
'points'
}->[
$p
->{
'length'
}-1]},
$c
);
}
sub
width {
my
$self
=
shift
;
my
@bounds
=
$self
->getBounds;
$bounds
[0];
}
sub
height {
my
$self
=
shift
;
my
@bounds
=
$self
->getBounds;
$bounds
[1];
}
sub
_image_type {
my
$data
=
shift
;
my
$magic
=
substr
(
$data
,0,4);
return
'Png'
if
$magic
eq
"\x89PNG"
;
return
'Jpeg'
if
((
substr
(
$data
,0,3) eq
"\377\330\377"
) &&
ord
(
substr
(
$data
,3,1)) >= 0xc0);
return
'Gif'
if
$magic
eq
"GIF8"
;
return
'Gd2'
if
$magic
eq
"gd2\000"
;
return
'Tiff'
if
$magic
eq
"\x4d\x4d\x00\x2a"
or
$magic
eq
"\x49\x49\x2a\x00"
or
$magic
eq
"IIN1"
;
return
'Bmp'
if
$magic
eq
"BMF\000"
;
return
'Webp'
if
$magic
eq
"RIFF"
and
substr
(
$data
,8,4) eq
"WEBP"
;
if
(
substr
(
$data
,4,4) eq
"ftyp"
) {
my
$boxsize
=
unpack
(
"N"
,
$magic
);
if
(
$boxsize
>=16 && (
$boxsize
& 0x3)==0) {
my
$brand
=
substr
(
$data
,8,4);
my
%compat
;
if
(
$boxsize
>16) {
%compat
=
map
{
$_
=>1}
unpack
(
"(A4)*"
,
substr
(
$data
,16,
$boxsize
-16));
}
return
'Avif'
if
$brand
eq
'avif'
||
$compat
{
'avif'
};
return
'Heif'
if
$brand
eq
'mif1'
||
$brand
eq
'heic'
||
$brand
eq
'heix'
||
$compat
{
'heic'
} ||
$compat
{
'heix'
} ||
$compat
{
'mif1'
};
}
}
return
'Xpm'
if
substr
(
$data
,0,9) eq
"/* XPM */"
;
return
'Xbm'
if
substr
(
$data
,0,8) eq
"#define "
;
return
;
}
sub
clone {
croak(
"Usage: clone(\$image)"
)
unless
@_
== 1;
my
$self
=
shift
;
my
(
$x
,
$y
) =
$self
->getBounds;
my
$new
=
$self
->new(
$x
,
$y
);
return
unless
$new
;
$new
->copy(
$self
,0,0,0,0,
$x
,
$y
);
return
$new
;
}
sub
newFromPng {
croak(
"Usage: newFromPng(class,filehandle,[truecolor])"
)
unless
@_
>=2;
my
(
$class
) =
shift
;
my
(
$f
) =
shift
;
my
$fh
=
$class
->_make_filehandle(
$f
);
binmode
(
$fh
);
$class
->_newFromPng(
$fh
,
@_
);
}
sub
newFromJpeg {
croak(
"Usage: newFromJpeg(class,filehandle,[truecolor])"
)
unless
@_
>=2;
my
(
$class
) =
shift
;
my
(
$f
) =
shift
;
my
$fh
=
$class
->_make_filehandle(
$f
);
binmode
(
$fh
);
$class
->_newFromJpeg(
$fh
,
@_
);
}
sub
newFromGif {
croak(
"Usage: newFromGif(class,filehandle)"
)
unless
@_
==2;
my
(
$class
) =
shift
;
my
(
$f
) =
shift
;
my
$fh
=
$class
->_make_filehandle(
$f
);
binmode
(
$fh
);
$class
->_newFromGif(
$fh
,
@_
);
}
sub
newFromTiff {
croak(
"Usage: newFromTiff(class,filehandle)"
)
unless
@_
==2;
my
(
$class
,
$f
) =
@_
;
my
$fh
=
$class
->_make_filehandle(
$f
);
binmode
(
$fh
);
$class
->_newFromTiff(
$fh
);
}
sub
newFromXbm {
croak(
"Usage: newFromXbm(class,filehandle)"
)
unless
@_
==2;
my
(
$class
,
$f
) =
@_
;
my
$fh
=
$class
->_make_filehandle(
$f
);
binmode
(
$fh
);
$class
->_newFromXbm(
$fh
);
}
sub
newFromWebp {
croak(
"Usage: newFromWebp(class,filehandle)"
)
unless
@_
==2;
my
(
$class
,
$f
) =
@_
;
my
$fh
=
$class
->_make_filehandle(
$f
);
binmode
(
$fh
);
$class
->_newFromWebp(
$fh
);
}
sub
newFromAvif {
croak(
"Usage: newFromAvif(class,filehandle)"
)
unless
@_
==2;
my
(
$class
,
$f
) =
@_
;
my
$fh
=
$class
->_make_filehandle(
$f
);
binmode
(
$fh
);
$class
->_newFromAvif(
$fh
);
}
sub
newFromWBMP {
croak(
"Usage: newFromWBMP(class,filehandle)"
)
unless
@_
==2;
my
(
$class
) =
shift
;
my
(
$f
) =
shift
;
my
$fh
=
$class
->_make_filehandle(
$f
);
binmode
(
$fh
);
$class
->_newFromWBMP(
$fh
,
@_
);
}
sub
newFromBmp {
croak(
"Usage: newFromBmp(class,filehandle)"
)
unless
@_
==2;
my
(
$class
) =
shift
;
my
(
$f
) =
shift
;
my
$fh
=
$class
->_make_filehandle(
$f
);
binmode
(
$fh
);
$class
->_newFromBmp(
$fh
,
@_
);
}
1;