├── demos ├── tile.png ├── font_list.png ├── fills.pl ├── gd_example.cgi ├── ttf.pl ├── polys.pl ├── truetype_test ├── draw_colors.pl ├── fonttest ├── brushes.pl ├── transform.pl ├── copies.pl ├── shapes.pl └── polyline.pl ├── t ├── test_data │ ├── tile.gd │ ├── frog.jpg │ ├── tile.avif │ ├── tile.gd2 │ ├── tile.gif │ ├── tile.heif │ ├── tile.jpeg │ ├── tile.png │ ├── tile.tiff │ ├── tile.wbmp │ ├── tile.webp │ ├── Generic.ttf │ ├── windows.bmp │ ├── palettemap.png │ ├── images │ │ ├── t1 │ │ │ ├── 1-00.gd │ │ │ ├── 1-00.gd2 │ │ │ ├── 1-00.gif │ │ │ ├── 1-00.jpeg │ │ │ └── 1-00.png │ │ ├── t2 │ │ │ ├── 2-00.gd │ │ │ ├── 2-00.gd2 │ │ │ ├── 2-00.gif │ │ │ ├── 2-00.jpeg │ │ │ └── 2-00.png │ │ ├── t3 │ │ │ ├── 3-00.gd │ │ │ ├── 3-00.gd2 │ │ │ ├── 3-00.gif │ │ │ ├── 3-00.jpeg │ │ │ └── 3-00.png │ │ ├── t4 │ │ │ ├── 4-00.gd │ │ │ ├── 4-00.gd2 │ │ │ ├── 4-00.gif │ │ │ ├── 4-00.jpeg │ │ │ └── 4-00.png │ │ ├── t5 │ │ │ ├── 5-00.gd │ │ │ ├── 5-00.gd2 │ │ │ ├── 5-00.gif │ │ │ ├── 5-00.jpeg │ │ │ └── 5-00.png │ │ ├── t6 │ │ │ ├── 6-00.gd │ │ │ ├── 6-00.gd2 │ │ │ ├── 6-00.gif │ │ │ ├── 6-00.jpeg │ │ │ └── 6-00.png │ │ ├── t7 │ │ │ ├── 7-00.gd │ │ │ ├── 7-00.gd2 │ │ │ ├── 7-00.gif │ │ │ ├── 7-00.jpeg │ │ │ ├── 7-00.png │ │ │ └── 7-01.gd2 │ │ ├── t8 │ │ │ ├── 8-00.gd │ │ │ ├── 8-00.gd2 │ │ │ ├── 8-00.gif │ │ │ ├── 8-00.jpeg │ │ │ ├── 8-00.png │ │ │ ├── 8-00.tiff │ │ │ ├── 8-01.gif │ │ │ ├── 8-01.jpeg │ │ │ ├── 8-01.png │ │ │ ├── 8-01.tiff │ │ │ ├── 8-02.gif │ │ │ ├── 8-02.jpeg │ │ │ ├── 8-02.png │ │ │ ├── 8-02.tiff │ │ │ ├── 8-03.gif │ │ │ ├── 8-03.jpeg │ │ │ ├── 8-03.png │ │ │ └── 8-03.tiff │ │ └── corrupt.png │ ├── tile.xbm │ ├── frog.xbm │ └── frog.xpm ├── z_pod.t ├── caller.t ├── windows_bmp.t ├── fork.t ├── Polyline.t ├── z_manifest.t ├── z_pod-spell-mistakes.t ├── z_kwalitee.t ├── HSV.t ├── transp.t ├── autodetect.t └── GD.t ├── typemap ├── README.QUICKDRAW ├── .whitesource ├── MANIFEST.SKIP ├── testlibs.sh ├── .gitignore ├── LICENSE ├── bdf_scripts ├── README ├── bdftogd ├── bdf2gdfont_pl.PL └── cvtbdf.pl ├── .appveyor.yml ├── testcpan.sh ├── lib └── GD │ ├── Group.pm │ ├── Polygon.pm │ ├── Image.pm │ ├── Image_pm.PL │ └── Polyline.pm ├── .travis.yml ├── const-xs.inc ├── MANIFEST ├── .github └── workflows │ └── testsuite.yml ├── README └── ChangeLog /demos/tile.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/demos/tile.png -------------------------------------------------------------------------------- /demos/font_list.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/demos/font_list.png -------------------------------------------------------------------------------- /t/test_data/tile.gd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/tile.gd -------------------------------------------------------------------------------- /t/test_data/frog.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/frog.jpg -------------------------------------------------------------------------------- /t/test_data/tile.avif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/tile.avif -------------------------------------------------------------------------------- /t/test_data/tile.gd2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/tile.gd2 -------------------------------------------------------------------------------- /t/test_data/tile.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/tile.gif -------------------------------------------------------------------------------- /t/test_data/tile.heif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/tile.heif -------------------------------------------------------------------------------- /t/test_data/tile.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/tile.jpeg -------------------------------------------------------------------------------- /t/test_data/tile.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/tile.png -------------------------------------------------------------------------------- /t/test_data/tile.tiff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/tile.tiff -------------------------------------------------------------------------------- /t/test_data/tile.wbmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/tile.wbmp -------------------------------------------------------------------------------- /t/test_data/tile.webp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/tile.webp -------------------------------------------------------------------------------- /typemap: -------------------------------------------------------------------------------- 1 | TYPEMAP 2 | GD::Image T_PTROBJ 3 | GD::Font T_PTROBJ 4 | GD::Polygon T_PTROBJ 5 | -------------------------------------------------------------------------------- /t/test_data/Generic.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/Generic.ttf -------------------------------------------------------------------------------- /t/test_data/windows.bmp: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/windows.bmp -------------------------------------------------------------------------------- /README.QUICKDRAW: -------------------------------------------------------------------------------- 1 | Support for the archaic Quickdraw format was withdrawn from GD as of version 2.55. 2 | -------------------------------------------------------------------------------- /t/test_data/palettemap.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/palettemap.png -------------------------------------------------------------------------------- /t/test_data/images/t1/1-00.gd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t1/1-00.gd -------------------------------------------------------------------------------- /t/test_data/images/t2/2-00.gd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t2/2-00.gd -------------------------------------------------------------------------------- /t/test_data/images/t3/3-00.gd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t3/3-00.gd -------------------------------------------------------------------------------- /t/test_data/images/t4/4-00.gd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t4/4-00.gd -------------------------------------------------------------------------------- /t/test_data/images/t5/5-00.gd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t5/5-00.gd -------------------------------------------------------------------------------- /t/test_data/images/t6/6-00.gd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t6/6-00.gd -------------------------------------------------------------------------------- /t/test_data/images/t7/7-00.gd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t7/7-00.gd -------------------------------------------------------------------------------- /t/test_data/images/t8/8-00.gd: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-00.gd -------------------------------------------------------------------------------- /t/test_data/images/corrupt.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/corrupt.png -------------------------------------------------------------------------------- /t/test_data/images/t1/1-00.gd2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t1/1-00.gd2 -------------------------------------------------------------------------------- /t/test_data/images/t1/1-00.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t1/1-00.gif -------------------------------------------------------------------------------- /t/test_data/images/t1/1-00.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t1/1-00.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t1/1-00.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t1/1-00.png -------------------------------------------------------------------------------- /t/test_data/images/t2/2-00.gd2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t2/2-00.gd2 -------------------------------------------------------------------------------- /t/test_data/images/t2/2-00.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t2/2-00.gif -------------------------------------------------------------------------------- /t/test_data/images/t2/2-00.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t2/2-00.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t2/2-00.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t2/2-00.png -------------------------------------------------------------------------------- /t/test_data/images/t3/3-00.gd2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t3/3-00.gd2 -------------------------------------------------------------------------------- /t/test_data/images/t3/3-00.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t3/3-00.gif -------------------------------------------------------------------------------- /t/test_data/images/t3/3-00.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t3/3-00.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t3/3-00.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t3/3-00.png -------------------------------------------------------------------------------- /t/test_data/images/t4/4-00.gd2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t4/4-00.gd2 -------------------------------------------------------------------------------- /t/test_data/images/t4/4-00.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t4/4-00.gif -------------------------------------------------------------------------------- /t/test_data/images/t4/4-00.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t4/4-00.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t4/4-00.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t4/4-00.png -------------------------------------------------------------------------------- /t/test_data/images/t5/5-00.gd2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t5/5-00.gd2 -------------------------------------------------------------------------------- /t/test_data/images/t5/5-00.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t5/5-00.gif -------------------------------------------------------------------------------- /t/test_data/images/t5/5-00.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t5/5-00.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t5/5-00.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t5/5-00.png -------------------------------------------------------------------------------- /t/test_data/images/t6/6-00.gd2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t6/6-00.gd2 -------------------------------------------------------------------------------- /t/test_data/images/t6/6-00.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t6/6-00.gif -------------------------------------------------------------------------------- /t/test_data/images/t6/6-00.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t6/6-00.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t6/6-00.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t6/6-00.png -------------------------------------------------------------------------------- /t/test_data/images/t7/7-00.gd2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t7/7-00.gd2 -------------------------------------------------------------------------------- /t/test_data/images/t7/7-00.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t7/7-00.gif -------------------------------------------------------------------------------- /t/test_data/images/t7/7-00.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t7/7-00.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t7/7-00.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t7/7-00.png -------------------------------------------------------------------------------- /t/test_data/images/t7/7-01.gd2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t7/7-01.gd2 -------------------------------------------------------------------------------- /t/test_data/images/t8/8-00.gd2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-00.gd2 -------------------------------------------------------------------------------- /t/test_data/images/t8/8-00.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-00.gif -------------------------------------------------------------------------------- /t/test_data/images/t8/8-00.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-00.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t8/8-00.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-00.png -------------------------------------------------------------------------------- /t/test_data/images/t8/8-00.tiff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-00.tiff -------------------------------------------------------------------------------- /t/test_data/images/t8/8-01.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-01.gif -------------------------------------------------------------------------------- /t/test_data/images/t8/8-01.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-01.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t8/8-01.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-01.png -------------------------------------------------------------------------------- /t/test_data/images/t8/8-01.tiff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-01.tiff -------------------------------------------------------------------------------- /t/test_data/images/t8/8-02.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-02.gif -------------------------------------------------------------------------------- /t/test_data/images/t8/8-02.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-02.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t8/8-02.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-02.png -------------------------------------------------------------------------------- /t/test_data/images/t8/8-02.tiff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-02.tiff -------------------------------------------------------------------------------- /t/test_data/images/t8/8-03.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-03.gif -------------------------------------------------------------------------------- /t/test_data/images/t8/8-03.jpeg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-03.jpeg -------------------------------------------------------------------------------- /t/test_data/images/t8/8-03.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-03.png -------------------------------------------------------------------------------- /t/test_data/images/t8/8-03.tiff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/lstein/Perl-GD/HEAD/t/test_data/images/t8/8-03.tiff -------------------------------------------------------------------------------- /.whitesource: -------------------------------------------------------------------------------- 1 | { 2 | "generalSettings": { 3 | "shouldScanRepo": true 4 | }, 5 | "checkRunSettings": { 6 | "vulnerableCheckRunConclusionLevel": "failure" 7 | } 8 | } -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^\.travis\.yml 2 | ^\.appveyor\.yml 3 | ^\.github/workflows/testsuite\.yml 4 | ^\.config 5 | ^\.gdbinit 6 | \bGD-\d+ 7 | \bGD\.c$ 8 | ^MYMETA\.yml$ 9 | ^MYMETA\.json$ 10 | \.git 11 | ~$ 12 | \.bak$ 13 | \b# 14 | lib/GD/Image.pm 15 | bdf_scripts/bdf2gdfont.pl 16 | -------------------------------------------------------------------------------- /t/z_pod.t: -------------------------------------------------------------------------------- 1 | # -*- perl -*- 2 | use strict; 3 | use Test::More; 4 | 5 | plan skip_all => 'No RELEASE_TESTING' 6 | unless -d '.git' || $ENV{RELEASE_TESTING}; 7 | 8 | eval "use Test::Pod 1.00"; 9 | plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; 10 | all_pod_files_ok(); 11 | -------------------------------------------------------------------------------- /testlibs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | sudo mv /usr/include/gd.h /usr/include/gd.h.orig 3 | for d in `ls /opt/libgd/` 4 | do 5 | echo perl Makefile.PL --lib_gd_path /opt/libgd/$d/lib 6 | perl Makefile.PL --lib_gd_path /opt/libgd/$d/lib 7 | make 8 | make test 9 | done 10 | sudo mv /usr/include/gd.h.orig /usr/include/gd.h 11 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .config.cache 2 | .gdbinit 3 | GD.bs 4 | GD.c 5 | GD.o 6 | GD.obj 7 | META.json 8 | META.yml 9 | MYMETA.json 10 | MYMETA.yml 11 | Makefile 12 | bdf_scripts/bdf2gdfont.pl 13 | blib/ 14 | pm_to_blib 15 | GD-*.tar.gz 16 | log.* 17 | GD.c.gcov 18 | GD.gcda 19 | GD.gcno 20 | GD.xs.gcov 21 | cover_db/ 22 | inline.h.gcov 23 | test_data/ 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The GD.pm interface is copyright 1995-2010, Lincoln D. Stein. This 2 | package and its accompanying libraries is free software; you can 3 | redistribute it and/or modify it under the terms of the GPL (either 4 | version 1, or at your option, any later version) or the Artistic 5 | License 2.0. Refer to LICENSE for the full license text. 6 | package for details. 7 | -------------------------------------------------------------------------------- /bdf_scripts/README: -------------------------------------------------------------------------------- 1 | The bdf2gdfont.pl script will convert an X11 BDF font into a bitmapped 2 | font that can be loaded into GD using the GD::Font->load() method. 3 | Some restrictions apply. Run "perldoc bdf2gdfont.pl" for details. 4 | 5 | Other scripts in this directory were designed for older versions of 6 | libgd in which the fonts are compiled in. Please use with care. 7 | 8 | Lincoln Stein 9 | Fall 2004 10 | -------------------------------------------------------------------------------- /t/caller.t: -------------------------------------------------------------------------------- 1 | # GH #47 2 | use strict; 3 | use GD; 4 | use Test::More 'no_plan'; 5 | use Test::NoWarnings; 6 | 7 | SKIP: { 8 | skip "No PNG support", 1 unless defined &GD::Image::newFromPng; 9 | 10 | # Use of uninitialized value $pkg 11 | my $image = GD::Image->newFromPng('t/test_data/tile.png'); 12 | f(); 13 | } 14 | 15 | sub f 16 | { 17 | my $image = GD::Image->newFromPng('t/test_data/tile.png'); 18 | } 19 | -------------------------------------------------------------------------------- /t/windows_bmp.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 4; 6 | 7 | use_ok('GD'); 8 | 9 | my $winbmp = "t/test_data/windows.bmp"; 10 | SKIP: { 11 | skip "No BMP support", 3 unless defined &GD::Image::newFromBmp; 12 | 13 | my $im = GD::Image->newFromBmp($winbmp); 14 | 15 | ok defined($im), "windows bmp does not return undef"; 16 | is $im->width, 2, "windows bmp has width 2"; 17 | is $im->height, 2, "windows bmp has height 2"; 18 | } 19 | -------------------------------------------------------------------------------- /.appveyor.yml: -------------------------------------------------------------------------------- 1 | # see https://github.com/libgd/libgd/blob/master/appveyor.yml for the full 2 | # matrix 3 | skip_tags: true 4 | 5 | cache: 6 | - C:\strawberry 7 | 8 | install: 9 | - if not exist "C:\strawberry" cinst strawberryperl -y 10 | - set PATH=C:\strawberry\perl\bin;C:\strawberry\perl\site\bin;C:\strawberry\c\bin;%PATH% 11 | - cd C:\projects\%APPVEYOR_PROJECT_NAME% 12 | 13 | build_script: 14 | - perl Makefile.PL MAKE=gmake 15 | - gmake 16 | 17 | test_script: 18 | - gmake test TEST_VERBOSE=1 19 | -------------------------------------------------------------------------------- /t/fork.t: -------------------------------------------------------------------------------- 1 | # see [GH #25] 2 | # check that global %COLORS is concurrency safe 3 | use GD::Simple; 4 | use Test::More; 5 | BEGIN { 6 | eval 'use Test::Fork;'; 7 | plan skip_all => 'Test::Fork required' if $@; 8 | # see cpantesters, not repro for me 9 | plan skip_all => "Test::Fork broken on $^O" if $^O eq 'freebsd'; 10 | } 11 | plan 'no_plan'; 12 | 13 | for (1..10) { 14 | fork_ok(1, 15 | sub{ 16 | GD::Simple->new->bgcolor('transparent'); 17 | ok(!$@, $@); 18 | }); 19 | } 20 | -------------------------------------------------------------------------------- /t/test_data/tile.xbm: -------------------------------------------------------------------------------- 1 | #define tile_width 21 2 | #define tile_height 22 3 | static char tile_bits[] = { 4 | 0xFF, 0xFF, 0x1F, 0xFF, 0xFF, 0x1F, 0xFF, 0xFF, 0x1F, 0xFF, 0xFF, 0x1F, 5 | 0xFF, 0xFF, 0x1F, 0xFF, 0xFF, 0x1F, 0xFF, 0xFF, 0x1F, 0xFF, 0xFF, 0x1F, 6 | 0xFF, 0xFF, 0x1F, 0xFF, 0xFF, 0x1F, 0xFF, 0xFF, 0x1F, 0x00, 0x00, 0x00, 7 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 8 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 9 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, }; 10 | -------------------------------------------------------------------------------- /testcpan.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | p=$(cat ~/.alias-perl | sed 's,alias p=,,') 3 | test -n "$p" || p=perl 4 | alias ppan='$p -S cpan' 5 | $p Makefile.PL && make test && sudo make install clean 6 | ppan -f GD::Graph GD::Text Barcode::Code128 GD::Thumbnail GD::SVG GD::Text::Arc GD::Thumbnail \ 7 | GD::Tiler GD::Wbmp GD::Window GD::Image::AnimatedGif GD::Image::Orientation \ 8 | GD::Image::Scale2x GD::Image::Thumbnail GD::Map GD::Map::Mercator \ 9 | GD::Chart GD::Barcode GD::Arrow GD::3DBarGrapher GD::Dashboard 10 | # wrong tests, assuming stable png 11 | ppan GD::OrgChart 12 | -------------------------------------------------------------------------------- /t/Polyline.t: -------------------------------------------------------------------------------- 1 | # Before `make install' is performed this script should be runnable with 2 | # `make test'. After `make install' it should work as `perl test.pl' 3 | 4 | ######################### 5 | 6 | # change 'tests => 1' to 'tests => last_test_to_print'; 7 | 8 | use Test; 9 | BEGIN { plan tests => 1 }; 10 | use GD::Polyline; 11 | ok(1); # If we made it this far, we're ok. 12 | 13 | ######################### 14 | 15 | # Insert your test code below, the Test module is use()ed here so read 16 | # its man page ( perldoc Test ) for help writing this test script. 17 | 18 | -------------------------------------------------------------------------------- /t/z_manifest.t: -------------------------------------------------------------------------------- 1 | # -*- perl -*- 2 | use Test::More; 3 | if (!-d ".git" or $^O != /^(linux|.*bsd|darwin|solaris|sunos)$/) { 4 | plan skip_all => "requires a git checkout and a unix for git and diff"; 5 | } 6 | plan tests => 1; 7 | 8 | system("git ls-tree -r --name-only HEAD |" 9 | ." grep -E -v '(.gitignore|.appveyor.yml|.whitesource|.github|.travis.yml)' >MANIFEST.git"); 10 | if (-e "MANIFEST.git") { 11 | #diag "MANIFEST.git created with git ls-tree"; 12 | is(`diff -bu MANIFEST.git MANIFEST`, "", "MANIFEST.git compared to MANIFEST") 13 | and unlink "MANIFEST.git"; 14 | } else { 15 | ok(1, "skip no git"); 16 | } 17 | -------------------------------------------------------------------------------- /demos/fills.pl: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | 3 | use GD; 4 | 5 | $im = new GD::Image(100,50); 6 | 7 | # allocate black -- this will be our background 8 | $black = $im->colorAllocate(0, 0, 0); 9 | 10 | # allocate white 11 | $white = $im->colorAllocate(255, 255, 255); 12 | 13 | # allocate red 14 | $red = $im->colorAllocate(255, 0, 0); 15 | 16 | # allocate blue 17 | $blue = $im->colorAllocate(0,0,255); 18 | 19 | #Inscribe an ellipse in the image 20 | $im->arc(50, 25, 98, 48, 0, 360, $white); 21 | 22 | # Flood-fill the ellipse. Fill color is red, and will replace the 23 | # black interior of the ellipse 24 | $im->fill(50, 21, $red); 25 | 26 | binmode STDOUT; 27 | 28 | # print the image to stdout 29 | print $im->png; 30 | 31 | -------------------------------------------------------------------------------- /t/z_pod-spell-mistakes.t: -------------------------------------------------------------------------------- 1 | # -*- perl -*- 2 | use strict; 3 | use Test::More; 4 | 5 | plan skip_all => 'No RELEASE_TESTING' 6 | unless -d '.git' || $ENV{RELEASE_TESTING}; 7 | 8 | eval "use Pod::Spell::CommonMistakes;"; 9 | plan skip_all => "Pod::Spell::CommonMistakes required" 10 | if $@; 11 | 12 | my @docs = qw( 13 | lib/GD.pm 14 | lib/GD/Group.pm 15 | lib/GD/Image.pm 16 | lib/GD/Polygon.pm 17 | lib/GD/Polyline.pm 18 | lib/GD/Simple.pm 19 | ); 20 | plan tests => scalar @docs; 21 | 22 | for my $f (@docs) { 23 | my $r = Pod::Spell::CommonMistakes::check_pod($f); 24 | if ( keys %$r == 0 ) { 25 | ok(1, "$f"); 26 | } else { 27 | ok(0, "$f"); 28 | foreach my $k ( keys %$r ) { 29 | diag " Found: '$k' - Possible spelling: '$r->{$k}'?"; 30 | } 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /demos/gd_example.cgi: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | 3 | use GD; 4 | 5 | print "Content-type: image/png\n\n"; 6 | 7 | # create a new image 8 | $im = new GD::Image(100,100); 9 | 10 | # allocate some colors 11 | $white = $im->colorAllocate(255,255,255); 12 | $black = $im->colorAllocate(0,0,0); 13 | $red = $im->colorAllocate(255,0,0); 14 | $blue = $im->colorAllocate(0,0,255); 15 | 16 | # make the background transparent and interlaced 17 | $im->transparent($white); 18 | $im->interlaced('true'); 19 | 20 | # Put a black frame around the picture 21 | $im->rectangle(0,0,99,99,$black); 22 | 23 | # Draw a blue oval 24 | $im->arc(50,50,95,75,0,360,$blue); 25 | 26 | # And fill it with red 27 | $im->fill(50,50,$red); 28 | 29 | binmode STDOUT; 30 | 31 | # Convert the image to PNG and print it on standard output 32 | print $im->png; 33 | 34 | 35 | -------------------------------------------------------------------------------- /lib/GD/Group.pm: -------------------------------------------------------------------------------- 1 | package GD::Group; 2 | 3 | =head1 NAME 4 | 5 | GD::Group - Simple object for recursive grouping 6 | 7 | =head1 DESCRIPTION 8 | 9 | Does absolutely nothing with GD, but works nicely with GD::SVG. 10 | 11 | =cut 12 | 13 | use strict; 14 | 15 | our $AUTOLOAD; 16 | our $VERSION = 1.00; 17 | 18 | sub AUTOLOAD { 19 | my ($pack,$func_name) = $AUTOLOAD =~ /(.+)::([^:]+)$/; 20 | my $this = shift; 21 | $this->{gd}->currentGroup($this->{group}); 22 | $this->{gd}->$func_name(@_); 23 | } 24 | 25 | sub new { 26 | my $this = shift; 27 | my ($gd,$group) = @_; 28 | return bless {gd => $gd, 29 | group => $group},ref $this || $this; 30 | } 31 | 32 | sub DESTROY { 33 | my $this = shift; 34 | my $gd = $this->{gd}; 35 | my $grp = $this->{group}; 36 | $gd->endGroup($grp); 37 | } 38 | 39 | 40 | 1; 41 | -------------------------------------------------------------------------------- /demos/ttf.pl: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | 3 | use lib '../blib/lib','../blib/arch'; 4 | use GD 1.20; 5 | use constant font => '../t/Generic.ttf'; 6 | 7 | $im = new GD::Image(400,250); 8 | 9 | 10 | warn $GD::VERSION; 11 | 12 | ($white,$black,$red,$blue,$yellow) = 13 | ( 14 | $im->colorAllocate(255, 255, 255), 15 | $im->colorAllocate(0, 0, 0), 16 | $im->colorAllocate(255, 0, 0), 17 | $im->colorAllocate(0,0,255), 18 | $im->colorAllocate(255,250,205) 19 | ); 20 | $im->interlaced(1); # cool venetian blinds effect 21 | 22 | # Some TTFs 23 | $im->stringTTF($black,font,12.0,0.0,20,20,"Hello world!") || die $@; 24 | $im->stringTTF($red,font,14.0,0.0,20,80,"Hello world!")|| die $@;; 25 | $im->stringTTF($blue,font,30.0,-0.5,60,100,"Goodbye cruel world!")|| die $@;; 26 | 27 | binmode STDOUT; 28 | 29 | # print the image to stdout 30 | print $im->png; 31 | 32 | -------------------------------------------------------------------------------- /demos/polys.pl: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | 3 | use GD; 4 | 5 | $im = new GD::Image(225,180); 6 | $black = $im->colorAllocate(0, 0, 0); 7 | $white = $im->colorAllocate(255, 255, 255); 8 | $red = $im->colorAllocate(255, 0, 0); 9 | $blue = $im->colorAllocate(0,0,255); 10 | $yellow = $im->colorAllocate(255,250,205); 11 | 12 | # Create a triangle 13 | $poly = new GD::Polygon; 14 | $poly->addPt(0,50); 15 | $poly->addPt(25,25); 16 | $poly->addPt(50,50); 17 | $im->filledPolygon($poly,$blue); 18 | 19 | # offset it down and to the right 20 | $poly->offset(100,100); 21 | $im->filledPolygon($poly,$red); 22 | 23 | # make it twice as wide and move it upward a bit 24 | $poly->map(50,50,100,100,10,10,110,60); 25 | $im->filledPolygon($poly,$yellow); 26 | 27 | # make it real tall 28 | $poly->map($poly->bounds,50,20,80,160); 29 | $im->filledPolygon($poly,$white); 30 | 31 | binmode STDOUT; 32 | 33 | # print the image to stdout 34 | print $im->png; 35 | 36 | -------------------------------------------------------------------------------- /demos/truetype_test: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | 3 | use lib '../blib/lib','../blib/arch'; 4 | use GD 1.20; 5 | use constant FONT_DIRECTORY => '/dosc/windows/fonts'; 6 | 7 | my $directory = shift || FONT_DIRECTORY; 8 | 9 | my @fonts = <$directory/*.pfa $directory/*.pfb $directory/*.ttf>; 10 | die "Usage: $0 \nDisplays a directory of TrueType and Type1 fonts\n" unless @fonts; 11 | 12 | my $im = new GD::Image(800,600); 13 | my ($white,$black) = ( 14 | $im->colorAllocate(255, 255, 255), 15 | $im->colorAllocate(0, 0, 0)); 16 | 17 | my ($x,$y) = (20,20); 18 | my $max_x = 0; 19 | 20 | for my $font (@fonts) { 21 | my ($font_name) = $font =~ /([^\\\/]+)$/; 22 | warn "rendering $font_name\n"; 23 | (my @h = $im->stringTTF($black,$font,12.0,0.0,$x,$y,$font_name)) || next; 24 | $y = $h[1] + 12 + 5; 25 | $max_x = $max_x > $h[4] ? $max_x : $h[4]; 26 | if ($y > 600) { 27 | $y = 20; 28 | $x = $max_x + 5; 29 | } 30 | } 31 | 32 | binmode STDOUT; 33 | 34 | # print the image to stdout 35 | print $im->png; 36 | 37 | -------------------------------------------------------------------------------- /demos/draw_colors.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use strict; 4 | use lib '.','./blib/lib','./blib/arch'; 5 | use GD::Simple; 6 | 7 | my @color_names = GD::Simple->color_names; 8 | my $cols = int(sqrt(@color_names)); 9 | my $rows = int(@color_names/$cols)+1; 10 | 11 | my $cell_width = 100; 12 | my $cell_height = 50; 13 | my $legend_height = 16; 14 | 15 | my $width = $cols * $cell_width; 16 | my $height = $rows * $cell_height; 17 | 18 | my $img = GD::Simple->new($width,$height); 19 | $img->font(gdSmallFont); 20 | 21 | for (my $c=0; $c<$cols; $c++) { 22 | for (my $r=0; $r<$rows; $r++) { 23 | my $color = $color_names[$c*$rows + $r] or next; 24 | my @topleft = ($c*$cell_width,$r*$cell_height); 25 | my @botright = ($topleft[0]+$cell_width,$topleft[1]+$cell_height-$legend_height); 26 | $img->bgcolor($color); 27 | $img->fgcolor($color); 28 | $img->rectangle(@topleft,@botright); 29 | $img->moveTo($topleft[0]+2,$botright[1]+$legend_height-2); 30 | $img->fgcolor('black'); 31 | $img->string($color); 32 | } 33 | } 34 | 35 | print eval {$img->png} || $img->gif; 36 | -------------------------------------------------------------------------------- /demos/fonttest: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | use lib './blib/arch','./blib/lib'; 4 | 5 | use strict; 6 | use GD; 7 | use subs qw( charmap ); 8 | 9 | my $teststring = pack 'C*', 32, 1 .. 255; 10 | my $im = new GD::Image(640, 500); 11 | my ($white, $black) = 12 | ( 13 | $im->colorAllocate(255, 255, 255), 14 | $im->colorAllocate(0, 0, 0), 15 | ); 16 | 17 | # $im->transparent($white); 18 | $im->interlaced(1); 19 | 20 | charmap($im, gdGiantFont, "GiantFont 9x15", 20, 16); 21 | charmap($im, gdLargeFont, "LargeFont 8x16", 120, 16); 22 | charmap($im, gdMediumBoldFont, "gdMediumBoldFont 7x13b", 220, 13); 23 | charmap($im, gdSmallFont, "gdSmallFont 6x13", 320, 13); 24 | charmap($im, gdTinyFont, "gdTinyFont 5x8", 420, 8); 25 | binmode(STDOUT); 26 | print $im->png; 27 | 28 | sub charmap 29 | { 30 | my $im = shift; 31 | my ($font, $title, $topoffset, $lineskip) = @_; 32 | 33 | $im->string($font, 16, $topoffset, $title.':', $black); 34 | my $line; 35 | for $line (0 .. 4) 36 | { 37 | $im->string($font, 16, $topoffset + (1 + $line) * $lineskip, 38 | substr($teststring, $line * 64, 64), $black); 39 | } 40 | } 41 | 42 | -------------------------------------------------------------------------------- /demos/brushes.pl: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | 3 | use GD; 4 | 5 | $im = new GD::Image(300,300); 6 | 7 | # allocate white 8 | $white = $im->colorAllocate(255, 255, 255); 9 | 10 | # allocate black 11 | $black = $im->colorAllocate(0, 0, 0); 12 | 13 | # allocate red 14 | $red = $im->colorAllocate(255, 0, 0); 15 | 16 | # allocate green 17 | $green = $im->colorAllocate(0,255,0); 18 | 19 | # allocate yellow 20 | $yellow = $im->colorAllocate(255,250,205); 21 | 22 | # Get an image from a png file 23 | open (TILE,"./tile.png") || die; 24 | $tile = newFromPng GD::Image(TILE); 25 | close TILE; 26 | 27 | # use it as a paintbrush 28 | $im->setBrush($tile); 29 | $im->arc(100,100,100,150,0,360,gdBrushed); 30 | 31 | # use it as a tiling pattern to fill a rectangle 32 | $im->setTile($tile); 33 | $im->filledRectangle(150,150,250,250,gdTiled); 34 | $im->rectangle(150,150,250,250,$black); 35 | 36 | # Draw a dotted line 37 | $im->setStyle($green,$green,$green,gdTransparent,$red,$red,$red,gdTransparent); 38 | $im->line(0,280,300,280,gdStyled); 39 | 40 | binmode STDOUT; 41 | 42 | # print the image to stdout 43 | print $im->png; 44 | 45 | -------------------------------------------------------------------------------- /demos/transform.pl: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | 3 | use GD; 4 | use Math::Trig; 5 | 6 | # test scaling, translation, transformation 7 | $im = new GD::Image(380,225); 8 | $black = $im->colorAllocate(0, 0, 0); 9 | $white = $im->colorAllocate(255, 255, 255); 10 | $red = $im->colorAllocate(255, 0, 0); 11 | $blue = $im->colorAllocate(0,0,255); 12 | $yellow = $im->colorAllocate(255,250,205); 13 | 14 | # Create a triangle 15 | $poly = new GD::Polygon; 16 | $poly->toPt(50,50); 17 | $poly->toPt(100,0); 18 | $poly->toPt(-50,50); 19 | $poly->toPt(-50,-50); 20 | 21 | $im->filledPolygon($poly,$yellow); 22 | 23 | # Stretch it a bit 24 | #$poly->scale(1.8,1.0); 25 | #$poly->offset(100,0); 26 | #$im->filledPolygon($poly,$red); 27 | 28 | # Rotate it (scale by 0.5,0.2, rotate by 0,1, move by -25,50) 29 | #$poly->transform(0.5,0.2, 0,1, -25,50); 30 | #$poly->scale(1.5); 31 | $poly->rotate(deg2rad(45)); 32 | $poly->offset(50,100); 33 | warn "blue: [", join(' ',$poly->bounds), "]"; 34 | $im->filledPolygon($poly,$blue); 35 | 36 | $poly->rotate(deg2rad(-90)); 37 | $poly->offset(180,0); 38 | warn "red: [", join(' ',$poly->bounds), "]"; 39 | $im->filledPolygon($poly,$red); 40 | 41 | binmode STDOUT; 42 | 43 | print $im->png; 44 | -------------------------------------------------------------------------------- /t/z_kwalitee.t: -------------------------------------------------------------------------------- 1 | # -*- perl -*- 2 | use strict; 3 | use warnings; 4 | use Test::More; 5 | use Config; 6 | 7 | plan skip_all => 'requires Test::More 0.88' 8 | if Test::More->VERSION < 0.88; 9 | plan skip_all => 'No RELEASE_TESTING' 10 | unless -d '.git' || $ENV{RELEASE_TESTING}; 11 | 12 | # Missing XS dependencies are usually not caught by EUMM 13 | # And they are usually only XS-loaded by the importer, not require. 14 | # But even the most basic deps are missing mostly. 15 | for (qw( Class::XSAccessor Text::CSV_XS List::MoreUtils Algorithm::Diff )) { 16 | eval "use $_;"; 17 | plan skip_all => "$_ required for Test::Kwalitee" 18 | if $@; 19 | } 20 | 21 | if (!-e 'META.yml') { 22 | require File::Copy; 23 | File::Copy::cp('MYMETA.yml','META.yml'); 24 | File::Copy::cp('MYMETA.json','META.json'); 25 | } 26 | 27 | eval { 28 | require Test::Kwalitee; 29 | }; 30 | plan skip_all => "Test::Kwalitee required" 31 | if $@; 32 | 33 | my @args = ('-has_test_pod_coverage'); 34 | if ($Test::Kwalitee::VERSION lt '1.02') { 35 | push @args, '-proper_libs'; 36 | } 37 | Test::Kwalitee->import(tests => [ @args ]); 38 | 39 | #plan skip_all => 'Test::Kwalitee fails with clang -faddress-sanitizer' 40 | # if $Config{ccflags} =~ /-faddress-sanitizer/; 41 | -------------------------------------------------------------------------------- /t/HSV.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # -*- encoding: utf-8; indent-tabs-mode: nil -*- 3 | # See https://rt.cpan.org/Ticket/Display.html?id=120572 4 | # checks 5832 RGB triples, executes a 5 | # round trip RGB -> HSV -> RGB and compares the initial and final 6 | # RGB triples. Of course, there will be rounding errors, so the 7 | # final RGB triple will be a little different from the initial. 8 | # So I compare the Manhattan distance between the two triples and 9 | # compare it with a fuzz value. 10 | 11 | use Test::More tests => 1; 12 | use strict; 13 | use warnings; 14 | use GD::Simple; 15 | 16 | my $fmt = " %3d" x 10; 17 | my $step = 15; 18 | my $fuzz = 3; 19 | my $neg_fix = 0; 20 | 21 | for (my $r0 = 0; $r0 <= 255; $r0 += $step) { 22 | for (my $g0 = 0; $g0 <= 255; $g0 += $step) { 23 | for (my $b0 = 0; $b0 <= 255; $b0 += $step) { 24 | my ($h, $s, $v) = GD::Simple->RGBtoHSV($r0, $g0, $b0); 25 | my ($r1, $g1, $b1) = GD::Simple->HSVtoRGB($h, $s, $v); 26 | my $delta = abs($r1 - $r0) + abs($g1 - $g0) + abs($b1 - $b0); 27 | if ($delta > $fuzz) { 28 | diag(sprintf $fmt, $h, $s, $v, $r0, $g0, $b0, $r1, $g1, $b1, $delta); 29 | fail(); 30 | exit; 31 | } 32 | } 33 | } 34 | } 35 | 36 | pass(); 37 | -------------------------------------------------------------------------------- /demos/copies.pl: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | 3 | use GD; 4 | 5 | $im = new GD::Image(300,300); 6 | $white = $im->colorAllocate(255, 255, 255); 7 | $black = $im->colorAllocate(0, 0, 0); 8 | $red = $im->colorAllocate(255, 0, 0); 9 | $blue = $im->colorAllocate(0,0,255); 10 | $yellow = $im->colorAllocate(255,250,205); 11 | 12 | # Create a flat wide rectangle paintbrush 13 | $brush = new GD::Image(10,10); 14 | $brush->colorAllocate(255,255,255); # white 15 | $brush->colorAllocate(0,0,0); # black 16 | $brush->transparent($white); # white is transparent 17 | $brush->filledRectangle(0,0,5,2,$black); # a black rectangle 18 | 19 | $im->setBrush($brush); 20 | $im->arc(100,100,100,150,0,360,gdBrushed); 21 | 22 | $poly = new GD::Polygon; 23 | $poly->addPt(30,30); 24 | $poly->addPt(100,10); 25 | $poly->addPt(190,290); 26 | $poly->addPt(30,290); 27 | $im->polygon($poly,gdBrushed); 28 | 29 | $im->fill(132,62,$blue); 30 | $im->fill(100,70,$red); 31 | $im->fill(40,40,$yellow); 32 | $im->interlaced(1); 33 | 34 | # Copy the 20,20,70,70 region 35 | # to a location at 150,150 36 | $im->copy($im,150,150,20,20,50,50); 37 | 38 | # Same thing, but doubling the size 39 | $im->copyResized($im,10,200,20,20,100,100,50,50); 40 | 41 | binmode STDOUT; 42 | 43 | # print the image to stdout 44 | print $im->png; 45 | 46 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | sudo: false 3 | dist: trusty 4 | addons: 5 | apt: 6 | packages: 7 | - libgd-dev 8 | 9 | perl: 10 | - "5.10" 11 | - "5.12" 12 | - "5.14" 13 | - "5.16" 14 | - "5.18" 15 | - "5.20-thr" 16 | - "5.22-thr" 17 | - "5.24" 18 | - "5.26" 19 | - "5.28" 20 | - "5.30" 21 | - "5.32" 22 | - "5.32-thr" 23 | - "dev" 24 | 25 | # not run tag pushes 26 | branches: 27 | except: 28 | - /^v?[0-9]+\.[0-9]+/ 29 | 30 | before_install: 31 | - mkdir $HOME/bin || true 32 | - ln -s `which true` $HOME/bin/cpansign 33 | - eval $(curl https://travis-perl.github.io/init) --perl 34 | 35 | install: 36 | - export AUTOMATED_TESTING=1 HARNESS_TIMER=1 AUTHOR_TESTING=0 RELEASE_TESTING=0 37 | - cpan-install --deps # installs prereqs, including recommends 38 | - cpan-install ExtUtils::PkgConfig Math::Trig Test::Kwalitee Test::Pod 39 | Pod::Spell::CommonMistakes Test::Fork 40 | - cpan-install --coverage # installs converage prereqs, if enabled 41 | 42 | #notifications: 43 | # email: 44 | # on_success: change 45 | # on_failure: always 46 | 47 | matrix: 48 | fast_finish: true 49 | include: 50 | - perl: "5.30" 51 | env: COVERAGE=1 AUTHOR_TESTING=1 RELEASE_TESTING=1 # enables coverage+coveralls reporting 52 | allow_failures: 53 | - perl: "dev" 54 | - perl: "5.32" 55 | 56 | -------------------------------------------------------------------------------- /demos/shapes.pl: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | 3 | use GD; 4 | 5 | $im = new GD::Image(300,300); 6 | ($white,$black,$red,$blue,$yellow) = 7 | ( 8 | $im->colorAllocate(255, 255, 255), 9 | $im->colorAllocate(0, 0, 0), 10 | $im->colorAllocate(255, 0, 0), 11 | $im->colorAllocate(0,0,255), 12 | $im->colorAllocate(255,250,205) 13 | ); 14 | $im->transparent($white); # white color is transparent 15 | $im->interlaced(1); # cool venetian blinds effect 16 | 17 | # Create a flat wide rectangle paintbrush 18 | $brush = new GD::Image(10,10); 19 | $brush->colorAllocate(255,255,255); # white 20 | $brush->colorAllocate(0,0,0); # black 21 | $brush->transparent($white); # white is transparent 22 | $brush->filledRectangle(0,0,5,2,$black); # a black rectangle 23 | 24 | # Draw a friendly title (ha!) 25 | $im->string(gdLargeFont,150,10,"Hello world!",$red); 26 | $im->string(gdSmallFont,150,28,"Goodbye cruel world!",$blue); 27 | $im->stringUp(gdTinyFont,280,250,"I'm climbing the wall!",$black); 28 | $im->charUp(gdMediumBoldFont,280,280,"Q",$black); 29 | 30 | # Draw an oval 31 | $im->setBrush($brush); 32 | $im->arc(100,100,100,150,0,360,gdBrushed); 33 | 34 | $poly = new GD::Polygon; 35 | $poly->addPt(30,30); 36 | $poly->addPt(100,10); 37 | $poly->addPt(190,290); 38 | $poly->addPt(30,290); 39 | $im->polygon($poly,gdBrushed); 40 | 41 | $im->fill(132,62,$blue); 42 | $im->fill(100,70,$red); 43 | $im->fill(40,40,$yellow); 44 | 45 | binmode STDOUT; 46 | 47 | # print the image to stdout 48 | print $im->png; 49 | 50 | -------------------------------------------------------------------------------- /t/test_data/frog.xbm: -------------------------------------------------------------------------------- 1 | #define frog_width 48 2 | #define frog_height 48 3 | static char frog_bits[] = { 4 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 5 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 6 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 7 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x70, 0x00, 0x00, 0x00, 0x00, 0x0E, 8 | 0xF8, 0x01, 0x00, 0x00, 0x80, 0x1F, 0xDC, 0x03, 0x00, 0x00, 0xC0, 0x3F, 9 | 0xF6, 0x06, 0x78, 0x3C, 0xE0, 0x7F, 0xEE, 0x0F, 0x84, 0x42, 0xF0, 0x7D, 10 | 0x75, 0x08, 0x32, 0x99, 0xF0, 0xEE, 0x77, 0x18, 0x4A, 0xA5, 0xB8, 0xB8, 11 | 0x1D, 0x30, 0x4A, 0xA5, 0x7C, 0xE1, 0x1F, 0xA0, 0x33, 0x99, 0xBC, 0xD4, 12 | 0x0F, 0x60, 0x84, 0x42, 0x5F, 0xE0, 0x09, 0x10, 0x78, 0x3C, 0x04, 0x80, 13 | 0x0F, 0x0C, 0x00, 0x00, 0x08, 0x80, 0x8A, 0x03, 0x00, 0x00, 0xF0, 0x40, 14 | 0x46, 0x80, 0xFF, 0xFF, 0x01, 0x43, 0xBE, 0xF0, 0xFF, 0xFF, 0x8F, 0x44, 15 | 0x8E, 0xFF, 0xFF, 0xFF, 0xFF, 0x48, 0x8E, 0xFF, 0x87, 0xC3, 0xFF, 0x48, 16 | 0x0E, 0xFF, 0x83, 0x83, 0x7F, 0x48, 0x0C, 0xFE, 0x0F, 0xE0, 0x3F, 0x28, 17 | 0x7C, 0xC8, 0xFF, 0xFF, 0x01, 0x26, 0x8C, 0x1F, 0x00, 0x00, 0x80, 0x29, 18 | 0x18, 0xE0, 0x00, 0x00, 0x60, 0x10, 0xB0, 0xE0, 0x03, 0x00, 0x1E, 0x08, 19 | 0x60, 0x31, 0xFC, 0xFF, 0x1D, 0x04, 0xC0, 0x73, 0xE0, 0x70, 0x1C, 0x02, 20 | 0xC0, 0x67, 0x70, 0x28, 0xC4, 0x03, 0xF0, 0xFC, 0xF0, 0x1A, 0x3C, 0x0C, 21 | 0xBC, 0xE0, 0x70, 0x28, 0x34, 0x34, 0x5E, 0xE2, 0xB3, 0x18, 0xFC, 0x4B, 22 | 0x7F, 0xF2, 0xF3, 0x3F, 0xEE, 0xBE, 0xFF, 0xFF, 0xC1, 0x1F, 0xBF, 0x6D, 23 | 0xFF, 0xFF, 0xCB, 0x1F, 0x01, 0x00, 0xFF, 0xFF, 0xF3, 0x5F, 0x02, 0x00, 24 | 0xFF, 0xFF, 0xFF, 0xFF, 0x01, 0x00, 0xFF, 0xFF, 0xFF, 0xFF, 0x00, 0x00, 25 | 0xFF, 0xFF, 0xFF, 0x07, 0x00, 0x00, 0xFF, 0xFF, 0xFF, 0x01, 0x00, 0x00, 26 | 0xFF, 0xFF, 0x1F, 0x00, 0x00, 0x00, 0xCF, 0xFF, 0x0F, 0x00, 0x00, 0x00, 27 | 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 28 | }; 29 | -------------------------------------------------------------------------------- /t/transp.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | # This is a feature: adding transparency changes the palette 4 | # https://rt.cpan.org/Ticket/Display.html?id=40525 5 | 6 | use Test::More tests => 12; 7 | 8 | use_ok('GD'); 9 | my $gif = "t/test_data/tile.gif"; 10 | my $jpeg = "t/test_data/tile.jpeg"; 11 | my $frog = "t/test_data/frog.jpg"; 12 | 13 | my $im = GD::Image->newFromGif($gif); 14 | 15 | $im->transparent( -1 ); 16 | is($im->transparent, -1, 'image is not transparent'); 17 | 18 | my $closest = $im->colorClosest( 24, 53, 62 ); 19 | $im->transparent( $im->colorClosest( 24, 53, 62 ) ); 20 | 21 | is( $im->transparent, $closest, "transparency preserves RGB before $closest" ); 22 | is( $im->transparent, $im->colorClosest( 24, 53, 62 ), 'transparency preserves RGB after' ); 23 | 24 | SKIP: { 25 | skip "No JPEG support", 8 unless defined &GD::Image::newFromJpeg; 26 | 27 | $im = GD::Image->newFromJpeg($jpeg); 28 | $im->transparent( -1 ); 29 | is($im->transparent, -1, 'image is not transparent'); 30 | 31 | $closest = $im->colorClosest( 24, 53, 62 ); 32 | $im->transparent( $closest ); 33 | 34 | is( $im->transparent, $closest, 'transparency preserves RGB before' ); 35 | 36 | my ($t, $c) = ($im->transparent, $im->colorClosest( 24, 53, 62 )); 37 | if ($t == $c) { 38 | TODO: { 39 | local $TODO = 'colorClosest ignores alpha'; 40 | isnt( $t, $c, "Closest" ); 41 | } 42 | } else { 43 | isnt( $t, $c, "Closest" ); 44 | } 45 | is( $im->transparent, $im->colorClosestAlpha( 24, 53, 62, 255 ), "ClosestAlpha" ); 46 | 47 | $im = GD::Image->newFromJpeg($frog); 48 | $im->transparent( -1 ); 49 | is($im->transparent, -1, 'image is not transparent'); 50 | 51 | $closest = $im->colorClosest( 24, 53, 62 ); 52 | $im->transparent( $closest ); 53 | is( $im->transparent, $closest, 'transparency preserves RGB before' ); 54 | 55 | ($t, $c) = ($im->transparent, $im->colorClosest( 24, 53, 62 )); 56 | if ($t == $c) { 57 | TODO: { 58 | local $TODO = 'colorClosest ignores alpha'; 59 | isnt( $t, $c, "Closest" ); 60 | } 61 | } else { 62 | isnt( $t, $c, "Closest" ); 63 | } 64 | is( $im->transparent, $im->colorClosestAlpha( 24, 53, 62, 255 ), "ClosestAlpha" ); 65 | } 66 | -------------------------------------------------------------------------------- /const-xs.inc: -------------------------------------------------------------------------------- 1 | void 2 | constant(sv) 3 | PREINIT: 4 | #ifdef dXSTARG 5 | dXSTARG; /* Faster if we have it. */ 6 | #else 7 | dTARGET; 8 | #endif 9 | STRLEN len; 10 | int type; 11 | IV iv = 0; 12 | /* NV nv; Uncomment this if you need to return NVs */ 13 | /* const char *pv; Uncomment this if you need to return PVs */ 14 | INPUT: 15 | SV * sv; 16 | const char * s = SvPV(sv, len); 17 | PPCODE: 18 | /* Change this to constant(aTHX_ s, len, &iv, &nv); 19 | if you need to return both NVs and IVs */ 20 | type = constant(aTHX_ s, len, &iv); 21 | /* Return 1 or 2 items. First is error message, or undef if no error. 22 | Second, if present, is found value */ 23 | switch (type) { 24 | case PERL_constant_NOTFOUND: 25 | sv = 26 | sv_2mortal(newSVpvf("%s is not a valid GD macro", s)); 27 | PUSHs(sv); 28 | break; 29 | case PERL_constant_NOTDEF: 30 | sv = sv_2mortal(newSVpvf( 31 | "Your vendor has not defined GD macro %s, used", 32 | s)); 33 | PUSHs(sv); 34 | break; 35 | case PERL_constant_ISIV: 36 | EXTEND(SP, 1); 37 | PUSHs(&PL_sv_undef); 38 | PUSHi(iv); 39 | break; 40 | /* Uncomment this if you need to return NOs 41 | case PERL_constant_ISNO: 42 | EXTEND(SP, 1); 43 | PUSHs(&PL_sv_undef); 44 | PUSHs(&PL_sv_no); 45 | break; */ 46 | /* Uncomment this if you need to return NVs 47 | case PERL_constant_ISNV: 48 | EXTEND(SP, 1); 49 | PUSHs(&PL_sv_undef); 50 | PUSHn(nv); 51 | break; */ 52 | /* Uncomment this if you need to return PVs 53 | case PERL_constant_ISPV: 54 | EXTEND(SP, 1); 55 | PUSHs(&PL_sv_undef); 56 | PUSHp(pv, strlen(pv)); 57 | break; */ 58 | /* Uncomment this if you need to return PVNs 59 | case PERL_constant_ISPVN: 60 | EXTEND(SP, 1); 61 | PUSHs(&PL_sv_undef); 62 | PUSHp(pv, iv); 63 | break; */ 64 | /* Uncomment this if you need to return SVs 65 | case PERL_constant_ISSV: 66 | EXTEND(SP, 1); 67 | PUSHs(&PL_sv_undef); 68 | PUSHs(sv); 69 | break; */ 70 | /* Uncomment this if you need to return UNDEFs 71 | case PERL_constant_ISUNDEF: 72 | break; */ 73 | /* Uncomment this if you need to return UVs 74 | case PERL_constant_ISUV: 75 | EXTEND(SP, 1); 76 | PUSHs(&PL_sv_undef); 77 | PUSHu((UV)iv); 78 | break; */ 79 | /* Uncomment this if you need to return YESs 80 | case PERL_constant_ISYES: 81 | EXTEND(SP, 1); 82 | PUSHs(&PL_sv_undef); 83 | PUSHs(&PL_sv_yes); 84 | break; */ 85 | default: 86 | sv = sv_2mortal(newSVpvf( 87 | "Unexpected return type %d while processing GD macro %s, used", 88 | type, s)); 89 | PUSHs(sv); 90 | } 91 | -------------------------------------------------------------------------------- /t/autodetect.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | use strict; 3 | use warnings; 4 | use Test::More tests => 12; 5 | 6 | use_ok('GD'); 7 | 8 | # FIXME GD, GD2 broken in some configs: gdImageCreateFromGd2Ptr error 9 | #SKIP: { 10 | # skip "No GD support", 1 unless defined &GD::Image::newFromGd; 11 | # my $gd = GD::Image->new("t/test_data/tile.gd"); 12 | # ok defined($gd), "gd detected"; 13 | #} 14 | #SKIP: { 15 | # skip "No GD2 support", 1 unless defined &GD::Image::newFromGd2; 16 | # my $gd2 = GD::Image->new("t/test_data/tile.gd2"); 17 | # ok defined($gd2), "gd2 detected"; 18 | #} 19 | SKIP: { 20 | skip "No GIF support", 1 unless defined &GD::Image::newFromGif; 21 | my $gif = GD::Image->new("t/test_data/tile.gif"); 22 | ok defined($gif), "gif detected"; 23 | } 24 | SKIP: { 25 | skip "No PNG support", 1 unless defined &GD::Image::newFromPng; 26 | my $png = GD::Image->new("t/test_data/tile.png"); 27 | ok defined($png), "png detected"; 28 | } 29 | SKIP: { 30 | skip "No JPEG support", 1 unless defined &GD::Image::newFromJpeg; 31 | my $jpeg = GD::Image->new("t/test_data/tile.jpeg"); 32 | ok defined($jpeg), "jpeg detected"; 33 | } 34 | SKIP: { 35 | skip "No TIFF support", 1 unless defined &GD::Image::newFromTiff; 36 | my $tiff = GD::Image->new("t/test_data/tile.tiff"); 37 | ok defined($tiff), "tiff detected"; 38 | } 39 | SKIP: { 40 | skip "No AVIF support", 1 unless defined &GD::Image::newFromAvif; 41 | my $avif; 42 | eval {$avif = GD::Image->new("t/test_data/tile.avif")}; 43 | if (!$avif and $@ =~ /gdImageCreateFromAvif error/) { 44 | ok 1, "Warning: avif support disabled in libgd"; 45 | } else { 46 | ok defined($avif), "avif detected"; 47 | } 48 | } 49 | SKIP: { 50 | skip "No HEIF support", 1 unless defined &GD::Image::newFromHeif; 51 | my $heif; 52 | eval { $heif = GD::Image->new("t/test_data/tile.heif") }; 53 | if (!$heif and $@ =~ /gdImageCreateFromHeif error/) { 54 | ok 1, "Warning: heif support disabled in libgd"; 55 | } else { 56 | ok defined($heif), "heif detected"; 57 | } 58 | } 59 | SKIP: { 60 | skip "No WEBP support", 1 unless defined &GD::Image::newFromWebp; 61 | my $webp; 62 | eval {$webp = GD::Image->new("t/test_data/tile.webp")}; 63 | if (!$webp and $@ =~ /gdImageCreateFromWebp error/) { 64 | ok 1, "Warning: webp support disabled in libgd"; 65 | } else { 66 | ok defined($webp), "webp detected"; 67 | } 68 | } 69 | SKIP: { 70 | skip "No WBMP support", 1 unless defined &GD::Image::newFromWBMP; 71 | my $wbmp = GD::Image->new("t/test_data/tile.wbmp"); 72 | ok defined($wbmp), "wbmp detected"; 73 | } 74 | SKIP: { 75 | skip "No BMP support", 1 unless defined &GD::Image::newFromBmp; 76 | my $bmp = GD::Image->new("t/test_data/windows.bmp"); 77 | ok defined($bmp), "bmp detected"; 78 | } 79 | 80 | SKIP: { 81 | skip "No XPM support", 1 unless defined &GD::Image::newFromXpm; 82 | my $xpm = GD::Image->new("t/test_data/frog.xpm"); 83 | ok defined($xpm), "xpm detected"; 84 | } 85 | my $xbm = GD::Image->new("t/test_data/frog.xbm"); 86 | ok defined($xbm), "xbm detected"; 87 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | ChangeLog 2 | GD.xs 3 | LICENSE 4 | MANIFEST 5 | MANIFEST.SKIP 6 | Makefile.PL 7 | README 8 | README.QUICKDRAW 9 | bdf_scripts/README 10 | bdf_scripts/bdf2gdfont_pl.PL 11 | bdf_scripts/bdftogd 12 | bdf_scripts/cvtbdf.pl 13 | const-c.inc 14 | const-xs.inc 15 | demos/brushes.pl 16 | demos/copies.pl 17 | demos/draw_colors.pl 18 | demos/fills.pl 19 | demos/font_list.png 20 | demos/fonttest 21 | demos/gd_example.cgi 22 | demos/polyline.pl 23 | demos/polys.pl 24 | demos/shapes.pl 25 | demos/tile.png 26 | demos/transform.pl 27 | demos/truetype_test 28 | demos/ttf.pl 29 | lib/GD.pm 30 | lib/GD/Group.pm 31 | lib/GD/Image.pm 32 | lib/GD/Image_pm.PL 33 | lib/GD/Polygon.pm 34 | lib/GD/Polyline.pm 35 | lib/GD/Simple.pm 36 | t/GD.t 37 | t/HSV.t 38 | t/Polyline.t 39 | t/autodetect.t 40 | t/caller.t 41 | t/fork.t 42 | t/test_data/Generic.ttf 43 | t/test_data/frog.jpg 44 | t/test_data/frog.xbm 45 | t/test_data/frog.xpm 46 | t/test_data/images/corrupt.png 47 | t/test_data/images/t1/1-00.gd 48 | t/test_data/images/t1/1-00.gd2 49 | t/test_data/images/t1/1-00.gif 50 | t/test_data/images/t1/1-00.jpeg 51 | t/test_data/images/t1/1-00.png 52 | t/test_data/images/t2/2-00.gd 53 | t/test_data/images/t2/2-00.gd2 54 | t/test_data/images/t2/2-00.gif 55 | t/test_data/images/t2/2-00.jpeg 56 | t/test_data/images/t2/2-00.png 57 | t/test_data/images/t3/3-00.gd 58 | t/test_data/images/t3/3-00.gd2 59 | t/test_data/images/t3/3-00.gif 60 | t/test_data/images/t3/3-00.jpeg 61 | t/test_data/images/t3/3-00.png 62 | t/test_data/images/t4/4-00.gd 63 | t/test_data/images/t4/4-00.gd2 64 | t/test_data/images/t4/4-00.gif 65 | t/test_data/images/t4/4-00.jpeg 66 | t/test_data/images/t4/4-00.png 67 | t/test_data/images/t5/5-00.gd 68 | t/test_data/images/t5/5-00.gd2 69 | t/test_data/images/t5/5-00.gif 70 | t/test_data/images/t5/5-00.jpeg 71 | t/test_data/images/t5/5-00.png 72 | t/test_data/images/t6/6-00.gd 73 | t/test_data/images/t6/6-00.gd2 74 | t/test_data/images/t6/6-00.gif 75 | t/test_data/images/t6/6-00.jpeg 76 | t/test_data/images/t6/6-00.png 77 | t/test_data/images/t7/7-00.gd 78 | t/test_data/images/t7/7-00.gd2 79 | t/test_data/images/t7/7-00.gif 80 | t/test_data/images/t7/7-00.jpeg 81 | t/test_data/images/t7/7-00.png 82 | t/test_data/images/t7/7-01.gd2 83 | t/test_data/images/t8/8-00.gd 84 | t/test_data/images/t8/8-00.gd2 85 | t/test_data/images/t8/8-00.gif 86 | t/test_data/images/t8/8-00.jpeg 87 | t/test_data/images/t8/8-00.png 88 | t/test_data/images/t8/8-00.tiff 89 | t/test_data/images/t8/8-01.gif 90 | t/test_data/images/t8/8-01.jpeg 91 | t/test_data/images/t8/8-01.png 92 | t/test_data/images/t8/8-01.tiff 93 | t/test_data/images/t8/8-02.gif 94 | t/test_data/images/t8/8-02.jpeg 95 | t/test_data/images/t8/8-02.png 96 | t/test_data/images/t8/8-02.tiff 97 | t/test_data/images/t8/8-03.gif 98 | t/test_data/images/t8/8-03.jpeg 99 | t/test_data/images/t8/8-03.png 100 | t/test_data/images/t8/8-03.tiff 101 | t/test_data/palettemap.png 102 | t/test_data/tile.avif 103 | t/test_data/tile.gd 104 | t/test_data/tile.gd2 105 | t/test_data/tile.gif 106 | t/test_data/tile.heif 107 | t/test_data/tile.jpeg 108 | t/test_data/tile.png 109 | t/test_data/tile.tiff 110 | t/test_data/tile.wbmp 111 | t/test_data/tile.webp 112 | t/test_data/tile.xbm 113 | t/test_data/windows.bmp 114 | t/transp.t 115 | t/windows_bmp.t 116 | t/z_kwalitee.t 117 | t/z_manifest.t 118 | t/z_pod-spell-mistakes.t 119 | t/z_pod.t 120 | testcpan.sh 121 | testlibs.sh 122 | typemap 123 | -------------------------------------------------------------------------------- /bdf_scripts/bdftogd: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl -w 2 | 3 | # 4 | # Simple convertor from bdf to gd font format. 5 | # 6 | # Author: Jan Pazdziora, adelton@fi.muni.cz, http://www.fi.muni.cz/~adelton/ 7 | # at Faculty of Informatics, Masaryk University in Brno, Czech Republic. 8 | # 9 | # Example of use: 10 | # fstobdf -s fontserverhost:7100 -fn 8x16 | ./bdftogd FontLarge gdfontl 11 | # 12 | 13 | use strict; 14 | 15 | my $VERSION = '0.60'; 16 | my $now = localtime; 17 | 18 | if (@ARGV < 2) 19 | { die "usage: bdftogd fontname filename, eg. bdftogd FontLarge gdfontl\n"; } 20 | 21 | my $gdname = shift; 22 | $gdname = 'gd' . $gdname unless $gdname =~ /^gd/i; 23 | 24 | my $filename = shift; 25 | $filename = 'gd' . $filename unless $filename =~ /^gd/i; 26 | 27 | if (-f "$filename.c") { die "File $filename.c already exists, won't overwrite\n"; } 28 | if (-f "$filename.h") { die "File $filename.h already exists, won't overwrite\n"; } 29 | 30 | my ($width, $height); 31 | my (@data, @left, @bottom); 32 | my ($globalleft, $globaltop); 33 | 34 | my ($minchar, $maxchar); 35 | 36 | my ($copyright, $fontdef); 37 | 38 | my $currentchar; 39 | my $gobitmap = 0; 40 | 41 | 42 | while (<>) 43 | { 44 | chomp; 45 | s/\r$//; 46 | my ($tag, $value) = split / /, $_, 2; 47 | die "Font is not fixed width\n" 48 | if $tag eq 'SPACING' and not $value =~ /[CM]/i; 49 | 50 | $currentchar = $value if $tag eq 'ENCODING'; 51 | $minchar = $currentchar if not defined $minchar 52 | or ($currentchar < $minchar && $currentchar >= 0); 53 | $maxchar = $currentchar if not defined $maxchar 54 | or ($currentchar > $maxchar && $currentchar >= 0); 55 | 56 | if ($tag eq 'ENDCHAR') 57 | { 58 | next if $currentchar < 0; 59 | $gobitmap = 0; 60 | my $bottom = $globaltop - $bottom[$currentchar]; 61 | 62 | 63 | if ($bottom > 0) 64 | { $data[$currentchar] = substr $data[$currentchar], 0, length($data[$currentchar]) - $bottom * $width; } 65 | else 66 | { $data[$currentchar] .= '0' x (-$bottom * $width); } 67 | } 68 | 69 | if ($tag eq 'FONTBOUNDINGBOX') 70 | { 71 | my ($tag, $wid, $hei, $left, $top) = split / /; 72 | if (defined $top) 73 | { 74 | $globalleft = $left; 75 | $globaltop = $top; 76 | $height = $hei; 77 | $width = $wid; 78 | } 79 | } 80 | if ($tag eq 'FONT' and not defined $fontdef) 81 | { $fontdef = $value; } 82 | if ($tag eq 'COPYRIGHT' and not defined $copyright) 83 | { $copyright = $value; } 84 | 85 | if ($tag eq 'BBX') 86 | { 87 | my ($tag, $wid, $hei, $left, $bottom) = split / /; 88 | if (defined $bottom) 89 | { 90 | $left[$currentchar] = $left; 91 | $bottom[$currentchar] = $bottom; 92 | } 93 | } 94 | 95 | if ($gobitmap) 96 | { 97 | my $value = pack 'H*', $_; 98 | my $bits = unpack 'B*', $value; 99 | $bits = ('0' x $left[$currentchar]) . $bits; 100 | $bits .= '0' x ($width - length $bits); 101 | $bits = substr $bits, 0, $width; 102 | $data[$currentchar] .= $bits; 103 | } 104 | 105 | if ($tag eq 'BITMAP') 106 | { 107 | $gobitmap = 1; 108 | $data[$currentchar] = ''; 109 | } 110 | } 111 | 112 | my $info = <<"EOF"; 113 | /* 114 | This is a header file for gd font, generated using 115 | bdftogd version $VERSION by Jan Pazdziora, adelton\@fi.muni.cz 116 | from bdf font 117 | $fontdef 118 | at $now. 119 | EOF 120 | 121 | if (defined $copyright) 122 | { 123 | $info .= <<"EOF"; 124 | The original bdf was holding following copyright: 125 | $copyright 126 | */ 127 | EOF 128 | } 129 | else 130 | { 131 | $info .= <<"EOF"; 132 | No copyright info was found in the original bdf. 133 | */ 134 | EOF 135 | } 136 | 137 | open FILEC, "> $filename.c" or die "Error writing $filename.c: $!\n"; 138 | open FILEH, "> $filename.h" or die "Error writing $filename.h: $!\n"; 139 | print FILEC <<"EOF"; 140 | 141 | $info 142 | 143 | #include "$filename.h" 144 | 145 | char ${gdname}Data[] = { 146 | EOF 147 | 148 | $minchar = 0 unless defined $minchar; 149 | $maxchar = 255 unless defined $maxchar; 150 | for (my $i = $minchar; $i <= $maxchar; $i++) 151 | { 152 | $data[$i] = '' unless defined $data[$i]; 153 | $data[$i] = '0' x ($width * $height - length $data[$i]) . $data[$i]; 154 | 155 | print FILEC "/* Char $i */\n"; 156 | for my $line (0 .. $height - 1) 157 | { print FILEC join ',', split(//, substr($data[$i], $line * $width, $width)), "\n"; } 158 | 159 | print FILEC "\n"; 160 | 161 | next; 162 | 163 | for my $line (0 .. $height - 1) 164 | { print substr($data[$i], $line * $width, $width), "\n"; } 165 | } 166 | 167 | my $capdef = "\U_${filename}_H_"; 168 | 169 | print FILEC <<"EOF"; 170 | 171 | }; 172 | 173 | gdFont ${gdname}Rep = { 174 | @{[ $maxchar - $minchar + 1]}, 175 | $minchar, 176 | $width, 177 | $height, 178 | ${gdname}Data 179 | }; 180 | 181 | gdFontPtr ${gdname} = &${gdname}Rep; 182 | 183 | /* This file has not been truncated. */ 184 | 185 | EOF 186 | 187 | 188 | close FILEC; 189 | 190 | print FILEH <<"EOF"; 191 | 192 | #ifndef $capdef 193 | #define $capdef 1 194 | 195 | $info 196 | 197 | #include "gd.h" 198 | 199 | extern gdFontPtr $gdname; 200 | 201 | #endif 202 | 203 | EOF 204 | 205 | 1; 206 | -------------------------------------------------------------------------------- /lib/GD/Polygon.pm: -------------------------------------------------------------------------------- 1 | package GD::Polygon; 2 | 3 | use strict; 4 | use Carp 'carp'; 5 | use GD; 6 | use vars '$VERSION'; 7 | $VERSION = '2.82'; 8 | 9 | # old documentation error 10 | *GD::Polygon::delete = \&deletePt; 11 | 12 | =head1 NAME 13 | 14 | GD::Polygon - Polygon class for the GD image library 15 | 16 | =head1 SYNOPSIS 17 | 18 | See L 19 | 20 | =head1 DESCRIPTION 21 | 22 | See L 23 | 24 | =head1 AUTHOR 25 | 26 | The GD.pm interface is copyright 1995-2005, Lincoln D. Stein. It is 27 | distributed under the same terms as Perl itself. See the "Artistic 28 | License" in the Perl source code distribution for licensing terms. 29 | 30 | The latest versions of GD.pm are available on CPAN: 31 | 32 | http://www.cpan.org 33 | 34 | =head1 SEE ALSO 35 | 36 | L 37 | L, 38 | L, 39 | L, 40 | L 41 | 42 | =cut 43 | 44 | ### The polygon object ### 45 | # create a new polygon 46 | sub new { 47 | my $class = shift; 48 | return bless { 'length'=>0,'points'=>[] },$class; 49 | } 50 | 51 | # automatic destruction of the polygon 52 | sub DESTROY { 53 | my $self = shift; 54 | undef $self->{'points'}; 55 | } 56 | 57 | sub clear { 58 | my $self = shift; 59 | $self->{'points'} = []; 60 | $self->{'length'} = 0; 61 | } 62 | 63 | # add an x,y vertex to the polygon 64 | sub addPt { 65 | my($self,$x,$y) = @_; 66 | push(@{$self->{'points'}},[$x,$y]); 67 | $self->{'length'}++; 68 | } 69 | 70 | # get a vertex 71 | sub getPt { 72 | my($self,$index) = @_; 73 | return () unless ($index >= 0) && ($index < $self->{'length'}); 74 | return @{$self->{'points'}->[$index]}; 75 | } 76 | 77 | # change the value of a vertex 78 | sub setPt { 79 | my($self,$index,$x,$y) = @_; 80 | unless (($index>=0) && ($index<$self->{'length'})) { 81 | carp "Attempt to set an undefined polygon vertex"; 82 | return undef; 83 | } 84 | @{$self->{'points'}->[$index]} = ($x,$y); 85 | 1; 86 | } 87 | 88 | # return the total number of vertices 89 | sub length { 90 | shift->{'length'} 91 | } 92 | 93 | # return the array of vertices. 94 | # each vertex is an two-member (x,y) array 95 | sub vertices { 96 | @{shift->{'points'}} 97 | } 98 | 99 | # return the bounding box of the polygon 100 | # (smallest rectangle that contains it) 101 | sub bounds { 102 | my $self = shift; 103 | my($top,$bottom,$left,$right) = @_; 104 | $top = 99999999; 105 | $bottom =-99999999; 106 | $left = 99999999; 107 | $right = -99999999; 108 | my $v; 109 | foreach $v ($self->vertices) { 110 | $left = $v->[0] if $left > $v->[0]; 111 | $right = $v->[0] if $right < $v->[0]; 112 | $top = $v->[1] if $top > $v->[1]; 113 | $bottom = $v->[1] if $bottom < $v->[1]; 114 | } 115 | return ($left,$top,$right,$bottom); 116 | } 117 | 118 | # delete a vertex, returning it, just for fun 119 | sub deletePt { 120 | my($self,$index) = @_; 121 | unless (($index>=0) && ($index<@{$self->{'points'}})) { 122 | carp "Attempt to delete an undefined polygon vertex"; 123 | return undef; 124 | } 125 | my($vertex) = splice(@{$self->{'points'}},$index,1); 126 | $self->{'length'}--; 127 | return @$vertex; 128 | } 129 | 130 | # translate the polygon in space by deltaX and deltaY 131 | sub offset { 132 | my($self,$dh,$dv) = @_; 133 | my $size = $self->length; 134 | my($i); 135 | for ($i=0;$i<$size;$i++) { 136 | my($x,$y)=$self->getPt($i); 137 | $self->setPt($i, $x+$dh, $y+$dv); 138 | } 139 | } 140 | 141 | # map the polygon from sourceRect to destRect, 142 | # translating and resizing it if necessary 143 | sub map { 144 | my($self,$srcL,$srcT,$srcR,$srcB,$destL,$destT,$destR,$destB) = @_; 145 | my($factorV) = ($destB-$destT)/($srcB-$srcT); 146 | my($factorH) = ($destR-$destL)/($srcR-$srcL); 147 | my($vertices) = $self->length; 148 | my($i); 149 | for ($i=0;$i<$vertices;$i++) { 150 | my($x,$y) = $self->getPt($i); 151 | $x = int($destL + ($x - $srcL) * $factorH); 152 | $y = int($destT + ($y - $srcT) * $factorV); 153 | $self->setPt($i,$x,$y); 154 | } 155 | } 156 | 157 | # These routines added by Winfriend Koenig. 158 | sub toPt { 159 | my($self, $dx, $dy) = @_; 160 | unless ($self->length > 0) { 161 | $self->addPt($dx,$dy); 162 | return; 163 | } 164 | my ($x, $y) = $self->getPt($self->length-1); 165 | $self->addPt($x+$dx,$y+$dy); 166 | } 167 | 168 | sub transform($$$$$$$) { 169 | # see PostScript Ref. page 154 170 | # documented as the affine transformation matrix: (xx,yx,xy,yy,x0,y0) 171 | # note that even the libgd doc is wrong here for yy. 172 | my($self, $sx, $sy, $rx, $ry, $tx, $ty) = @_; 173 | my $size = $self->length; 174 | for (my $i=0; $i<$size; $i++) { 175 | my($x,$y) = $self->getPt($i); 176 | # gdAffineApplyToPointF: 177 | # dst->x = x * affine[0] + y * affine[2] + affine[4]; 178 | # dst->y = x * affine[1] + y * affine[3] + affine[5]; 179 | $self->setPt($i, $x*$sx + $y*$ry + $tx, $x*$rx + $y*$sy + $ty); 180 | } 181 | } 182 | 183 | sub scale { 184 | my($self, $sx, $sy, $tx, $ty) = @_; 185 | $sy = $sx unless defined $sy; 186 | $self->offset(-$tx,-$ty) if defined $tx or defined $ty; 187 | $self->transform($sx,$sy,0,0,$tx,$ty); 188 | } 189 | 190 | # clockwise in radians 191 | sub rotate { 192 | my($self, $r) = @_; 193 | my ($s, $c) = (sin($r), cos($r)); 194 | $self->transform($c,$c,-$s,$s, 0,0); 195 | } 196 | 197 | 1; 198 | -------------------------------------------------------------------------------- /.github/workflows/testsuite.yml: -------------------------------------------------------------------------------- 1 | name: testsuite 2 | 3 | on: 4 | push: 5 | branches: 6 | - "*" 7 | tags-ignore: 8 | - "*" 9 | pull_request: 10 | 11 | jobs: 12 | ubuntu: 13 | env: 14 | PERL_USE_UNSAFE_INC: 0 15 | AUTHOR_TESTING: 1 16 | AUTOMATED_TESTING: 1 17 | RELEASE_TESTING: 1 18 | 19 | runs-on: ubuntu-latest 20 | 21 | steps: 22 | - uses: actions/checkout@1af3b93b6815bc44a9784bd300feb67ff0d1eeb3 # v6.0.0 23 | - run: perl -V 24 | - run: sudo apt install libgd-dev 25 | - name: install cpan deps 26 | uses: perl-actions/install-with-cpm@8b1a9840b26cc3885ae2889749a48629be2501b0 # v1.9 27 | with: 28 | install: | 29 | ExtUtils::PkgConfig 30 | File::Which 31 | Math::Trig 32 | Class::XSAccessor 33 | Text::CSV_XS 34 | List::MoreUtils 35 | Algorithm::Diff 36 | Test::Kwalitee 37 | Test::Pod 38 | Pod::Spell::CommonMistakes 39 | Test::Fork 40 | Test::NoWarnings 41 | - run: perl Makefile.PL 42 | - run: make test 43 | 44 | linux: 45 | name: "perl ${{ matrix.perl-version }}" 46 | needs: [ubuntu] 47 | env: 48 | PERL_USE_UNSAFE_INC: 0 49 | AUTHOR_TESTING: 1 50 | AUTOMATED_TESTING: 1 51 | RELEASE_TESTING: 1 52 | 53 | runs-on: ubuntu-latest 54 | 55 | strategy: 56 | fail-fast: false 57 | matrix: 58 | perl-version: 59 | [ 60 | "5.38", 61 | "5.36", 62 | "5.34", 63 | "5.32", 64 | "5.30", 65 | "5.28", 66 | "5.26", 67 | "5.24", 68 | "5.22", 69 | "5.20", 70 | "5.18", 71 | "5.16", 72 | "5.14", 73 | "5.12", 74 | "5.10", 75 | "5.8", 76 | ] 77 | 78 | steps: 79 | - uses: actions/checkout@1af3b93b6815bc44a9784bd300feb67ff0d1eeb3 # v6.0.0 80 | - uses: shogo82148/actions-setup-perl@f9f0bf89e0d19ddbabb2f40d43db2e944bce7d2f # v1.36.0 81 | with: 82 | perl-version: ${{ matrix.perl-version }} 83 | - run: perl -V 84 | - run: sudo apt install libgd-dev 85 | - name: install cpan deps 86 | uses: perl-actions/install-with-cpm@8b1a9840b26cc3885ae2889749a48629be2501b0 # v1.9 87 | with: 88 | sudo: false 89 | install: | 90 | ExtUtils::PkgConfig 91 | File::Which 92 | Math::Trig 93 | Test::NoWarnings 94 | - run: perl Makefile.PL 95 | - run: make test 96 | 97 | macOS: 98 | needs: [ubuntu] 99 | env: 100 | PERL_USE_UNSAFE_INC: 0 101 | AUTHOR_TESTING: 1 102 | AUTOMATED_TESTING: 1 103 | RELEASE_TESTING: 1 104 | 105 | runs-on: macOS-latest 106 | 107 | strategy: 108 | fail-fast: false 109 | matrix: 110 | perl-version: [latest] 111 | 112 | steps: 113 | - uses: actions/checkout@1af3b93b6815bc44a9784bd300feb67ff0d1eeb3 # v6.0.0 114 | - run: perl -V 115 | # already installed 116 | - run: brew install gd 117 | - name: install cpan deps 118 | uses: perl-actions/install-with-cpm@8b1a9840b26cc3885ae2889749a48629be2501b0 # v1.9 119 | with: 120 | install: | 121 | ExtUtils::PkgConfig 122 | File::Which 123 | Math::Trig 124 | Test::Fork 125 | Test::NoWarnings 126 | - run: perl Makefile.PL 127 | - run: make test 128 | 129 | windows: 130 | needs: [ubuntu] 131 | env: 132 | PERL_USE_UNSAFE_INC: 0 133 | AUTHOR_TESTING: 0 134 | AUTOMATED_TESTING: 1 135 | RELEASE_TESTING: 0 136 | VCPKG_DEFAULT_TRIPLET: x64-windows 137 | 138 | runs-on: windows-latest 139 | 140 | strategy: 141 | fail-fast: false 142 | matrix: 143 | perl-version: [latest] 144 | 145 | steps: 146 | - uses: actions/checkout@1af3b93b6815bc44a9784bd300feb67ff0d1eeb3 # v6.0.0 147 | - run: perl -V 148 | #- run: choco install -y libgd 149 | #- name: choco install -libgd 150 | # uses: crazy-max/ghaction-chocolatey@v3 151 | # with: 152 | # args: install -y libgd 153 | #- run: vcpkg install libgd 154 | # too slow: echo.set(VCPKG_BUILD_TYPE release) >> d:\vcpkg\triplets\x64-windows.cmake 155 | # or install the msys2 perl-gd library 156 | # vcpkg needs 7m, but is cached 157 | - name: vcpkg install libgd 158 | uses: johnwason/vcpkg-action@caa1c94fbb94d8b023a0cc93edf10cd3791349a7 # v7.0.1 159 | id: vcpkg 160 | with: 161 | pkgs: libgd 162 | triplet: x64-windows-release 163 | token: ${{ github.token }} 164 | github-binarycache: true 165 | - name: install cpan deps 166 | uses: perl-actions/install-with-cpm@8b1a9840b26cc3885ae2889749a48629be2501b0 # v1.9 167 | with: 168 | sudo: false 169 | install: | 170 | ExtUtils::PkgConfig 171 | File::Which 172 | Math::Trig 173 | Test::Fork 174 | Test::NoWarnings 175 | - run: perl Makefile.PL --lib_gd_path vcpkg/packages/tiff_x64-windows-release/lib 176 | - run: perl -pi -e's/-Wl,--enable-auto-image-base/ /' Makefile 177 | - run: make test TEST_VERBOSE=1 2>&1 | tee make.log 178 | continue-on-error: true 179 | - name: Upload Failure 180 | uses: actions/upload-artifact@330a01c490aca151604b8cf639adc76d48f6c5d4 # v5.0.0 181 | if: failure() 182 | with: 183 | name: artifacts 184 | path: . 185 | -------------------------------------------------------------------------------- /bdf_scripts/bdf2gdfont_pl.PL: -------------------------------------------------------------------------------- 1 | #!perl 2 | use Config; 3 | use File::Basename qw(&basename &dirname); 4 | use Cwd; 5 | 6 | my $origdir = cwd; 7 | my $dir = dirname($0); 8 | chdir $dir; 9 | my $file = 'bdf2gdfont'; 10 | $file .= $^O eq 'VMS' ? '.com' : '.pl'; 11 | 12 | open OUT,">",$file or die "Can't create $file: $!"; 13 | 14 | print "Extracting $file (with variable substitutions)\n"; 15 | 16 | print OUT <<"!GROK!THIS!"; 17 | $Config{startperl} 18 | !GROK!THIS! 19 | 20 | # In the following, perl variables are not expanded during extraction. 21 | 22 | print OUT <<'!NO!SUBS!'; 23 | 24 | # 25 | # Simple convertor from bdf to loadable GD font format. 26 | # 27 | # Author: Lincoln Stein , heavily adopted from bdftogd from 28 | # Jan Pazdziora 29 | # 30 | # Example of use: 31 | # fstobdf -s fontserverhost:7100 -fn 8x16 | bdftofnt > myfont.fnt 32 | # 33 | 34 | use strict; 35 | our $VERSION = '1.00'; 36 | 37 | if ($ARGV[0] =~ /^--?h/) { 38 | exec "perldoc $0"; 39 | } 40 | 41 | my ($width, $height); 42 | my (@data, @left, @bottom); 43 | my ($globalleft, $globaltop); 44 | 45 | my ($minchar, $maxchar); 46 | 47 | my ($copyright, $fontdef); 48 | 49 | my $currentchar; 50 | my $gobitmap = 0; 51 | 52 | foreach (@ARGV) { 53 | $_ = "gunzip -c $_ |" if /\.gz$/; 54 | } 55 | 56 | while (<>) 57 | { 58 | chomp; 59 | s/\r$//; 60 | next unless $_; 61 | my ($tag, $value) = split / /, $_, 2; 62 | die "Font is not fixed width\n" 63 | if $tag eq 'SPACING' and not $value =~ /[CM]/i; 64 | 65 | $currentchar = $value if $tag eq 'ENCODING'; 66 | $minchar = $currentchar if not defined $minchar 67 | or ($currentchar < $minchar && $currentchar >= 0); 68 | $maxchar = $currentchar if not defined $maxchar 69 | or ($currentchar > $maxchar && $currentchar >= 0); 70 | 71 | if ($tag eq 'ENDCHAR') 72 | { 73 | next if $currentchar < 0; 74 | $gobitmap = 0; 75 | my $bottom = $globaltop - $bottom[$currentchar]; 76 | 77 | 78 | if ($bottom > 0) 79 | { $data[$currentchar] = substr $data[$currentchar], 0, length($data[$currentchar]) - $bottom * $width; } 80 | else 81 | { $data[$currentchar] .= '0' x (-$bottom * $width); } 82 | } 83 | 84 | if ($tag eq 'FONTBOUNDINGBOX') 85 | { 86 | my ($tag, $wid, $hei, $left, $top) = split / /; 87 | if (defined $top) 88 | { 89 | $globalleft = $left; 90 | $globaltop = $top; 91 | $height = $hei; 92 | $width = $wid; 93 | } 94 | } 95 | if ($tag eq 'FONT' and not defined $fontdef) 96 | { $fontdef = $value; } 97 | if ($tag eq 'COPYRIGHT' and not defined $copyright) 98 | { $copyright = $value; } 99 | 100 | if ($tag eq 'BBX') 101 | { 102 | my ($tag, $wid, $hei, $left, $bottom) = split / /; 103 | if (defined $bottom) 104 | { 105 | $left[$currentchar] = $left; 106 | $bottom[$currentchar] = $bottom; 107 | } 108 | } 109 | 110 | if ($gobitmap) 111 | { 112 | my $value = pack 'H*', $_; 113 | my $bits = unpack 'B*', $value; 114 | $bits = ('0' x $left[$currentchar]) . $bits; 115 | $bits .= '0' x ($width - length $bits); 116 | $bits = substr $bits, 0, $width; 117 | $data[$currentchar] .= $bits; 118 | } 119 | 120 | if ($tag eq 'BITMAP') 121 | { 122 | $gobitmap = 1; 123 | $data[$currentchar] = ''; 124 | } 125 | } 126 | 127 | $minchar = 0 unless defined $minchar; 128 | $maxchar = 255 unless defined $maxchar; 129 | 130 | binmode STDOUT; # for DOS/Windows systems 131 | my $length = $maxchar-$minchar+1; 132 | 133 | 134 | print pack ('VVVV',$length,$minchar,$width,$height); # header 135 | 136 | for (my $i = $minchar; $i <= $maxchar; $i++) { 137 | $data[$i] = '' unless defined $data[$i]; 138 | $data[$i] = '0' x ($width * $height - length $data[$i]) . $data[$i]; 139 | print pack('C*',split '',$data[$i]); 140 | } 141 | 142 | print STDERR "Successfully converted $length ${width}x$}height} characters\n"; 143 | 144 | __END__ 145 | 146 | =head1 NAME 147 | 148 | bdf2gdfont.pl - Convert X11 "BDF" fonts into a loadable font format for GD. 149 | 150 | =head1 SYNOPSIS 151 | 152 | % bdf2gdfont.pl courR12.bdf > courR12.fnt 153 | 154 | =head1 DESCRIPTION 155 | 156 | This script converts BDF-style X11 font files into a format that can 157 | be loaded by the GD module using the GD::Font->load() method. There 158 | are a number of ways to obtain BDF fonts. 159 | 160 | =over 4 161 | 162 | =item 1. The font is already present on your system. 163 | 164 | Some BDF fonts can be found in the standard X11R6 distribution. This 165 | script will automatically uncompress gzipped font files if their 166 | extension ends with .gz (the gunzip program must be on your path). 167 | 168 | =item 2. From a font server. 169 | 170 | The "fstobdf" utility, a standard X11 utility, will read a named font 171 | from the font server of your choice and return it in BDF format. You 172 | can pipe it to bdf2gdfont.pl: 173 | 174 | fstobdf -s fontserverhost:7100 -fn 8x16 | bdf2gdfont.pl > newfont.fnt 175 | 176 | Use xlsfonts to find out what fonts are available. Most fonts will 177 | have long names like 178 | -B&H-LucidaTypewriter-Bold-R-Normal-Sans-18-180-75-75-M-110-ISO8859-10. 179 | 180 | =item 3. Using the pcf2bdf utility. 181 | 182 | Some fonts are only available in PCF (compiled) format. To obtain 183 | these, you can either turn on a font server and follow recipe (2), or 184 | use TAGA Nayuta's pcf2bdf utility. This utility is available from 185 | http://www.tsg.ne.jp/GANA/S/pcf2bdf/ (page is in Japanese, but you can 186 | find the download link). 187 | 188 | =back 189 | 190 | =head2 Limitations 191 | 192 | This font converter only works with fixed-width fonts. If used with a 193 | TrueType or proportional font it will die with an error message. 194 | 195 | =head1 SEE ALSO 196 | 197 | L 198 | 199 | =head1 AUTHOR 200 | 201 | Lincoln Stein , heavily adapted from bdftogd from 202 | Jan Pazdziora . 203 | 204 | Copyright (c) 2004 Cold Spring Harbor Laboratory 205 | 206 | This library is free software; you can redistribute it and/or modify 207 | it under the same terms as Perl itself. 208 | 209 | =cut 210 | 211 | !NO!SUBS! 212 | close OUT or die "Can't close $file: $!"; 213 | chmod 0755, $file or die "Can't reset permissions for $file: $!\n"; 214 | exec("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; 215 | chdir $origdir; 216 | -------------------------------------------------------------------------------- /bdf_scripts/cvtbdf.pl: -------------------------------------------------------------------------------- 1 | #!/usr/local/bin/perl 2 | # Filename - cvtbdf.pl 3 | # Author - Geoff Baysinger (gbaysing@HiWAAY.net) 4 | # Purpose - Allows "simple" installation of additional BDF fonts for GD.pm 5 | # Usage - "cvtbdf.pl" (no arguments, see instructions) 6 | # License - Freely given to be distributed with the GD.pm libraries 7 | # (you may modify this script to your heart's content, 8 | # but it may only be distributed by the author or via the GD.pm 9 | # package.) 10 | # 11 | # Summary - 12 | # Uses "bdftogd", (provided with GD.pm) to convert BDF fonts to GD format. 13 | # It should makes the edits necessary to the GD.pm source files so that. 14 | # the "bdftogd" process is automated and all the user needs do is recompile 15 | # the GD.pm package (only "GD.so" is changed during compilation). 16 | # 17 | # Instructions - 18 | # 1) go to your GD.pm source installation directory 19 | # note: if you have already installed GD.pm, run a "make clean" 20 | # 2) create a subdirectory called "fonts" (mkdir fonts) 21 | # 3) copy the BDF font files you wish to convert to the "fonts" directory 22 | # note: The BDF font must be a type that "bdftogd" can convert, hence 23 | # it must be a standard monospaced character font, not a BDF 24 | # cursor file. Some monospaced fonts may still not work. Test 25 | # with "bdftogd" before running this script if you are unsure. 26 | # 4) copy "bdftogd" and "cvtbdf.pl" to the "fonts" directory 27 | # 5) run "cvtbdf.pl" 28 | # 6) go to your GD.pm source installation directory and install the new 29 | # version via a "make" and "make install" 30 | # 31 | # Notes - 32 | # A) Keep the "fonts" subdirectory and all fonts you wish to use in the 33 | # future. Each time you want to add a font you will need the old ones 34 | # in the directory, or they will disappear during the next recompile. 35 | # B) Add new fonts in the future is as easy as copying the .bdf file to 36 | # the "fonts" directory and running steps #5 and #6 again. 37 | # 38 | # Thanks - 39 | # To Lincoln Stein for the use of CGI.pm and GD.pm and to all other 40 | # contributors of those packages. 41 | 42 | # make sure we have the conversion program 43 | if (! -x "bdftogd") { die "OOPS!\n Can't execute 'bdftogd', is it even there?\n error: $!\n\n"; } 44 | 45 | &badnames; 46 | &saveorig("GD.pm","GD.xs","libgd/Makefile.PL"); 47 | ©orig("GD.pm","GD.xs","libgd/Makefile.PL"); 48 | 49 | for $i (@files) { 50 | open(OLDXS,"../GD.xs") || die "OOPS!\n Can't open '../GD.xs' for reading\n Make sure you're in a 'fonts' subdirectory\n error: $!\n\n"; 51 | open(NEWXS,"> ../GD.xs.fonts") || die "OOPS!\n Can't open '../GD.xs.fonts' for writing\n Make sure you're in a 'fonts' subdirectory\n error: $!\n\n"; 52 | open(OLDPM,"../GD.pm") || die "OOPS!\n Can't open '../GD.pm' for reading\n Make sure you're in a 'fonts' subdirectory\n error: $!\n\n"; 53 | open(NEWPM,"> ../GD.pm.fonts") || die "OOPS!\n Can't open '../GD.pm.fonts' for writing\n Make sure you're in a 'fonts' subdirectory\n error: $!\n\n"; 54 | open(OLDMAKE,"../libgd/Makefile.PL") || die "OOPS!\n Can't open '../libgd/Makefile.PL' for reading\n Make sure you're in a 'fonts' subdirectory\n error: $!\n\n"; 55 | open(NEWMAKE,"> ../libgd/Makefile.PL.fonts") || die "OOPS!\n Can't open '../libgd/Makefile.PL.fonts' for writing\n Make sure you're in a 'fonts' subdirectory\n error: $!\n\n"; 56 | 57 | # some state-keeping variables 58 | my $extern; 59 | my $package; 60 | my $export; 61 | my $preload; 62 | my $h; 63 | my $c; 64 | 65 | # figure out our "name" 66 | my $name = "BDF" . $i; 67 | $name =~ /(.*)\.bdf/; 68 | $name = $1; 69 | print "=> name = $name\n"; 70 | 71 | 72 | # do the actual font conversion: 73 | open(FONT,"$i"); 74 | # usage: bdftogd fontname filename, eg. bdftogd FontLarge gdfontl } 75 | my $fontname = "Font" . $name; 76 | my $filename = "font" . $name; 77 | my $gdname = "gdfont" . $name; 78 | open(CONVERT,"| bdftogd $fontname $filename"); 79 | while () { print CONVERT; } 80 | close CONVERT; 81 | # move the font files to "../libgd" 82 | open(OLD,"${gdname}.h"); 83 | open(NEW,"> ../libgd/${gdname}.h"); 84 | while () { print NEW; } 85 | close OLD; 86 | close NEW; 87 | unlink("${gdname}.h"); 88 | open(OLD,"${gdname}.c"); 89 | open(NEW,"> ../libgd/${gdname}.c"); 90 | while () { print NEW; } 91 | close OLD; 92 | close NEW; 93 | unlink("${gdname}.c"); 94 | 95 | ## Begin editing files 96 | # GD.xs: 97 | while () { 98 | $data = $_; 99 | if (! $extern && $data =~ /^extern[\s]{1,}gdFontPtr/) { 100 | $data = "extern gdFontPtr gdFont" . $name . ";\n" . $data; 101 | $extern = 1; 102 | } elsif (! $package && $data =~ /^MODULE[\s]*=[\s]*GD[\s]{1,}PACKAGE[\s]*=[\s]*GD::Font[\s]{1,}PREFIX=gd/) { 103 | $data .= "\nGD::Font\ngd" . $name . "(packname=\"GD::Font\")\n char * packname\n PROTOTYPE: \$\n CODE:\n {\n RETVAL = gdFont" . $name . ";\n }\n OUTPUT:\n RETVAL\n"; 104 | $package = 1; 105 | } 106 | print NEWXS $data; 107 | } 108 | 109 | # GD.pm: 110 | while () { 111 | $data = $_; 112 | if (! $export && $data =~ /\@EXPORT = qw\(/) { 113 | $data .= " gd" . $name . "Font\n"; 114 | $export = "done"; 115 | } elsif (! $preload && $data =~ /^# Preloaded methods go here./) { 116 | $data .= "sub GD::gd" . $name . "Font {\n return &GD::Font::" . $name . ";\n}\n"; 117 | $preload = "done"; 118 | } 119 | print NEWPM $data; 120 | } 121 | 122 | # libgd/Makefile.PL: 123 | while () { 124 | $data = $_; 125 | # 'H' => [qw(gd.h gdfontl.h gdfonts.h io.h gdfontg.h gdfontmb.h gdfontt.h mtables.h)], 126 | if (! $h && $data =~ /^([\s]*'H'[\s]*\=\>[\s]*\[qw\(gd\.h[\s])(.*)/) { 127 | $data = $1 . "${gdname}.h " . $2 . "\n"; 128 | $h = "done"; 129 | } elsif (! $c && $data =~ /^([\s]*'C'[\s]*\=\>[\s]*\[qw\(gdfontg\.c[\s])(.*)/) { 130 | # 'C' => [qw(gdfontg.c gdfontmb.c gdfontt.c gdfontl.c gdfonts.c libgd.c)], 131 | $data = $1 . "${gdname}.c " . $2 . "\n"; 132 | $c = "done"; 133 | } 134 | print NEWMAKE $data; 135 | } 136 | 137 | # close the files 138 | close OLDXS; 139 | close NEWXS; 140 | close OLDPM; 141 | close NEWPM; 142 | close OLDMAKE; 143 | close NEWMAKE; 144 | 145 | # copy the files to the proper extension 146 | open(NEWXS,"../GD.xs.fonts"); 147 | open(OLDXS,"> ../GD.xs"); 148 | open(NEWPM,"../GD.pm.fonts"); 149 | open(OLDPM,"> ../GD.pm"); 150 | open(NEWMAKE,"../libgd/Makefile.PL.fonts"); 151 | open(OLDMAKE,"> ../libgd/Makefile.PL"); 152 | while () { print OLDXS; } 153 | while () { print OLDPM; } 154 | while () { print OLDMAKE; } 155 | close NEWXS; 156 | close OLDXS; 157 | close NEWPM; 158 | close OLDPM; 159 | close NEWMAKE; 160 | close OLDMAKE; 161 | 162 | # unlink the temp files 163 | unlink "../GD.pm.fonts"; 164 | unlink "../GD.xs.fonts"; 165 | unlink "../libgd/Makefile.PL.fonts"; 166 | } 167 | 168 | sub saveorig { 169 | local (@files) = @_; 170 | for $file (@files) { 171 | if (! -f "../${file}.orig") { 172 | open(OLD,"../$file") || die $!; 173 | open(ORIG,"> ../${file}.orig") || die $!; 174 | while () { print ORIG; } 175 | close OLD; 176 | close ORIG; 177 | } 178 | } 179 | } 180 | 181 | sub copyorig { 182 | local(@files) = @_; 183 | for $file (@files) { 184 | open(ORIG,"../${file}.orig") || die $!; 185 | open(NEW,"> ../$file") || die $!; 186 | while () { print NEW; } 187 | close ORIG; 188 | close NEW; 189 | } 190 | } 191 | 192 | sub badnames { 193 | @badnames = (<*.BDF>,<*.Bdf>,<*.BDf>,<*.bDf>,<*.bDF>,<*.BdF>); 194 | for $i (@badnames) { 195 | my $goodname = $i; 196 | $goodname =~ tr/A-Z/a-z/; 197 | open(BAD,"$i"); 198 | open(GOOD,"> $goodname"); 199 | while () { print GOOD; } 200 | close BAD; 201 | close GOOD; 202 | unlink $i; 203 | } 204 | @files = <*.bdf>; 205 | } 206 | 207 | -------------------------------------------------------------------------------- /lib/GD/Image.pm: -------------------------------------------------------------------------------- 1 | # DO NOT EDIT! THIS FILE IS AUTOGENERATED BY lib/GD/Image_pm.PL 2 | package GD::Image; 3 | 4 | use strict; 5 | use GD; 6 | use Symbol 'gensym','qualify_to_ref'; 7 | use vars '$VERSION'; 8 | $VERSION = '2.83'; 9 | 10 | =head1 NAME 11 | 12 | GD::Image - Image class for the GD image library 13 | 14 | =head1 SYNOPSIS 15 | 16 | See L 17 | 18 | =head1 DESCRIPTION 19 | 20 | Supported Image formats: 21 | 22 | =over 4 23 | 24 | =item Png 25 | 26 | =item Gif 27 | 28 | =item Jpeg 29 | 30 | =item Tiff 31 | 32 | =item Xbm 33 | 34 | =item WBMP 35 | 36 | =item BMP 37 | 38 | =item Webp 39 | 40 | =item Avif 41 | 42 | =back 43 | 44 | Unsupported Image formats: 45 | 46 | =over 4 47 | 48 | =item Gd 49 | 50 | =item Gd2 51 | 52 | =item Xpm 53 | 54 | =item GifAnim 55 | 56 | =item Heif 57 | 58 | =back 59 | 60 | See L 61 | 62 | =head1 AUTHOR 63 | 64 | The GD.pm interface is copyright 1995-2005, Lincoln D. Stein. It is 65 | distributed under the same terms as Perl itself. See the "Artistic 66 | License" in the Perl source code distribution for licensing terms. 67 | 68 | The latest versions of GD.pm are available on CPAN: 69 | 70 | http://www.cpan.org 71 | 72 | =head1 SEE ALSO 73 | 74 | L 75 | L, 76 | L, 77 | L, 78 | L 79 | 80 | =cut 81 | 82 | # Copyright 1995 Lincoln D. Stein. See accompanying README file for 83 | # usage information 84 | 85 | *stringTTF = \&GD::Image::stringFT; 86 | 87 | sub _make_filehandle { 88 | shift; # get rid of class 89 | no strict 'refs'; 90 | my $thing = shift; 91 | return $thing if defined(fileno $thing); 92 | 93 | # otherwise try qualifying it into caller's package 94 | my $fh; 95 | { 96 | local $^W = 0; # to avoid uninitialized variable warning from Symbol.pm 97 | my $pkg = caller(2); 98 | $pkg = "main" unless defined $pkg;; 99 | $fh = qualify_to_ref($thing,$pkg); 100 | } 101 | return $fh if defined(fileno $fh); 102 | 103 | # otherwise treat it as a file to open 104 | $fh = gensym; 105 | if (!open($fh,$thing)) { 106 | die "$thing not found: $!"; 107 | return undef; 108 | } 109 | return $fh; 110 | } 111 | 112 | sub new { 113 | my $pack = shift; 114 | if (@_ == 1) { 115 | if (my $type = _image_type($_[0])) { 116 | my $method = "newFrom${type}Data"; 117 | return unless $pack->can($method); 118 | return $pack->$method($_[0]); 119 | } elsif (-f $_[0] and $_[0] =~ /\.gd$/) { 120 | my $type = 'Gd'; 121 | return unless my $fh = $pack->_make_filehandle($_[0]); 122 | my $method = "newFrom${type}"; 123 | return unless $pack->can($method); 124 | return $pack->$method($fh); 125 | } elsif (-f $_[0] and $_[0] =~ /\.gd2$/) { 126 | my $type = 'Gd2'; 127 | return unless my $fh = $pack->_make_filehandle($_[0]); 128 | my $method = "newFrom${type}"; 129 | return unless $pack->can($method); 130 | return $pack->$method($fh); 131 | } elsif (-f $_[0] and $_[0] =~ /\.wbmp$/) { 132 | my $type = 'WBMP'; 133 | return unless my $fh = $pack->_make_filehandle($_[0]); 134 | my $method = "newFrom${type}"; 135 | return unless $pack->can($method); 136 | return $pack->$method($fh); 137 | } elsif (-f $_[0] and $_[0] =~ /\.xpm$/) { 138 | my $type = 'Xpm'; 139 | my $method = "newFrom${type}"; 140 | return unless $pack->can($method); 141 | return $pack->$method($_[0]); 142 | } 143 | return unless my $fh = $pack->_make_filehandle($_[0]); 144 | my $magic; 145 | return unless read($fh,$magic,64); 146 | return unless my $type = _image_type($magic); 147 | seek($fh,0,0); 148 | my $method = "newFrom${type}"; 149 | if ($type eq 'Xpm') { 150 | return $pack->$method($_[0]); 151 | } else { 152 | return $pack->$method($fh); 153 | } 154 | } 155 | return $pack->_new(@_); 156 | } 157 | 158 | sub newTrueColor { 159 | my $pack = shift; 160 | return $pack->_new(@_, 1); 161 | } 162 | 163 | sub newPalette { 164 | my $pack = shift; 165 | return $pack->_new(@_, 0); 166 | } 167 | 168 | sub ellipse ($$$$$) { 169 | my ($self,$cx,$cy,$width,$height,$color) = @_; 170 | $self->arc($cx,$cy,$width,$height,0,360,$color); 171 | } 172 | 173 | # draws closed polygon with the specified color 174 | sub polygon { 175 | my $self = shift; 176 | my($p,$c) = @_; 177 | $self->openPolygon($p, $c); 178 | $self->line( @{$p->{'points'}->[0]}, 179 | @{$p->{'points'}->[$p->{'length'}-1]}, $c); 180 | } 181 | 182 | sub width { 183 | my $self = shift; 184 | my @bounds = $self->getBounds; 185 | $bounds[0]; 186 | } 187 | 188 | sub height { 189 | my $self = shift; 190 | my @bounds = $self->getBounds; 191 | $bounds[1]; 192 | } 193 | 194 | sub _image_type { 195 | my $data = shift; 196 | my $magic = substr($data,0,4); 197 | return 'Png' if $magic eq "\x89PNG"; 198 | return 'Jpeg' if ((substr($data,0,3) eq "\377\330\377") && 199 | ord(substr($data,3,1)) >= 0xc0); 200 | return 'Gif' if $magic eq "GIF8"; 201 | return 'Gd2' if $magic eq "gd2\000"; 202 | return 'Tiff' if $magic eq "\x4d\x4d\x00\x2a" or 203 | $magic eq "\x49\x49\x2a\x00" or 204 | $magic eq "IIN1"; 205 | return 'Bmp' if $magic eq "BMF\000"; 206 | return 'Webp' if $magic eq "RIFF" and substr($data,8,4) eq "WEBP"; 207 | if (substr($data,4,4) eq "ftyp") { #possibly ISOBMFF-compliant container like HEIF which us used for AVIF and HEIC 208 | #first 4 bytes (they are now in $magic) must contain 32-bit Big Endian size of the 'ftyp' box (including size field and 'ftyp' mark) 209 | my $boxsize = unpack("N", $magic); 210 | if($boxsize>=16 && ($boxsize & 0x3)==0) { #minimum size of 'ftyp' box is 16 bytes and it must be multiple of 4 211 | #Structure of 'ftyp' box (from offset 8): 212 | # uint32 major_brand; 213 | # uint32 minor_version; 214 | # uint32 compatible_brands[]; to end of the box 215 | my $brand = substr($data,8,4); #major_brand 216 | my %compat; 217 | if($boxsize>16) { #compatible_brands list is not empty 218 | %compat = map {$_=>1} unpack("(A4)*", substr($data,16,$boxsize-16)); 219 | } 220 | return 'Avif' if $brand eq 'avif' || $compat{'avif'}; 221 | #Consider recognizing 'avis' brand meaning AV1 image sequence 222 | 223 | return 'Heif' if $brand eq 'mif1' || $brand eq 'heic' || $brand eq 'heix' || $compat{'heic'} || $compat{'heix'} || $compat{'mif1'}; 224 | #'mif1' stands for 'Multiple Image Format' and is general for the HEIF image container with any codec 225 | #'heic' indicates that HEVC Main Profile is utilized 226 | #'heix' indicates that HEVC Main 10 profile is utilized 227 | #Consider recognizing: 228 | # 'msf1' brand meaning 'Multiple Sequence Format' for general image sequence in HEIF 229 | # 'hevc' brand for HEVC Main Profile sequence 230 | # 'hevx' brand for HEVC Main 10 Profile sequence 231 | } 232 | } 233 | return 'Xpm' if substr($data,0,9) eq "/* XPM */"; 234 | return 'Xbm' if substr($data,0,8) eq "#define "; 235 | return; 236 | } 237 | 238 | 239 | sub clone { 240 | croak("Usage: clone(\$image)") unless @_ == 1; 241 | my $self = shift; 242 | my ($x,$y) = $self->getBounds; 243 | my $new = $self->new($x,$y); 244 | return unless $new; 245 | $new->copy($self,0,0,0,0,$x,$y); 246 | return $new; 247 | } 248 | 249 | sub newFromPng { 250 | croak("Usage: newFromPng(class,filehandle,[truecolor])") unless @_>=2; 251 | my($class) = shift; 252 | my($f) = shift; 253 | my $fh = $class->_make_filehandle($f); 254 | binmode($fh); 255 | $class->_newFromPng($fh,@_); 256 | } 257 | 258 | sub newFromJpeg { 259 | croak("Usage: newFromJpeg(class,filehandle,[truecolor])") unless @_>=2; 260 | my($class) = shift; 261 | my($f) = shift; 262 | my $fh = $class->_make_filehandle($f); 263 | binmode($fh); 264 | $class->_newFromJpeg($fh,@_); 265 | } 266 | 267 | sub newFromGif { 268 | croak("Usage: newFromGif(class,filehandle)") unless @_==2; 269 | my($class) = shift; 270 | my($f) = shift; 271 | my $fh = $class->_make_filehandle($f); 272 | binmode($fh); 273 | $class->_newFromGif($fh,@_); 274 | } 275 | 276 | sub newFromTiff { 277 | croak("Usage: newFromTiff(class,filehandle)") unless @_==2; 278 | my($class,$f) = @_; 279 | my $fh = $class->_make_filehandle($f); 280 | binmode($fh); 281 | $class->_newFromTiff($fh); 282 | } 283 | 284 | sub newFromXbm { 285 | croak("Usage: newFromXbm(class,filehandle)") unless @_==2; 286 | my($class,$f) = @_; 287 | my $fh = $class->_make_filehandle($f); 288 | binmode($fh); 289 | $class->_newFromXbm($fh); 290 | } 291 | 292 | sub newFromWebp { 293 | croak("Usage: newFromWebp(class,filehandle)") unless @_==2; 294 | my($class,$f) = @_; 295 | my $fh = $class->_make_filehandle($f); 296 | binmode($fh); 297 | $class->_newFromWebp($fh); 298 | } 299 | 300 | sub newFromAvif { 301 | croak("Usage: newFromAvif(class,filehandle)") unless @_==2; 302 | my($class,$f) = @_; 303 | my $fh = $class->_make_filehandle($f); 304 | binmode($fh); 305 | $class->_newFromAvif($fh); 306 | } 307 | 308 | sub newFromWBMP { 309 | croak("Usage: newFromWBMP(class,filehandle)") unless @_==2; 310 | my($class) = shift; 311 | my($f) = shift; 312 | my $fh = $class->_make_filehandle($f); 313 | binmode($fh); 314 | $class->_newFromWBMP($fh,@_); 315 | } 316 | 317 | sub newFromBmp { 318 | croak("Usage: newFromBmp(class,filehandle)") unless @_==2; 319 | my($class) = shift; 320 | my($f) = shift; 321 | my $fh = $class->_make_filehandle($f); 322 | binmode($fh); 323 | $class->_newFromBmp($fh,@_); 324 | } 325 | 326 | # Autoload methods go after __END__, and are processed by the autosplit program. 327 | 1; 328 | __END__ 329 | -------------------------------------------------------------------------------- /demos/polyline.pl: -------------------------------------------------------------------------------- 1 | ############################################################################ 2 | # 3 | # Sample code for use of Polyline.pm 4 | # 5 | # Author: Dan Harasty 6 | # Email: harasty@cpan.org 7 | # Version: 0.1 8 | # Date: 7/20/2002 9 | # 10 | # 11 | 12 | use GD; 13 | use GD::Polyline; 14 | 15 | $PI = 3.14159; $TWO_PI = 2 * $PI; 16 | sub r2d {$_[0] * 180 / $PI}; 17 | 18 | $splinekey = "
  • Green: original polygon or polyline
  • Blue: control points added with addControlPoints()
  • Black: spline generated by toSpline()
"; 19 | 20 | if (1) { 21 | 22 | use GD; 23 | use GD::Polyline; 24 | 25 | # create an image 26 | $image = new GD::Image (500,300); 27 | $white = $image->colorAllocate(255,255,255); 28 | $black = $image->colorAllocate( 0, 0, 0); 29 | $red = $image->colorAllocate(255, 0, 0); 30 | 31 | # create a new polyline 32 | $polyline = new GD::Polyline; 33 | 34 | # add some points 35 | $polyline->addPt( 0, 0); 36 | $polyline->addPt( 0,100); 37 | $polyline->addPt( 50,125); 38 | $polyline->addPt(100, 0); 39 | 40 | # polylines can use polygon methods (and vice versa) 41 | $polyline->offset(200,100); 42 | 43 | # rotate 60 degrees, about the centroid 44 | $polyline->rotate(3.14159/3, $polyline->centroid()); 45 | 46 | # scale about the centroid 47 | $polyline->scale(1.5, 2, $polyline->centroid()); 48 | 49 | # draw the polyline 50 | $image->polydraw($polyline,$black); 51 | 52 | # create a spline, which is also a polyine 53 | $spline = $polyline->addControlPoints->toSpline; 54 | $image->polydraw($spline,$red); 55 | 56 | # output the png 57 | #binmode STDOUT; 58 | #print $image->png; 59 | 60 | SampleImage($image, "polyline-synopsis.png", "Synopsis", "Polyline created by 'SYNOPSIS' section of documentation."); 61 | 62 | } 63 | 64 | if (1) { 65 | $image = NewImage(); 66 | 67 | $offset = 50; 68 | 69 | 70 | for $poly (new GD::Polygon, new GD::Polyline) { 71 | 72 | $table_info = []; 73 | 74 | $poly->addPt( 0, 0); 75 | $poly->addPt( 0,100); 76 | $poly->addPt( 50,125); 77 | $poly->addPt(100, 0); 78 | 79 | #print "this " . ref($poly) . " has " . $poly->length() . " points\n"; 80 | 81 | push @$table_info, ["".ref($poly).""]; 82 | push @$table_info, ['vertex number: ', 0..($poly->length()-1)]; 83 | 84 | @coords = $poly->vertices(); 85 | @coords = map {"[".int($_->[0]).",".int($_->[1])."]"} @coords; 86 | push @$table_info, ['coordinates (pre-offset): ', @coords]; 87 | 88 | @lengths = $poly->segLength(); 89 | @lengths = map {int($_+0.5)} @lengths; 90 | #print "segLengths are : @lengths\n"; 91 | #print "perimeter is : " . int($poly->segLength()) . "\n"; 92 | push @$table_info, ['segment lengths: ', @lengths]; 93 | 94 | @angles = $poly->segAngle(); 95 | @angles = map {int(r2d($_)+0.5)} @angles; 96 | #print "seg angles are : @angles\n"; 97 | push @$table_info, ['segment angles: ', @angles]; 98 | 99 | @angles = $poly->vertexAngle(); 100 | @angles = map {defined ($_) ? int(r2d($_)+0.5) : "undef"} @angles; 101 | #print "vertex angles are: @angles\n"; 102 | push @$table_info, ['vertex angles: ', @angles]; 103 | 104 | $poly->offset(50 + $offset,80); 105 | $offset += 200; 106 | 107 | # draw the original poly 108 | $image->polydraw($poly,$black); 109 | 110 | #print "\n\n"; 111 | 112 | push @$summary_table, genHTMLTable($table_info, 0); 113 | } 114 | 115 | SampleImage($image, "polyline-simple.png", "Simple", "GD::Polygon and GD::Polyline with same vertexes.

" . genHTMLTable([$summary_table], 1)); 116 | 117 | } 118 | 119 | if (1) { 120 | $image = NewImage(); 121 | 122 | $offset = 50; 123 | 124 | for $poly (new GD::Polygon, new GD::Polyline) { 125 | 126 | $poly->addPt( 0, 0); 127 | $poly->addPt( 0,100); 128 | $poly->addPt( 50,125); 129 | $poly->addPt(100, 0); 130 | 131 | $poly->offset(50 + $offset,80); 132 | $offset += 200; 133 | 134 | # draw the original poly 135 | $image->polydraw($poly,$green); 136 | 137 | # create and draw the control line for the spline 138 | $ctrlline = $poly->addControlPoints(); 139 | $image->polydraw($ctrlline,$cyan); 140 | 141 | # create and draw the spline itself 142 | $spline = $ctrlline->toSpline(); 143 | $image->polydraw($spline,$black); 144 | 145 | } 146 | 147 | SampleImage($image, "polyline-spline.png", "Spline", "Splines fit to vertices of polygon and polyline. $splinekey"); 148 | 149 | } 150 | 151 | 152 | if (1) { 153 | $image = NewImage(); 154 | 155 | $triangle = new GD::Polygon; 156 | 157 | $triangle->addPt( 0, 0); 158 | $triangle->addPt(-19, 95); 159 | $triangle->addPt( 19, 95); 160 | 161 | $triangle->offset(250,50); 162 | 163 | foreach (1..9) { 164 | $image->polydraw($triangle,gdBrushed); 165 | $triangle->rotate($TWO_PI / 9, 250, 150); 166 | } 167 | 168 | SampleImage($image, "polyline-star9.png", "Nine Pointed Star", "A triangle, rotated about a point other than the origin.
Demonstration of \$poly->rotate() and \$poly->offset()"); 169 | 170 | } 171 | 172 | if (1) { 173 | $image = NewImage(); 174 | 175 | $cloverControl = new GD::Polyline; 176 | $cloverControl->addPt(45,45); 177 | $cloverControl->addPt(10,10); 178 | $cloverControl->addPt(90,10); 179 | $cloverControl->addPt(55,45); 180 | $cloverControl->addPt(90,10); 181 | $cloverControl->addPt(90,90); 182 | $cloverControl->addPt(55,55); 183 | $cloverControl->addPt(90,90); 184 | $cloverControl->addPt(10,90); 185 | $cloverControl->addPt(45,55); 186 | $cloverControl->addPt(10,90); 187 | $cloverControl->addPt(10,10); 188 | $cloverControl->addPt(45,45); 189 | 190 | $clover = $cloverControl->toSpline(); 191 | 192 | # note that the three following transformations 193 | # could have been called on $cloverControl, instead, 194 | # followed by the above call 195 | 196 | $clover->offset($clover->centroid(-1)); 197 | $clover->scale(3, 3); 198 | $clover->offset(250, 150); 199 | 200 | $image->filledPolygon($clover,$green); 201 | 202 | SampleImage($image, "polyline-clover.png", "Clover", "Sample image generated by GD::Polygon"); 203 | 204 | } 205 | 206 | if (1) { 207 | $image = NewImage(); 208 | 209 | $polyline = new GD::Polyline; 210 | 211 | for (0..15) { 212 | $polyline->addPt(30 * $_ + 10, rand(90) + 5); 213 | } 214 | 215 | $image->polyline($polyline,$green); 216 | 217 | $ctrlline = $polyline->addControlPoints(); 218 | $ctrlline->offset(0,100); 219 | $image->polyline($ctrlline,$cyan); 220 | 221 | $spline = $ctrlline->toSpline(); 222 | $spline->offset(0,100); 223 | $image->polyline($spline,$black); 224 | 225 | SampleImage($image, "polyline-zigzag.png", "Zigzag", "Spline fit to random function. $splinekey"); 226 | 227 | } 228 | 229 | if (1) { 230 | $image = NewImage(); 231 | 232 | $ring_network = new GD::Polygon; 233 | 234 | $num_nodes = 10; 235 | $randfactor = 80; 236 | 237 | for (1..$num_nodes) { 238 | $x = 250 + 150 * cos($TWO_PI * $_/$num_nodes); 239 | $y = 150 + 100 * sin($TWO_PI * $_/$num_nodes); 240 | $x += rand($randfactor)-$randfactor/2; 241 | $y += rand($randfactor)-$randfactor/2; 242 | $ring_network->addPt($x, $y); 243 | } 244 | 245 | $image->setBrush($brush2); 246 | $image->polyline($ring_network->addControlPoints->toSpline,gdBrushed); 247 | 248 | $ring_node = new GD::Polygon; 249 | 250 | $ring_node->addPt( 0, 0); 251 | $ring_node->addPt(10, 0); 252 | $ring_node->addPt(10,10); 253 | $ring_node->addPt( 0,10); 254 | 255 | for $ring_vertex ($ring_network->vertices()) { 256 | $ring_node->offset($ring_node->centroid(-1)); 257 | $ring_node->offset(@$ring_vertex); 258 | $image->filledPolygon($ring_node,$grey); 259 | } 260 | 261 | SampleImage($image, "polyline-ring-network.png", "Ring Network", "Closed spline fit to nodes at somewhat random positions."); 262 | 263 | } 264 | 265 | WriteToFile("polyline-example.html", theHTML()); 266 | 267 | print "\n"; 268 | print "open 'polyline-example.html' in your favorite browser that supports PNG.\n"; 269 | print "\n"; 270 | 271 | print "done! " . localtime() . "\n"; 272 | 273 | ########################## 274 | # 275 | # helper functions 276 | # 277 | 278 | sub NewImage { 279 | $image = new GD::Image (500,300); 280 | 281 | $white = $image->colorAllocate(255,255,255); 282 | $black = $image->colorAllocate( 0, 0, 0); 283 | $grey = $image->colorAllocate(128,128,128); 284 | $red = $image->colorAllocate(255, 0, 0); 285 | $orange = $image->colorAllocate(255,196, 0); 286 | $green = $image->colorAllocate( 0,255, 0); 287 | $blue = $image->colorAllocate( 0, 0,255); 288 | $cyan = $image->colorAllocate( 0,255,255); 289 | $purple = $image->colorAllocate(206, 0,165); 290 | 291 | $brush_width = 2; 292 | $brush_color = [255,128,0]; 293 | $brush = new GD::Image($brush_width,$brush_width); 294 | $brush->transparent($brush->colorAllocate(255,255,255)); 295 | $brush->filledRectangle(0,0,$brush_width,$brush_width,$brush->colorAllocate(@$brush_color)); 296 | $brush1 = $brush; 297 | 298 | $brush_width = 3; 299 | $brush_color = [206,0,165]; 300 | $brush = new GD::Image($brush_width,$brush_width); 301 | $brush->transparent($brush->colorAllocate(255,255,255)); 302 | $brush->filledRectangle(0,0,$brush_width,$brush_width,$brush->colorAllocate(@$brush_color)); 303 | $brush2 = $brush; 304 | 305 | $image->setBrush($brush1); 306 | 307 | $image; 308 | } 309 | 310 | my $html; 311 | 312 | sub SampleImage { 313 | my $image = shift; 314 | my $file = shift; 315 | my $title = shift; 316 | my $text = shift; 317 | 318 | WriteToBinaryFile($file, $image->png()); 319 | 320 | $html .= "
\n"; 321 | $html .= "$title - $file
\n"; 322 | $html .= "

$text

\n"; 323 | 324 | } 325 | 326 | sub theHTML { 327 | $html; 328 | } 329 | 330 | sub WriteToFile { 331 | my $file = shift || return 0; 332 | my $contents = shift || ""; 333 | 334 | open (NEWFILE, ">" . $file) or die "couldn't write to file $file"; 335 | print NEWFILE $contents; 336 | close(NEWFILE); 337 | 338 | print "created file $file\n"; 339 | } 340 | 341 | sub WriteToBinaryFile { 342 | my $file = shift || return 0; 343 | my $contents = shift || ""; 344 | 345 | open (NEWFILE, ">" . $file) or die "couldn't write to file $file"; 346 | binmode NEWFILE; 347 | print NEWFILE $contents; 348 | close(NEWFILE); 349 | 350 | print "created file $file\n"; 351 | } 352 | 353 | sub genHTMLTable { 354 | my $array_of_arrays = shift; 355 | my $border = shift; 356 | my $html_table; 357 | 358 | $html_table .= ""; 359 | for my $array_of_items (@$array_of_arrays) { 360 | $html_table .= ""; 363 | } 364 | $html_table .= "
"; 361 | $html_table .= join("", @$array_of_items); 362 | $html_table .= "
"; 365 | $html_table; 366 | } 367 | 368 | -------------------------------------------------------------------------------- /t/test_data/frog.xpm: -------------------------------------------------------------------------------- 1 | /* XPM */ 2 | static char *magick[] = { 3 | /* columns rows colors chars-per-pixel */ 4 | "48 48 256 2", 5 | " c #060604040606", 6 | ". c #080888884040", 7 | "X c #9c9c9e9e4c4c", 8 | "o c #1f1fc7c73c3c", 9 | "O c #47478a8a5151", 10 | "+ c #4747c4c43939", 11 | "@ c #747448482828", 12 | "# c #4747a5a53131", 13 | "$ c #2020d8d8b8b8", 14 | "% c #a4a4c6c66c6c", 15 | "& c #71716a6a4444", 16 | "* c #0c0ca6a61414", 17 | "= c #4848aeae7474", 18 | "- c #c8c896960808", 19 | "; c #040446460c0c", 20 | ": c #4848d8d8a0a0", 21 | "> c #0505e9e9e5e5", 22 | ", c #a4a443431111", 23 | "< c #d4d4a6a67c7c", 24 | "1 c #d0d0a8a82424", 25 | "2 c #6464a2a24444", 26 | "3 c #2929ededd9d9", 27 | "4 c #242484845c5c", 28 | "5 c #4848b3b33737", 29 | "6 c #040427270606", 30 | "7 c #6767c7c75757", 31 | "8 c #a2a254541a1a", 32 | "9 c #eaeaaaaa1414", 33 | "0 c #4747d9d95454", 34 | "q c #4646c2c27878", 35 | "w c #2e2eaaaa2c2c", 36 | "e c #0808f6f6dede", 37 | "r c #4a4ab4b44f4f", 38 | "t c #282805050505", 39 | "y c #4747cfcf3d3d", 40 | "u c #e9e9adad4545", 41 | "i c #2828d6d63636", 42 | "p c #272787872f2f", 43 | "a c #4949e9e9c7c7", 44 | "s c #2626fafaf6f6", 45 | "d c #3737b5b52929", 46 | "f c #717155552727", 47 | "g c #4c4c60604040", 48 | "h c #040418180505", 49 | "j c #e4e48e8e0707", 50 | "k c #a3a353533333", 51 | "l c #3838c6c62828", 52 | "z c #5656c6c63c3c", 53 | "x c #6767adad7373", 54 | "c c #fafab4b41212", 55 | "v c #68688c8c4848", 56 | "b c #292993935959", 57 | "n c #a8a868680808", 58 | "m c #5959b5b55252", 59 | "M c #3c3cb5b55555", 60 | "N c #3333c7c75555", 61 | "B c #b5b54a4a2626", 62 | "V c #26269a9a1c1c", 63 | "C c #e4e49a9a5c5c", 64 | "Z c #4646a9a95454", 65 | "A c #484894943434", 66 | "S c #1818f9f9e9e9", 67 | "D c #e4e4caca4c4c", 68 | "F c #040434340808", 69 | "G c #fafaa9a90606", 70 | "H c #e8e89c9c0606", 71 | "J c #909054541717", 72 | "K c #4747c6c65252", 73 | "L c #a7a745452e2e", 74 | "P c #2929edededed", 75 | "I c #3c3ccece1c1c", 76 | "U c #f9f99a9a0707", 77 | "Y c #1c1ce9e9e9e9", 78 | "T c #36368b8b6666", 79 | "R c #6161e6e6d1d1", 80 | "E c #4646bbbb7474", 81 | "W c #b7b755551111", 82 | "Q c #3737b4b43d3d", 83 | "! c #414175754040", 84 | "~ c #181805050404", 85 | "^ c #9494c2c28484", 86 | "/ c #3939d2d2cfcf", 87 | "( c #10107e7e3030", 88 | ") c #6464cecec9c9", 89 | "_ c #161615150404", 90 | "` c #5656aaaa5a5a", 91 | "' c #ccccdededcdc", 92 | "] c #929263633737", 93 | "[ c #8c8c52522f2f", 94 | "{ c #a3a35c5c1717", 95 | "} c #4949bcbc5454", 96 | "| c #b6b658583939", 97 | " . c #2c2c6e6e2c2c", 98 | ".. c #565685856666", 99 | "X. c #3838fbfbf3f3", 100 | "o. c #e7e7fdfdf9f9", 101 | "O. c #c4c4bebe1414", 102 | "+. c #5757baba3737", 103 | "@. c #373788884444", 104 | "#. c #04041b1b2424", 105 | "$. c #3737c5c53b3b", 106 | "%. c #040428282222", 107 | "&. c #fbfba9a92020", 108 | "*. c #a2a24c4c2b2b", 109 | "=. c #09099a9a3737", 110 | "-. c #8484b2b26868", 111 | ";. c #4646caca3b3b", 112 | ":. c #8a8a44441c1c", 113 | ">. c #6666b9b96c6c", 114 | ",. c #5757bcbc5b5b", 115 | "<. c #3535bbbb3c3c", 116 | "1. c #45458b8b6c6c", 117 | "2. c #6666b6b65b5b", 118 | "3. c #26268b8b7e7e", 119 | "4. c #0606fcfcfafa", 120 | "5. c #a4a45b5b3838", 121 | "6. c #c9c967671919", 122 | "7. c #fafaa0a00808", 123 | "8. c #5757b8b87474", 124 | "9. c #59597a7a3737", 125 | "0. c #0707f1f1f2f2", 126 | "q. c #1515fbfbfbfb", 127 | "w. c #34346e6e5c5c", 128 | "e. c #8f8f43433737", 129 | "r. c #05050c0c0505", 130 | "t. c #4848dbdbdcdc", 131 | "y. c #3939ebebd4d4", 132 | "u. c #4747e6e6e4e4", 133 | "i. c #373798985959", 134 | "p. c #9191fefefcfc", 135 | "a. c #a4a49a9a1c1c", 136 | "s. c #6464e2e26c6c", 137 | "d. c #b8b8b8b83434", 138 | "f. c #2121b9b92525", 139 | "g. c #c4c4a2a24444", 140 | "h. c #ccccc2c29494", 141 | "j. c #acacc2c28484", 142 | "k. c #d3d3fefefbfb", 143 | "l. c #b4b4fefefcfc", 144 | "z. c #a4a4aeae5454", 145 | "x. c #717177773f3f", 146 | "c. c #6f6f9b9b4949", 147 | "v. c #efefbbbb3737", 148 | "b. c #8c8c78785050", 149 | "n. c #464696967070", 150 | "m. c #6060e8e8ecec", 151 | "M. c #6868dcdcb8b8", 152 | "N. c #c6c6a8a84646", 153 | "B. c #a9a964644545", 154 | "V. c #3939d8d83d3d", 155 | "C. c #7474cccc7272", 156 | "Z. c #2020a8a84343", 157 | "A. c #7c7cb2b2acac", 158 | "S. c #262699994040", 159 | "D. c #aeaeb9b95f5f", 160 | "F. c #24241a1a0404", 161 | "G. c #dcdcb2b2c4c4", 162 | "H. c #3939a6a65757", 163 | "J. c #2424bebe6464", 164 | "K. c #b8b8b7b7bcbc", 165 | "L. c #b4b4dede8c8c", 166 | "P. c #3737dfdfd4d4", 167 | "I. c #1010dddddcdc", 168 | "U. c #646465653a3a", 169 | "Y. c #69699e9e6c6c", 170 | "T. c #bcbca8a83c3c", 171 | "R. c #d4d4b9b94141", 172 | "E. c #4444f2f2cccc", 173 | "W. c #6c6c92927c7c", 174 | "Q. c #6161f3f3c4c4", 175 | "!. c #dada9d9d1414", 176 | "~. c #f4f4a2a24040", 177 | "^. c #09097d7d5151", 178 | "/. c #6565abab5959", 179 | "(. c #2a2a97977a7a", 180 | "). c #5959dede6767", 181 | "_. c #5757c8c86c6c", 182 | "`. c #f8f8aaaa4444", 183 | "'. c #5c5c9c9c5c5c", 184 | "]. c #5050f3f3ecec", 185 | "[. c #7878ceceb8b8", 186 | "{. c #2f2f7c7c5050", 187 | "}. c #bcbc72722c2c", 188 | "|. c #3434e4e44848", 189 | " X c #8484aeae4444", 190 | ".X c #5c5caeae4444", 191 | "XX c #717155554444", 192 | "oX c #424279795f5f", 193 | "OX c #94946d6d5151", 194 | "+X c #dcdc9c9c5454", 195 | "@X c #747478786060", 196 | "#X c #191999994040", 197 | "$X c #5757dbdbdada", 198 | "%X c #5c5cf2f2e8e8", 199 | "&X c #3c3ccfcf6464", 200 | "*X c #91914d4d1c1c", 201 | "=X c #2c2c7c7c6969", 202 | "-X c #1c1c8d8d4242", 203 | ";X c #808066664444", 204 | ":X c #7777aeae6f6f", 205 | ">X c #3939ecece8e8", 206 | ",X c #f8f8fcfcfafa", 207 | " q.q.UXs s p.l.k.k.,Xo.,Xo.k.k.o.k.k.k.l.p.t.P q.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.", 265 | "4.4.4.q.> q.I.>Xl.k.o.o.,X,Xk.o.o.o.,Xk.k.l.l.p.P 4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.4.> 4.4.", 266 | "0.4.4.4.4.q.S S P ].l.k.k.l.l.k.k.l.l.l.p.X.I.0.4.4.4.4.4.4.4.S 4.4.4.4.4.4.4.4.q.4.4.4.4.4.4.4.", 267 | "4.4.4.0.q.e s 0.e q.>Xp.m.m./ u.$Xt.t.>Xs q.4.4.4.4.4.4.4.4.0.q.4.4.4.4.4.4.4.4.UXS s q.e 4.4.0.", 268 | "4.0.4.q.X.>X0Xs S 0.> Y P Y P s Y s s 0.0.0.q.q.4.4.4.4.4.4.4.4.UXq.0.4.4.4.4.4.s P.t./ s 4.4.4.", 269 | "4.4.Y P %.%.eXy.3 S q.q.0.q.4.4.4.0.4.4.4.q.0.4.4.4.4.4.4.4.4.0.UXq.4.4.4.4.S y.P.eX#.%.u.UXq.4.", 270 | "4.UX].6 (.4 4 6 #.$X>XS q.0.4.4.4.4.0.4.4.0.4.4.4.4.4.4.4.0.q.0.4.4.4.4.4.S P.%.6 3.3.3.#.t.S 4.", 271 | "e X.h =XT H.sX@.gX6 / X.> q.4.4.4.0.X.0XP X.UXUXs UXX.0X0XX.UXq.0.4.4.4.S X.6 3.T T 3.zX=XeX$ S ", 272 | "y.F cXn.( -XbX-XE (.F t.S 4.4.4.4.S P.#.#.#.%.%X/ m.#.#.#.#.>XS 4.0.4.e y.%.T oX=X4 T =X=X3.%.y.", 273 | "R 6 4 4 8.#X#X=.=.bX^.eXs > 4.4.S 3 %.o.,X,Xk.#.M.h o.,X,Xk.6 E.0.4.q.X.%.=Xw.O {.Z sXi.cX3.%.SX", 274 | "r.n.(.bX4 1X#XN J.uX(.F y.S 4.s >X6 k.,Xt ~ ,X,Xh k.o. ,X,X#.s e S P.6 1.oX@.# -X( -XH.4 =Xh ", 275 | "r.w.3.= @.@.* N N &XE . F y.s I.$Xh ,X~ G.,X ,Xr.o. ' o. ,Xr.0Xs >X%.gX{.dXp LXQ s.#X. cXKXr.", 276 | "h x VX@.-XM K $.BXf.0 uXcX%.u.].) #.k. K.K.r.,Xr.,Xr.K.K. ,X#.>XP %.(.zX4 sX} HXZXo o &X-Xw. ", 277 | "h VXlXO S.N l y I BXIXAX= 6 6X6 6 h k.o.r.r.k.o.h o.,X ,Xo.6 a y.%.=Xi.i.Q ZX5 AX* i =.q lXr.", 278 | "6 VXT @.Z.f.l l I I o 0 Z 6 F uXM ,.h o.,Xo.k.h '.h o.,X,Xo.6 M 6 6 1.1.p z V + PXAXi i BXS.{.h ", 279 | "h n.9X1XJ.0 l I + IX&XQ F ,.5 $.y K .Xh h h 6 8.,.m h r.h 6 FXK K C.6 dX7 PXPX+ ;.d i 5Xi <.x h ", 280 | "F VX4 #XZ.N + PXjX} F 6 ,.5 + l BXIXd hX5 jX<.<.$.$.} m LXr AXIXl f.$.F LXLXz + IXV.|.5Xo &XZ h ", 281 | "A.#.bXbXZ.N r F 6 F r ,.} 5 <.;.uX} 5 7 5 LX).uXuX} FX7 7 # jXK l y <.).F 6 F F IX|.f.5X|.J.6 [.", 282 | "[.eX^.q = r 6 m z <.BXQ } ,.8.h 6 6 r.r.r.h h h 6 h h r.r.h h h h .X>.Z uXK jXFX6 F $.|.f.N F R ", 283 | ") %.4 -XF 6 2.6 LXjXjX} 6 h h r.r. ~ r. ~ r.r.h h h ,.Z m 6 9XE F <.$.&XF / ", 284 | "6X6 T 6 M jXdX6 h h h r. ~ ~ h ~ t qXt t ~ ~ t qXt t ~ r.r. ~ r.h #.h r.h 8.H.} ; 5 uXF GX", 285 | "GX6 sXh jXQ ,.h r.r. r.~ t r.~ < C u +XiXqX:.~.C u N.h ~ ~ r. r.h ` 7 LXF + uXF GX", 286 | "Y eX=XF r Q ,.Z h h h r. r. < +X~.~.!.n J J ~.v.u g.h. ~ ~ h h xX+.z PXF $.J.eXP ", 287 | "q.P h h m +._.r x r.h F r.h h h r.r. ~ 4XtXD d.R.R.1 1 T.F. r.r.r.h h 6 h X.%.oX6 6 6 m x :X:XO 2.9Xh h h h h h h h h h h 6 h h 6 h h 6 6 PXK K + IXPX+..X6 h _.E F X.UX", 289 | "q.P %.3.x dXm F 6 6 h F 6 m x >.2.7 LX,.jXr ,.,.2.Z Z ,.r m C.LX<.0 Q uXBX;.l ; F Z 8.gXq F 0Xs ", 290 | "q.I.y.F b HX5 PX+ ;.Q M ` 6 h h ` Z uXBX$.$.0 d ;.+ IX0 $.Q Z m + } ,.'.kX6 F IXd AXq q F a E.$ ", 291 | "a Q.Q.a F #Xw V l BX&XK Z h ! O 6 F K <.N + y PXd ;.;.uXuX} ,.,.5 6 h h h .X+ l BX$.H.6 6X6XCXCX", 292 | "N.D.C.: E.; ^._.-XK <._.h .i.r r jXF 6 6 6 6 F F 6 6 6 h 6 6 F F i.oXoX1XuXBXl $.LX6 L.% NXd.O.", 293 | "7.v.D.C.Q.: F 4 b p } H.F O -XZ.K 5 5 2.x {.O {.r 2.>.KX1.sXHXd r ,.h h @.} IXBXjXh % z.R.9 9 c ", 294 | "G 9 u T.pX% h 6 h F @.'.:Xh i.M o BXz # 6 @.b E r jXm 6 i.-X$.i ;.FXHX/.2.2.6 6 h h D.R.!.&.G 7.", 295 | "9 !.u tXt r.9.! /.` h 6 h h @.i.N BXl z 6 sXb -X&XV C.6 @.E BXo $.+ 6 6 h h kXKX2 -.6 r.1 v.j 7.", 296 | "9 u ~ h 9.O ` 1Xr LXK ,.m 6 r.lX= } + +.F 1XsX,.jXjXm 6 H.S.IXy uXjXF H.@.1X9X/.>.` A .6 z FX2.h U. dX-XQ z 6 @.9XO '.2.m 6 -XM y <.m 8.h zX{.T 6 nX@.6 >.h 2 c.h d.", 298 | "t ;X@Xr...oXh Y.Y.h Y.-.r.U.OX {.#XAXQ F h yXr. h h h S.#X;.PX2 h h r.W.g r.9.v 6 nX! 6 9.X _ ", 299 | "XX~ ~ & _ & U.r. & f ;XU.6 E Q + ` ^ XX;X lXT -XK w hXh & & U._ pX~ _ z.h h D.~ ~ N.", 300 | ";XmX[ 5.rX:.MXvXMXvX5.[ [ ;Xb.! @.-XZ.F .Xc. OXMX yX{.F M jX# h T.tXv.DX9 v.1 9 2X- 2X!.9 9 9 ", 301 | "vX@ B.7XL 7X3XJ J { *.k iX[ x.lXh /.2.h r.OX[ MXf _ h ! x h Xa.qXH G G 7.7.c 9 H c 7.7.G U &.", 302 | "8 { 7X*.| *.*.8 k 3XiX*XMXOX@ t t f ~ ~ f MXMXMX5.iX] vX~ ~ @ qXqX!.c G G 7.G G G G 7.7.7.7.U 7.", 303 | "7XW 5.*.:.rXk aX*XJ J iX[ 5.rXe.e.B.:.e.B.rX*.k { J *X3X8 8 }.J DXv.7.7.G 7.U U G 7.7.7.7.U 7.7.", 304 | "L L *.k B.B.*X:.5.8 iXiX[ rXL | | k rX| 5.e.rX[ J n n DX`.H fXfXc &.H G c 7.G G 7.G G G G G 7.&.", 305 | "B k | [ *X*X*.aX5.*.*.k k L L L k e.k , e.aX{ { { 9 fX7.c 7.9 c U 7.&.&.7.7.G 7.7.G G G 9 9 G G ", 306 | "e.L L *.7Xk B 7XB B L B B B B 7Xk iX3X, 6.~.fX7.!.c &.7.7.c 9 H G 7.G 7.H G G 7.G 7.G 9 9 G 9 G ", 307 | "aX8 7X6.JXJX6., B B B B , W W { 8 { 7XW j &.U G G 7.7.7.7.7.c 7.G wX7.7.7.c G G 7.G G G G G c G ", 308 | "H 7.H U 7.7.7.7.7.&.&.7.fX7.9 9 &.fX7.7.G c 7.c G U 7.G 7.7.G c G U G G G 7.H 7.G 7.7.G 7.G G G ", 309 | "c c G G G G G G G G 9 9 c c 9 9 H 7.G G G G G G G U 7.7.7.G G 7.G 7.G U G c 7.&.&.7.7.7.7.7.7.G " 310 | }; 311 | -------------------------------------------------------------------------------- /t/GD.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use FileHandle; 7 | use FindBin qw($Bin); 8 | use lib "$Bin/../blib/lib","$Bin/../blib/arch","$Bin/../lib"; 9 | use constant FONT=>"$Bin/test_data/Generic.ttf"; 10 | use constant IMAGE_TESTS => 8; 11 | use Test::More tests => IMAGE_TESTS + 7; 12 | use IO::Dir; 13 | 14 | use_ok('GD',':DEFAULT',':cmp'); 15 | use_ok('GD::Simple'); 16 | 17 | chdir $Bin || die "Couldn't change to 't' directory: $!"; 18 | my $images = './test_data/images'; 19 | 20 | my $arg = shift; 21 | write_regression_tests() if (defined $arg && $arg eq '--write'); 22 | run_image_regression_tests(); 23 | run_round_trip_test(); 24 | catch_libgd_error(); 25 | test_cve2019_6977(); 26 | 27 | exit 0; 28 | 29 | sub write_regression_tests { 30 | # TODO get all the supported image formats dynamically 31 | my @image_types = qw(png gif jpeg tiff wbmp webp heif avif); 32 | if (GD::LIBGD_VERSION() < 2.0302 ) { 33 | # GD 2.3.2 disabled the old GD and GD2 formats by default 34 | unshift @image_types, 'gd2', 'gd'; 35 | } 36 | warn "Writing regression files..."; 37 | for my $suffix (@image_types) { 38 | my $op = ucfirst $suffix; 39 | $op = 'WBMP' if $suffix eq 'wbmp'; 40 | unless (GD::Image->can("newFrom$op")) { 41 | print "# not writing $op regression test: not supported\n"; 42 | next; 43 | } 44 | for my $t (1..IMAGE_TESTS) { 45 | my $data = eval "test${t}('$suffix')" or die $@; 46 | write_regression_test($data,$t,$suffix); 47 | } 48 | } 49 | } 50 | 51 | sub write_regression_test { 52 | my ($data,$test,$suffix) = @_; 53 | my $base = "$images/t${test}"; 54 | mkdir $base unless -d $base; 55 | my $count = 0; 56 | my $filename = sprintf ("$base/$test-%02d.$suffix",$count); 57 | while (-e $filename) { 58 | $count++; 59 | $filename = sprintf ("$base/$test-%02d.$suffix",$count); 60 | } 61 | open my $fh,'>',$filename or die "$filename: $!"; 62 | binmode($fh); 63 | print $fh $data->$suffix; 64 | close $fh or die "$filename: $!"; 65 | } 66 | 67 | sub compare { 68 | my ($data,$test,$suffix) = @_; 69 | my @files_to_match = glob("$images/t${test}/*.$suffix"); 70 | 71 | my $matched; 72 | for my $file (@files_to_match) { 73 | $matched ||= compare_image($data,$file,$suffix); 74 | } 75 | return $matched; 76 | } 77 | 78 | sub compare_image { 79 | my ($data1,$file,$suffix) = @_; 80 | my $op = ucfirst($suffix); 81 | my $method = "newFrom${op}"; 82 | my $data2 = eval {GD::Image->$method($file)} or die $@; 83 | return ! $data1->compare($data2) & GD_CMP_IMAGE(); 84 | } 85 | 86 | sub test1 { 87 | my $suffix = shift; 88 | my $im = new GD::Image(300,300); 89 | my($white) = $im->colorAllocate(255, 255, 255); 90 | my($black) = $im->colorAllocate(0, 0, 0); 91 | my($red) = $im->colorAllocate(255, 0, 0); 92 | my($green) = $im->colorAllocate(0,255,0); 93 | my($yellow) = $im->colorAllocate(255,250,205); 94 | my $fn = "./test_data/tile.$suffix"; 95 | my $op = ucfirst($suffix); 96 | my $tile = eval "GD::Image->newFrom${op}('$fn')" or die $@; 97 | return unless $tile; 98 | $im->setBrush($tile); 99 | $im->arc(100,100,100,150,0,360,gdBrushed()); 100 | $im->setTile($tile); 101 | $im->filledRectangle(150,150,250,250,gdTiled()); 102 | $im->rectangle(150,150,250,250,$black); 103 | $im->setStyle($green,$green,$green,gdTransparent(),$red,$red,$red,gdTransparent()); 104 | $im->line(0,280,300,280,gdStyled()); 105 | return $im; 106 | } 107 | 108 | sub test2 { 109 | my($im) = new GD::Image(300,300); 110 | my($white,$black,$red,$blue,$yellow) = ( 111 | $im->colorAllocate(255, 255, 255), 112 | $im->colorAllocate(0, 0, 0), 113 | $im->colorAllocate(255, 0, 0), 114 | $im->colorAllocate(0,0,255), 115 | $im->colorAllocate(255,250,205) 116 | ); 117 | my($brush) = new GD::Image(10,10); 118 | $brush->colorAllocate(255,255,255); # white 119 | $brush->colorAllocate(0,0,0); # black 120 | $brush->transparent($white); # white is transparent 121 | $brush->filledRectangle(0,0,5,2,$black); # a black rectangle 122 | $im->setBrush($brush); 123 | $im->arc(100,100,100,150,0,360,gdBrushed()); 124 | my($poly) = new GD::Polygon; 125 | $poly->addPt(30,30); 126 | $poly->addPt(100,10); 127 | $poly->addPt(190,290); 128 | $poly->addPt(30,290); 129 | $im->polygon($poly,gdBrushed()); 130 | $im->fill(132,62,$blue); 131 | $im->fill(100,70,$red); 132 | $im->fill(40,40,$yellow); 133 | $im->copy($im,150,150,20,20,50,50); 134 | $im->copyResized($im,10,200,20,20,100,100,50,50); 135 | return $im; 136 | } 137 | 138 | sub test3 { 139 | my($im) = new GD::Image(100,50); 140 | my($black,$white,$red,$blue) = 141 | ( 142 | $im->colorAllocate(0, 0, 0), 143 | $im->colorAllocate(255, 255, 255), 144 | $im->colorAllocate(255, 0, 0), 145 | $im->colorAllocate(0,0,255) 146 | ); 147 | $im->arc(50, 25, 98, 48, 0, 360, $white); 148 | $im->fill(50, 21, $red); 149 | return $im; 150 | } 151 | 152 | sub test4 { 153 | my($im) = new GD::Image(225,180); 154 | my($black,$white,$red,$blue,$yellow) = 155 | ($im->colorAllocate(0, 0, 0), 156 | $im->colorAllocate(255, 255, 255), 157 | $im->colorAllocate(255, 0, 0), 158 | $im->colorAllocate(0,0,255), 159 | $im->colorAllocate(255,250,205) 160 | ); 161 | my($poly) = new GD::Polygon; 162 | $poly->addPt(0,50); 163 | $poly->addPt(25,25); 164 | $poly->addPt(50,50); 165 | $im->filledPolygon($poly,$blue); 166 | $poly->offset(100,100); 167 | $im->filledPolygon($poly,$red); 168 | $poly->map(50,50,100,100,10,10,110,60); 169 | $im->filledPolygon($poly,$yellow); 170 | $poly->map($poly->bounds,50,20,80,160); 171 | $im->filledPolygon($poly,$white); 172 | return $im; 173 | } 174 | 175 | sub test5 { 176 | my($im) = new GD::Image(300,300); 177 | my($white,$black,$red,$blue,$yellow) = 178 | ( 179 | $im->colorAllocate(255, 255, 255), 180 | $im->colorAllocate(0, 0, 0), 181 | $im->colorAllocate(255, 0, 0), 182 | $im->colorAllocate(0,0,255), 183 | $im->colorAllocate(255,250,205) 184 | ); 185 | $im->transparent($white); 186 | my($brush) = new GD::Image(10,10); 187 | $brush->colorAllocate(255,255,255); 188 | $brush->colorAllocate(0,0,0); 189 | $brush->transparent($white); 190 | $brush->filledRectangle(0,0,5,2,$black); 191 | $im->string(gdLargeFont(),150,10,"Hello world!",$red); 192 | $im->string(gdSmallFont(),150,28,"Goodbye cruel world!",$blue); 193 | $im->stringUp(gdTinyFont(),280,250,"I'm climbing the wall!",$black); 194 | $im->charUp(gdMediumBoldFont(),280,280,"Q",$black); 195 | $im->setBrush($brush); 196 | $im->arc(100,100,100,150,0,360,gdBrushed()); 197 | my $poly = new GD::Polygon; 198 | $poly->addPt(30,30); 199 | $poly->addPt(100,10); 200 | $poly->addPt(190,290); 201 | $poly->addPt(30,290); 202 | $im->polygon($poly,gdBrushed()); 203 | $im->fill(132,62,$blue); 204 | $im->fill(100,70,$red); 205 | $im->fill(40,40,$yellow); 206 | return $im; 207 | } 208 | 209 | sub test6 { 210 | my $dtor = 0.0174533; 211 | my $pi = 3.141592654; 212 | my $xsize = 500; my $ysize = 500; my $scale = 1; 213 | my $x_offset = $xsize/2; my $y_offset = $ysize/2; 214 | my $im = new GD::Image($xsize,$ysize); 215 | my $poly = new GD::Polygon; 216 | my $col_bg = $im->colorAllocate(0,0,0); 217 | my $col_fg = $im->colorAllocate(255,255,0); 218 | my $col_fill = $im->colorAllocate(255,0,0); 219 | my $r_0 = 100; my $theta_0 = 20; my $spring_factor = 30; 220 | for(my $theta=0;$theta<=360;$theta++) { 221 | my $r = $r_0 + $spring_factor*sin(2*$pi*$theta/$theta_0); 222 | my $x = int($r * cos($theta*$dtor))*$scale+$x_offset; 223 | my $y = int($r * sin($theta*$dtor))*$scale+$y_offset; 224 | $poly->addPt($x,$y); 225 | } 226 | 227 | $im->filledPolygon($poly,$col_fill); # Call gdImageFilledPolygon() 228 | return $im; 229 | } 230 | 231 | sub test7 { 232 | my $im = GD::Image->new(400,250); 233 | if (!$im) { printf("Test7: no image");}; 234 | my($white,$black,$red,$blue,$yellow) = 235 | ( 236 | $im->colorAllocate(255, 255, 255), 237 | $im->colorAllocate(0, 0, 0), 238 | $im->colorAllocate(255, 0, 0), 239 | $im->colorAllocate(0,0,255), 240 | $im->colorAllocate(255,250,205) 241 | ); 242 | 243 | # Some TTFs 244 | $im->stringFT($black,FONT,12.0,0.0,20,20,"Hello world!") || warn $@; 245 | $im->stringFT($red,FONT,14.0,0.0,20,80,"Hello world!") || warn $@; 246 | $im->stringFT($blue,FONT,30.0,-0.5,60,100,"Goodbye cruel world!") || warn $@; 247 | return $im; 248 | } 249 | 250 | sub test8 { 251 | my $im = test4(); 252 | $im = $im->copyRotate90(); 253 | $im = $im->copyFlipHorizontal(); 254 | $im = $im->copyTranspose(); 255 | $im->rotate180(); 256 | $im->flipVertical(); 257 | $im = $im->copyReverseTranspose(); 258 | $im = $im->copyFlipVertical(); 259 | return $im; 260 | } 261 | 262 | sub run_image_regression_tests { 263 | my $default_image_type = 'gd2'; 264 | if (!GD::Image->can("newFromGd2") || GD::LIBGD_VERSION() >= 2.0302) { 265 | $default_image_type = 'png'; 266 | } 267 | my $suffix = $ENV{GDIMAGETYPE} || $default_image_type; 268 | print STDERR "# Testing gd ".GD::VERSION_STRING()." using $suffix support.\n"; 269 | for my $t (1..IMAGE_TESTS) { 270 | my $gd = eval "test${t}('$suffix')"; 271 | if (!$gd) { 272 | fail("unable to generate comparison image for test $t with $suffix: $@"); 273 | } else { 274 | my $ok = compare($gd,$t,$suffix); 275 | unless ($ok) { 276 | if (($suffix ne 'gd2') or ($t == 7)) { 277 | ok(1, "TODO image comparison test $t $suffix failed (regen with --write)"); 278 | } else { 279 | ok($ok, "image comparison test $t $suffix"); 280 | } 281 | diag("gd: ",GD::VERSION_STRING(), 282 | ", files: ",join(" ",glob("$images/t${t}/*.$suffix"))); 283 | } else { 284 | ok($ok, "image comparison test $t $suffix"); 285 | } 286 | } 287 | } 288 | } 289 | 290 | sub run_round_trip_test { 291 | my $image = GD::Image->new(300,300); 292 | $image->colorAllocate(255,255,255); 293 | $image->colorAllocate(0,0,0); 294 | $image->colorAllocate(255,0,0); 295 | $image->rectangle(0,0,300,300,0); 296 | $image->filledRectangle(10,10,50,50,2); 297 | if (GD::Image->can("newFromGd")) { 298 | my $gd = $image->gd; 299 | my $image2 = GD::Image->newFromGdData($gd); 300 | ok(!$image->compare($image2) & GD_CMP_IMAGE(),'round trip gd'); 301 | my $gd2 = $image->gd2; 302 | $image2 = GD::Image->newFromGd2Data($gd2); 303 | ok(!$image->compare($image2) & GD_CMP_IMAGE(),'round trip gd2'); 304 | } 305 | else { 306 | # GD 2.3.2 disabled the old GD and GD2 formats by default 307 | my $png = $image->png; 308 | my $image2 = GD::Image->newFromPngData($png); 309 | ok(!$image->compare($image2) & GD_CMP_IMAGE(),'round trip png'); 310 | my $gif = $image->gif; 311 | $image2 = GD::Image->newFromGifData($gif); 312 | ok(!$image->compare($image2) & GD_CMP_IMAGE(),'round trip gif'); 313 | } 314 | } 315 | 316 | sub catch_libgd_error { 317 | diag("ignore corrupt png error messages..."); 318 | SKIP: { 319 | skip "No PNG support", 2 unless defined &GD::Image::newFromPng; 320 | my $image = eval { GD::Image->newFromPng("test_data/images/corrupt.png") }; 321 | is($image, undef); 322 | ok($@, 'caught corrupt png'); 323 | } 324 | } 325 | 326 | sub test_cve2019_6977 { 327 | my $img1 = GD::Image->new(0xfff, 0xfff, 1); 328 | my $img2 = GD::Image->new(0xfff, 0xfff, 0); 329 | $img2->colorAllocate(0, 0, 0); 330 | $img2->setPixel (0, 0, 255); 331 | if (GD::LIBGD_VERSION() >= 2.10) { 332 | $img1->colorMatch ($img2); 333 | } 334 | ok(1, 'survived CVE 2019-6977'); # fails only under valgrind or asan 335 | } 336 | -------------------------------------------------------------------------------- /lib/GD/Image_pm.PL: -------------------------------------------------------------------------------- 1 | #!perl 2 | use Config; 3 | use File::Basename qw(&basename &dirname); 4 | use Cwd; 5 | 6 | my $DEFINES = ''; 7 | my $VERSION = ''; 8 | if (open F,".config.cache") { 9 | chomp($DEFINES = ); 10 | close F; 11 | } 12 | 13 | my $origdir = cwd; 14 | chdir dirname($0); 15 | my $file = 'Image.pm'; 16 | 17 | open OUT,">",$file or die "Can't create $file: $!"; 18 | 19 | print "Extracting $file (with variable substitutions)\n"; 20 | 21 | print OUT <<"!GROK!THIS!"; 22 | # DO NOT EDIT! THIS FILE IS AUTOGENERATED BY $0 23 | !GROK!THIS! 24 | 25 | print OUT << '!NO!SUBS!'; 26 | package GD::Image; 27 | 28 | use strict; 29 | use GD; 30 | use Symbol 'gensym','qualify_to_ref'; 31 | use vars '$VERSION'; 32 | $VERSION = '2.83'; 33 | 34 | =head1 NAME 35 | 36 | GD::Image - Image class for the GD image library 37 | 38 | =head1 SYNOPSIS 39 | 40 | See L 41 | 42 | =head1 DESCRIPTION 43 | 44 | Supported Image formats: 45 | 46 | =over 4 47 | 48 | !NO!SUBS! 49 | 50 | print OUT "=item Png\n\n" if $DEFINES =~ /HAVE_PNG/; 51 | print OUT "=item Gif\n\n" if $DEFINES =~ /HAVE_GIF/; 52 | print OUT "=item Gd\n\n=item Gd2\n\n" if $DEFINES =~ /HAVE_GD2/; 53 | print OUT "=item Jpeg\n\n" if $DEFINES =~ /HAVE_JPEG/; 54 | print OUT "=item Tiff\n\n" if $DEFINES =~ /HAVE_TIFF/; 55 | print OUT "=item Xpm\n\n" if $DEFINES =~ /HAVE_XPM/; 56 | print OUT "=item Xbm\n\n" if 1 or $DEFINES =~ /HAVE_XBM/; 57 | print OUT "=item WBMP\n\n" if 1 or $DEFINES =~ /HAVE_WBMP/; 58 | print OUT "=item BMP\n\n" if $DEFINES =~ /HAVE_BMP/; 59 | print OUT "=item GifAnim\n\n" if $DEFINES =~ /HAVE_GIFANIM/; 60 | print OUT "=item Webp\n\n" if $DEFINES =~ /HAVE_WEBP/; 61 | print OUT "=item Heif\n\n" if $DEFINES =~ /HAVE_HEIF/; 62 | print OUT "=item Avif\n\n" if $DEFINES =~ /HAVE_AVIF/; 63 | 64 | print OUT << '!NO!SUBS!'; 65 | =back 66 | 67 | Unsupported Image formats: 68 | 69 | =over 4 70 | 71 | !NO!SUBS! 72 | 73 | print OUT "=item Png\n\n" if $DEFINES !~ /HAVE_PNG/; 74 | print OUT "=item Gif\n\n" if $DEFINES !~ /HAVE_GIF/; 75 | print OUT "=item Gd\n\n=item Gd2\n\n" if $DEFINES !~ /HAVE_GD2/; 76 | print OUT "=item Jpeg\n\n" if $DEFINES !~ /HAVE_JPEG/; 77 | print OUT "=item Tiff\n\n" if $DEFINES !~ /HAVE_TIFF/; 78 | print OUT "=item Xpm\n\n" if $DEFINES !~ /HAVE_XPM/; 79 | print OUT "=item GifAnim\n\n" if $DEFINES !~ /HAVE_GIFANIM/; 80 | print OUT "=item Webp\n\n" if $DEFINES !~ /HAVE_WEBP/; 81 | print OUT "=item Heif\n\n" if $DEFINES !~ /HAVE_HEIF/; 82 | print OUT "=item Avif\n\n" if $DEFINES !~ /HAVE_AVIF/; 83 | print OUT "=item BMP\n\n" if $DEFINES !~ /HAVE_BMP/; 84 | 85 | print OUT << '!NO!SUBS!'; 86 | =back 87 | 88 | See L 89 | 90 | =head1 AUTHOR 91 | 92 | The GD.pm interface is copyright 1995-2005, Lincoln D. Stein. It is 93 | distributed under the same terms as Perl itself. See the "Artistic 94 | License" in the Perl source code distribution for licensing terms. 95 | 96 | The latest versions of GD.pm are available on CPAN: 97 | 98 | http://www.cpan.org 99 | 100 | =head1 SEE ALSO 101 | 102 | L 103 | L, 104 | L, 105 | L, 106 | L 107 | 108 | =cut 109 | 110 | # Copyright 1995 Lincoln D. Stein. See accompanying README file for 111 | # usage information 112 | 113 | *stringTTF = \&GD::Image::stringFT; 114 | 115 | sub _make_filehandle { 116 | shift; # get rid of class 117 | no strict 'refs'; 118 | my $thing = shift; 119 | return $thing if defined(fileno $thing); 120 | 121 | # otherwise try qualifying it into caller's package 122 | my $fh; 123 | { 124 | local $^W = 0; # to avoid uninitialized variable warning from Symbol.pm 125 | my $pkg = caller(2); 126 | $pkg = "main" unless defined $pkg;; 127 | $fh = qualify_to_ref($thing,$pkg); 128 | } 129 | return $fh if defined(fileno $fh); 130 | 131 | # otherwise treat it as a file to open 132 | $fh = gensym; 133 | if (!open($fh,$thing)) { 134 | die "$thing not found: $!"; 135 | return undef; 136 | } 137 | return $fh; 138 | } 139 | 140 | sub new { 141 | my $pack = shift; 142 | if (@_ == 1) { 143 | if (my $type = _image_type($_[0])) { 144 | my $method = "newFrom${type}Data"; 145 | return unless $pack->can($method); 146 | return $pack->$method($_[0]); 147 | } elsif (-f $_[0] and $_[0] =~ /\.gd$/) { 148 | my $type = 'Gd'; 149 | return unless my $fh = $pack->_make_filehandle($_[0]); 150 | my $method = "newFrom${type}"; 151 | return unless $pack->can($method); 152 | return $pack->$method($fh); 153 | } elsif (-f $_[0] and $_[0] =~ /\.gd2$/) { 154 | my $type = 'Gd2'; 155 | return unless my $fh = $pack->_make_filehandle($_[0]); 156 | my $method = "newFrom${type}"; 157 | return unless $pack->can($method); 158 | return $pack->$method($fh); 159 | } elsif (-f $_[0] and $_[0] =~ /\.wbmp$/) { 160 | my $type = 'WBMP'; 161 | return unless my $fh = $pack->_make_filehandle($_[0]); 162 | my $method = "newFrom${type}"; 163 | return unless $pack->can($method); 164 | return $pack->$method($fh); 165 | } elsif (-f $_[0] and $_[0] =~ /\.xpm$/) { 166 | my $type = 'Xpm'; 167 | my $method = "newFrom${type}"; 168 | return unless $pack->can($method); 169 | return $pack->$method($_[0]); 170 | } 171 | return unless my $fh = $pack->_make_filehandle($_[0]); 172 | my $magic; 173 | return unless read($fh,$magic,64); 174 | return unless my $type = _image_type($magic); 175 | seek($fh,0,0); 176 | my $method = "newFrom${type}"; 177 | if ($type eq 'Xpm') { 178 | return $pack->$method($_[0]); 179 | } else { 180 | return $pack->$method($fh); 181 | } 182 | } 183 | return $pack->_new(@_); 184 | } 185 | 186 | sub newTrueColor { 187 | my $pack = shift; 188 | return $pack->_new(@_, 1); 189 | } 190 | 191 | sub newPalette { 192 | my $pack = shift; 193 | return $pack->_new(@_, 0); 194 | } 195 | 196 | sub ellipse ($$$$$) { 197 | my ($self,$cx,$cy,$width,$height,$color) = @_; 198 | $self->arc($cx,$cy,$width,$height,0,360,$color); 199 | } 200 | 201 | # draws closed polygon with the specified color 202 | sub polygon { 203 | my $self = shift; 204 | my($p,$c) = @_; 205 | $self->openPolygon($p, $c); 206 | $self->line( @{$p->{'points'}->[0]}, 207 | @{$p->{'points'}->[$p->{'length'}-1]}, $c); 208 | } 209 | 210 | sub width { 211 | my $self = shift; 212 | my @bounds = $self->getBounds; 213 | $bounds[0]; 214 | } 215 | 216 | sub height { 217 | my $self = shift; 218 | my @bounds = $self->getBounds; 219 | $bounds[1]; 220 | } 221 | 222 | sub _image_type { 223 | my $data = shift; 224 | my $magic = substr($data,0,4); 225 | return 'Png' if $magic eq "\x89PNG"; 226 | return 'Jpeg' if ((substr($data,0,3) eq "\377\330\377") && 227 | ord(substr($data,3,1)) >= 0xc0); 228 | return 'Gif' if $magic eq "GIF8"; 229 | return 'Gd2' if $magic eq "gd2\000"; 230 | return 'Tiff' if $magic eq "\x4d\x4d\x00\x2a" or 231 | $magic eq "\x49\x49\x2a\x00" or 232 | $magic eq "IIN1"; 233 | return 'Bmp' if $magic eq "BMF\000"; 234 | return 'Webp' if $magic eq "RIFF" and substr($data,8,4) eq "WEBP"; 235 | if (substr($data,4,4) eq "ftyp") { #possibly ISOBMFF-compliant container like HEIF which us used for AVIF and HEIC 236 | #first 4 bytes (they are now in $magic) must contain 32-bit Big Endian size of the 'ftyp' box (including size field and 'ftyp' mark) 237 | my $boxsize = unpack("N", $magic); 238 | if($boxsize>=16 && ($boxsize & 0x3)==0) { #minimum size of 'ftyp' box is 16 bytes and it must be multiple of 4 239 | #Structure of 'ftyp' box (from offset 8): 240 | # uint32 major_brand; 241 | # uint32 minor_version; 242 | # uint32 compatible_brands[]; to end of the box 243 | my $brand = substr($data,8,4); #major_brand 244 | my %compat; 245 | if($boxsize>16) { #compatible_brands list is not empty 246 | %compat = map {$_=>1} unpack("(A4)*", substr($data,16,$boxsize-16)); 247 | } 248 | return 'Avif' if $brand eq 'avif' || $compat{'avif'}; 249 | #Consider recognizing 'avis' brand meaning AV1 image sequence 250 | 251 | return 'Heif' if $brand eq 'mif1' || $brand eq 'heic' || $brand eq 'heix' || $compat{'heic'} || $compat{'heix'} || $compat{'mif1'}; 252 | #'mif1' stands for 'Multiple Image Format' and is general for the HEIF image container with any codec 253 | #'heic' indicates that HEVC Main Profile is utilized 254 | #'heix' indicates that HEVC Main 10 profile is utilized 255 | #Consider recognizing: 256 | # 'msf1' brand meaning 'Multiple Sequence Format' for general image sequence in HEIF 257 | # 'hevc' brand for HEVC Main Profile sequence 258 | # 'hevx' brand for HEVC Main 10 Profile sequence 259 | } 260 | } 261 | return 'Xpm' if substr($data,0,9) eq "/* XPM */"; 262 | return 'Xbm' if substr($data,0,8) eq "#define "; 263 | return; 264 | } 265 | 266 | 267 | sub clone { 268 | croak("Usage: clone(\$image)") unless @_ == 1; 269 | my $self = shift; 270 | my ($x,$y) = $self->getBounds; 271 | my $new = $self->new($x,$y); 272 | return unless $new; 273 | $new->copy($self,0,0,0,0,$x,$y); 274 | return $new; 275 | } 276 | 277 | !NO!SUBS! 278 | 279 | if ($DEFINES =~ /HAVE_PNG/) { 280 | print OUT <<'!NO!SUBS!' 281 | sub newFromPng { 282 | croak("Usage: newFromPng(class,filehandle,[truecolor])") unless @_>=2; 283 | my($class) = shift; 284 | my($f) = shift; 285 | my $fh = $class->_make_filehandle($f); 286 | binmode($fh); 287 | $class->_newFromPng($fh,@_); 288 | } 289 | 290 | !NO!SUBS! 291 | } 292 | 293 | if ($DEFINES =~ /HAVE_GD2/) { 294 | print OUT <<'!NO!SUBS!' 295 | sub newFromGd { 296 | croak("Usage: newFromGd(class,filehandle)") unless @_==2; 297 | my($class,$f) = @_; 298 | my $fh = $class->_make_filehandle($f); 299 | binmode($fh); 300 | $class->_newFromGd($fh); 301 | } 302 | 303 | sub newFromGd2 { 304 | croak("Usage: newFromGd2(class,filehandle)") unless @_==2; 305 | my($class,$f) = @_; 306 | my $fh = $class->_make_filehandle($f); 307 | binmode($fh); 308 | $class->_newFromGd2($fh); 309 | } 310 | 311 | sub newFromGd2Part { 312 | croak("Usage: newFromGd2(class,filehandle,srcX,srcY,width,height)") unless @_==6; 313 | my($class,$f) = splice(@_,0,2); 314 | my $fh = $class->_make_filehandle($f); 315 | binmode($fh); 316 | $class->_newFromGd2Part($fh,@_); 317 | } 318 | !NO!SUBS! 319 | } 320 | 321 | if ($DEFINES =~ /HAVE_JPEG/) { 322 | print OUT <<'!NO!SUBS!' 323 | sub newFromJpeg { 324 | croak("Usage: newFromJpeg(class,filehandle,[truecolor])") unless @_>=2; 325 | my($class) = shift; 326 | my($f) = shift; 327 | my $fh = $class->_make_filehandle($f); 328 | binmode($fh); 329 | $class->_newFromJpeg($fh,@_); 330 | } 331 | 332 | !NO!SUBS! 333 | } 334 | 335 | if ($DEFINES =~ /HAVE_GIF/) { 336 | print OUT <<'!NO!SUBS!' 337 | sub newFromGif { 338 | croak("Usage: newFromGif(class,filehandle)") unless @_==2; 339 | my($class) = shift; 340 | my($f) = shift; 341 | my $fh = $class->_make_filehandle($f); 342 | binmode($fh); 343 | $class->_newFromGif($fh,@_); 344 | } 345 | 346 | !NO!SUBS! 347 | } 348 | 349 | if ($DEFINES =~ /HAVE_TIFF/) { 350 | print OUT <<'!NO!SUBS!' 351 | sub newFromTiff { 352 | croak("Usage: newFromTiff(class,filehandle)") unless @_==2; 353 | my($class,$f) = @_; 354 | my $fh = $class->_make_filehandle($f); 355 | binmode($fh); 356 | $class->_newFromTiff($fh); 357 | } 358 | 359 | !NO!SUBS! 360 | } 361 | 362 | print OUT <<'!NO!SUBS!'; 363 | sub newFromXbm { 364 | croak("Usage: newFromXbm(class,filehandle)") unless @_==2; 365 | my($class,$f) = @_; 366 | my $fh = $class->_make_filehandle($f); 367 | binmode($fh); 368 | $class->_newFromXbm($fh); 369 | } 370 | 371 | !NO!SUBS! 372 | 373 | if ($DEFINES =~ /HAVE_WEBP/) { 374 | print OUT <<'!NO!SUBS!' 375 | sub newFromWebp { 376 | croak("Usage: newFromWebp(class,filehandle)") unless @_==2; 377 | my($class,$f) = @_; 378 | my $fh = $class->_make_filehandle($f); 379 | binmode($fh); 380 | $class->_newFromWebp($fh); 381 | } 382 | 383 | !NO!SUBS! 384 | } 385 | 386 | if ($DEFINES =~ /HAVE_HEIF/) { 387 | print OUT <<'!NO!SUBS!' 388 | sub newFromHeif { 389 | croak("Usage: newFromHeif(class,filehandle)") unless @_==2; 390 | my($class,$f) = @_; 391 | my $fh = $class->_make_filehandle($f); 392 | binmode($fh); 393 | $class->_newFromHeif($fh); 394 | } 395 | 396 | !NO!SUBS! 397 | } 398 | 399 | if ($DEFINES =~ /HAVE_AVIF/) { 400 | print OUT <<'!NO!SUBS!' 401 | sub newFromAvif { 402 | croak("Usage: newFromAvif(class,filehandle)") unless @_==2; 403 | my($class,$f) = @_; 404 | my $fh = $class->_make_filehandle($f); 405 | binmode($fh); 406 | $class->_newFromAvif($fh); 407 | } 408 | 409 | !NO!SUBS! 410 | } 411 | 412 | if (1 or $DEFINES =~ /HAVE_WBMP/) { 413 | print OUT <<'!NO!SUBS!'; 414 | sub newFromWBMP { 415 | croak("Usage: newFromWBMP(class,filehandle)") unless @_==2; 416 | my($class) = shift; 417 | my($f) = shift; 418 | my $fh = $class->_make_filehandle($f); 419 | binmode($fh); 420 | $class->_newFromWBMP($fh,@_); 421 | } 422 | 423 | !NO!SUBS! 424 | } 425 | 426 | if ($DEFINES =~ /HAVE_BMP/) { 427 | print OUT <<'!NO!SUBS!'; 428 | sub newFromBmp { 429 | croak("Usage: newFromBmp(class,filehandle)") unless @_==2; 430 | my($class) = shift; 431 | my($f) = shift; 432 | my $fh = $class->_make_filehandle($f); 433 | binmode($fh); 434 | $class->_newFromBmp($fh,@_); 435 | } 436 | 437 | !NO!SUBS! 438 | } 439 | 440 | print OUT <<'!NO!SUBS!'; 441 | # Autoload methods go after __END__, and are processed by the autosplit program. 442 | 1; 443 | __END__ 444 | !NO!SUBS! 445 | 446 | close OUT or die "Can't close $file: $!"; 447 | chdir $origdir; 448 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | GD.pm -- A perl5 interface to Thomas Boutell's gd library. 2 | 3 | ABSTRACT: 4 | 5 | This is a autoloadable interface module for libgd, a popular library 6 | for creating and manipulating PNG files. With this library you can 7 | create PNG images on the fly or modify existing files. Features 8 | include: 9 | 10 | a. lines, polygons, rectangles and arcs, both filled and unfilled 11 | b. flood fills 12 | c. the use of arbitrary images as brushes and as tiled fill patterns 13 | d. line styling (dashed lines and the like) 14 | e. horizontal and vertical text rendering 15 | f. support for transparency and interlacing 16 | g. support for TrueType font rendering, via libfreetype. 17 | h. support for spline curves, via GD::Polyline 18 | i. support for symbolic font names, such as "helvetica:italic" 19 | j. support for symbolic color names, such as "green", via GD::Simple 20 | k. produces output in png, gif, jpeg, xbm and other formats supported by libgd 21 | l. produces output in svg format via GD::SVG. 22 | 23 | For full information on usage, see the accompanying man and html 24 | documentation. Also check the FAQ at the bottom of this document. 25 | 26 | INSTALLATION: 27 | 28 | 1. Windows users can find a binary PPM package in the repositories at 29 | these sites: 30 | 31 | http://trouchelle.com/perl/ppmrepview.pl 32 | http://www.bribes.org/perl/ppmdir.html 33 | 34 | These packages are not always updated to the most recent version, but 35 | GD is pretty stable and you usually won't miss the bleeding edge 36 | version. 37 | 38 | For Unix/darwin users and those who have a developer's kit installed 39 | on Windows (e.g. cygwin): 40 | 41 | 2. Make sure you have downloaded and installed the following packages: 42 | 43 | a. Perl 5.6.0 or higher: 44 | http://www.perl.com/ 45 | 46 | b. The gd graphics library: 47 | http://libgd.org 48 | 49 | c. The PNG graphics library: 50 | http://www.libpng.org/pub/png/libpng.html 51 | 52 | d. The zlib compression library: 53 | http://www.gzip.org/zlib/ 54 | 55 | (OPTIONAL) 56 | 57 | e. The FreeType font rendering library for TrueType fonts: 58 | http://www.freetype.org/ 59 | 60 | f. The JPEG library, version 6b or later: 61 | ftp://ftp.uu.net/graphics/jpeg/ 62 | 63 | g. The XPM library, a standard part of modern X Windows 64 | distributions. If you don't have a modern 65 | version of X, don't try to get XPM working. 66 | 67 | 3. On darwin, you can use these package managers to resolve dependencies and 68 | build libgd: 69 | 70 | i. MacPorts http://www.macports.org/ 71 | ii. Homebrew http://mxcl.github.io/homebrew/ 72 | 73 | If this module fails to compile and link, you are probably using an 74 | older version of libgd. Symptoms of this problem include errors about 75 | functions not being recognized in the gd.h header file, and undefined 76 | symbols from the linker. If you are having this type of error, please 77 | REMOVE all versions of libgd, gd.h from your system and reinstall 78 | libgd 2.0.28 or higher. Do not contact Lincoln for help until you 79 | have done this. 80 | 81 | Use GD 1.41 for libgd versions 1.8.4 and lower. 82 | 83 | 3. Unpack the tar file: 84 | 85 | zcat GD-2.XX.tar.gz | tar xvf - 86 | 87 | (Where "XX" is the most recent revision number.) This will create 88 | the directory GD-2.XX. 89 | 90 | 4. To compile GD.pm: 91 | 92 | a. cd GD-2.XX 93 | b. perl Makefile.PL 94 | c. make 95 | d. make test 96 | f. sudo make install 97 | 98 | This will create GD.pm and install it into 99 | the system-wide Perl library directory. You'll need root 100 | privileges to do the install step. If you don't have them, see below. 101 | 102 | During step (b), Makefile.PL will look for the program gdlib-config or gdlib.pc 103 | that newer versions of libgd install for you. If this program is not present, the 104 | Makefile.PL script will ask you whether to build support for 105 | JPEG, FreeType and/or XPM image formats. Please answer "y" (the default) 106 | if libgd was built with the feature, and "n" if it was not. Failure 107 | to answer correctly will lead to link errors. 108 | 109 | If, during step (b) you see notes about missing libraries, then this 110 | module will probably not link correctly, even though the warning may say 111 | "probably harmless". 112 | 113 | 5. Before you install GD, you will want to run the regression tests. You 114 | can do this after the "make" step by typing: 115 | 116 | make test 117 | 118 | 6. There are some demos you can run in ext/GD/demos. They print PNG 119 | files to standard output. To view the files, pipe their 120 | output to "display" or "xv" in this way: 121 | 122 | a. cd GD-2.XX/demos 123 | b perl shapes.pl | display - 124 | 125 | You will need a graphics program that can read and display PNG 126 | format. I recommend Image::Magick's display program, available from 127 | ftp://ftp.wizards.dupont.com/pub/ImageMagick/ 128 | If you don't have any display programs handy, you can save to a 129 | temporary file and display with recent versions of Netscape or 130 | Internet Explorer. 131 | 132 | 7. A program named fonttest is included in this package under demos. This 133 | generates an image showing all the built-in fonts available. If you have 134 | built libgd with TrueType support, and you have a directory containing 135 | some TrueType fonts, you can create a simple font listing by running 136 | the program truetype_test, also located in demos. 137 | 138 | 8. See demos/gd_example.cgi for an example of how to use GD to create 139 | a picture dynamically with a CGI script. It's intended to be run 140 | under a Web server. To see it work, install it in your server's 141 | cgi-bin/ directory and invoke it from a browser by fetching a URL like: 142 | 143 | http://your.site/cgi-bin/gd_example.cgi 144 | 145 | IF YOU RUN INTO PROBLEMS 146 | 147 | If the make and install all seem to go well but you get errors like 148 | "Fatal error: can't load module GD.so", or "Fatal error: unknown 149 | symbol gdFontSmall" when you try to run a script that uses GD, you may 150 | have problems with dynamic linking. Check whether other 151 | dynamically-linked Perl modules such as POSIX and DB_File run 152 | correctly. If not, then you'll have to link Perl statically, as 153 | described above. Other problems may be fixed by compiling libgd as a 154 | shared library, as described in step (2) of the installation 155 | instructions. 156 | 157 | If you are trying to compile and link GD on a Windows or Macintosh 158 | machine and fail, please verify that you are able to build the Perl 159 | distribution from source code. If you can't do that, then you don't 160 | have the compiler/linker/make tools required for building Perl 161 | modules. You may not even need to do this, as ActiveState and MacPerl 162 | both include precompiled versions of GD. 163 | 164 | If you have problems and can't solve it on your own, post a message to 165 | the newsgroup "comp.lang.perl.modules". There are some systems that 166 | require obscure compiler and linker options in order to compile 167 | correctly, and unfortunately I have a limited number of systems at my 168 | disposal. You're much more likely to get correct answers from the 169 | gurus on the newsgroup than from myself. 170 | 171 | THE GD::SIMPLE LIBRARY 172 | 173 | GD::Simple is a simplified API for GD. It supports turtle graphics, a 174 | unified interface for drawing text, and symbolic color names (like 175 | "green"). Run "perldoc GD::Simple" for information on using it. 176 | 177 | The GD::SVG LIBRARY 178 | 179 | GD::SVG, which is available separately on CPAN, provides a subset of 180 | GD method calls. For this subset, you can create images in SVG 181 | (scalable vector graphics) format. 182 | 183 | THE QUICKDRAW LIBRARY 184 | 185 | This is no longer supported. 186 | 187 | FREQUENTLY ASKED QUESTIONS 188 | 189 | 1. I get a warning about prerequisite Math::Trig not being found 190 | 191 | The version of Math::Trig that comes with Perl version 5.6.0 and 192 | lower has a bug in it that causes it not to be found even when it 193 | is installed. Try running perl -MMath::Trig -e0 from the command 194 | line. If you get no errors, go ahead and install GD. If you get an 195 | error, install Math::Trig from CPAN. 196 | 197 | 2. Why do I get errors about functions not being found when building this module? 198 | 199 | You need libgd (the C library that does all the work) version 2.0.28 or 200 | higher. Older versions will give you errors during GD 201 | installation. Get the latest version from http://libgd.org and install it. 202 | Sometimes just installing the new version of libgd is not enough: you must 203 | remove the old library first. Find the gd.h include file and all libgd files 204 | and remove them from your system. 205 | 206 | 3. Why do I get errors about symbols being undefined when building this module? 207 | 208 | See (1). 209 | 210 | 4. The %&#&#! thing doesn't compile at all! I'm getting lots of compile errors! 211 | 212 | Does "make" fail with messages like these? 213 | 214 | GD.xs: In function 'newDynamicCtx': 215 | GD.xs:440: error: 'gdIOCtx' has no member named 'gd_free' 216 | GD.xs: In function 'gd_cloneDim': 217 | GD.xs:460: error: 'struct gdImageStruct' has no member named 'alpha' 218 | GD.xs:460: error: 'struct gdImageStruct' has no member named 'alpha' 219 | GD.xs:466: error: 'struct gdImageStruct' has no member named 'thick' 220 | GD.xs:466: error: 'struct gdImageStruct' has no member named 'thick' 221 | 222 | If so, then you may have an old gd.h include file located somewhere 223 | in your system include path. Please find it and remove it. A typical 224 | location is /usr/include/gd.h. The way to make sure you are removing 225 | the correct gd.h is to run "gdlib-config --cflags" to find out where 226 | the current gd.h lives: 227 | 228 | % gdlib-config --cflags 229 | -I/usr/local/include 230 | 231 | This tells you that /usr/local/include/gd.h is the correct gd.h. Please 232 | find and remove any other gd.h. 233 | 234 | 5. My scripts fail with "Can't locate object method 'png' via package "GD::Image". 235 | 236 | libgd can now be built with support for one or more of the PNG, GIF, XPM or 237 | JPEG formats. If one or more of these formats are not supported by libgd, then 238 | the corresponding GD::Image methods will be unavailable. Unfortunately, many 239 | older scripts assume that the png() method will always be present. You can 240 | work around this issue with code like the following: 241 | 242 | my $image = $gd->can('png') ? $gd->png : $gd->gif; 243 | 244 | or if you prefer eval {} 245 | 246 | my $image = eval {$gd->png} || $gd->gif; 247 | 248 | As of libgd 2.0.33, GIF support is always compiled in, so (for the time being!) 249 | this is a safe fallback. 250 | 251 | 6. Is there a utility to convert X Windows BDF fonts into GD fonts. 252 | 253 | Yes. See the utility bdf2gdfont.pl. Run "bdf2gdfont.pl -h" to get help 254 | on using this. 255 | 256 | 7. Does GD run with Macintosh OS X? 257 | 258 | Yes. GD compiles just fine under OSX. However, you may need to 259 | remove old versions of libgd, libpng, and libz and reinstall the 260 | current versions before you try to install GD. 261 | 262 | 8. Does GD run with Win32 Perl? 263 | 264 | The latest ActiveState binaries for Win32 systems come with GD 265 | already compiled in and ready to go. I don't own any Win32 systems, 266 | and cannot provide you with help in compiling GD from scratch on such 267 | systems. Github actions and appveyor are used to test the windows builds. 268 | 269 | 9. GD won't compile on system XX. 270 | 271 | Because libgd relies on multiple external libraries, GD does as well. 272 | Unfortunately, different systems place their libraries in different 273 | places and sometimes are picky about the order in which libraries 274 | are linked. The best thing to do is to install the latest version of 275 | libgd. Recent versions of libgd contain a gdlib-config utility, which 276 | GD will use to determine which libraries are necessary and in which 277 | order to link them. 278 | 279 | Another thing to be aware of is that some Unix distributions provide 280 | a faulty precompiled version of Perl which is unable to build and 281 | load new C-based modules (like this one). If you are getting errors 282 | like this: 283 | 284 | /arch/auto/GD/GD.so: undefined symbol: SetCPerlObj at .... 285 | 286 | then you may have such a faulty version of Perl. The most reliable 287 | thing to do is to recompile Perl from source code, thereby ensuring 288 | that it is complete. 289 | 290 | 10. When I try to load an XPM file, all I get is blackness! 291 | 292 | The libgd createFromXpm() function works with some XPM files, and 293 | not with others. The problem is buried deep in the libXpm library 294 | somewhere. 295 | 296 | 11. The stringFTCircle() method doesn't work! 297 | 298 | I know. I think this might be a problem in libgd because I have 299 | never gotten it to work as a C program. If you have any insight 300 | into this problem let me know. 301 | 302 | 12. Test XX fails 303 | 304 | The regression tests for GD involve generating images, saving 305 | them as PNG, JPEG or GIF files, and then comparing the files bit-for-bit 306 | to known "correct" files. Sometimes one of the underlying 307 | C libraries such as libz, libpng or libgd is updated, causing 308 | GD to generate an image that is subtly different. These differences 309 | are usually insignificant, such as a reordering of colors in the 310 | color table, but they will call isolated tests to fail. If you 311 | are seeing the great majority of GD tests pass, but one or two 312 | fail, then you are probably seeing the effect of a new library. 313 | Just go ahead and install GD and drop me a note about the problem. 314 | 315 | BUG REPORTS 316 | 317 | Please report bugs, feature requests and propose code changes using 318 | the GitHub repository at https://github.com/lstein/Perl-GD. We do not 319 | check the CPAN RT bug system with any frequency. 320 | 321 | ACKNOWLEDGEMENTS: 322 | 323 | I'd like to thank Jan Pazdziora, Geoff Baysinger, and David Kilzer for 324 | their contributions to the library, as well as Thomas Boutell who 325 | wrote libgd. 326 | 327 | SOURCE CODE AND UPDATES: 328 | 329 | The current version of GD can be found in CPAN. The development 330 | version can be found on GitHub at https://github.com/lstein/Perl-GD. 331 | 332 | AUTHOR and LICENSE 333 | 334 | Copyright 1995-2014 Lincoln Stein 335 | Maintainance taken over by Reini Urban 2017. 336 | 337 | This package and its accompanying libraries is free software; you can 338 | redistribute it and/or modify it under the terms of the GPL (either 339 | version 1, or at your option, any later version) or the Artistic 340 | License 2.0. Refer to LICENSE for the full license text. 341 | package for details. 342 | 343 | -------------------------------------------------------------------------------- /ChangeLog: -------------------------------------------------------------------------------- 1 | 2.83 * Fix missing PNG regression (RT #153923) on old 2 | systems without the .pc, but gdlib-config. The check was too strict. 3 | Requires now File::Which. 4 | 2.82 * Improve HEIF/AVIF autodetection (RT #153305) by Yuriy Yevtukhov. 5 | * Fix strawberryperl default libgd path (shawnlaffan PR #54) 6 | * Fix AVIF and Webp autodetection in tests (shawnlaffan PR #54) 7 | 2.81 * Change GD::Polygon::transform to match old demos (RT #140043), 8 | and GD::Polyline. 9 | Add GD::Polygon::rotate(cw-radian) helper. 10 | Allow GD::Polygon::scale(2.0). 11 | 2.80 * Fix broken copyTranspose and copyReverseTranspose (RT #153300) 12 | by Yuriy Yevtukhov. 13 | * Add transformation tests 14 | * Fix wrong WBMP name and detection 15 | * Fix wrong filename extension auto-detection for gd,gd2,wbmp 16 | * Fix wrong filename extension auto-detection for xpm, 17 | newFromXpm needs the filename, not handle. 18 | * Fix wrong libgd doc link (PR #52) by Tsuyoshi Watanabe 19 | 2.79 * Improve image type autodetection (RT #153212), add a test 20 | * Fix Avif without Heif config 21 | * Improve gdlib.pc reader for supported library features 22 | 2.78 * Fix Use of uninitialized value $pkg in concatenation warning 23 | (RT #148899 and GH #47). Thanks to ppisar for the analysis. 24 | Adds a new hard Test::NoWarnings test requirement. 25 | 2.77 * add BMP support with libgd 2.1.0, PR #49 by PeterCJ 26 | * don't link to -lXPM without XPM nor X11, GH #45 27 | * rename ANIMGIF feature to GIFANIM 28 | * fix unused variable failure in GH CI, RT #141125 by PhilterPaper 29 | 2.76 * fix broken TIFF and AVIF support, PR #43 by Paul Howarth 30 | * re-enable XBM support (always on) 31 | * provide xbm magic support (a hack, for GD::Graph) 32 | 2.75 * add experimental support for TIFF and RAQM (with freetype) 33 | * improve GD2 tests (GH #42, RT #140856) 34 | * also list the unsupported image formats in the GD::Image pod 35 | * fix copyRotated pod (it rotates CCW) PR #36 by LorenzoTo 36 | * fix GD::Simple->fontMetrics docs and implementation GH #37 by Ben Crowell. 37 | fix lineheight calculation according to the docs. You might need to 38 | fix your code! 39 | * add image methods tiff, webp, heif, avif, and its documentation. 40 | * fix the fix for the poly->transform documentation RT #140043 41 | 2.74 * add experimental support for WEBP, HEIF and AVIF 42 | * document all supported Image formats in the GD::Image lib 43 | * added Github actions (for PR's) 44 | * fix poly->transform documentation RT #140043 45 | * fix GD,GD2 detection and tests RT #139399 (since libgd 2.3.3) 46 | fixed tests by Håkon Hægland. 47 | * POD: Remove indirect object constructors from example code snippet (PR #39) 48 | * patch from Ben Crowell that fixes incorrect behaviour of GD::Simple->fontMetrics 49 | * fix cross-compilation if gdlib.pc has no cflags by Fabrice Fontaine 50 | 2.73 * allow --options override the libgd options. Not recommended. 51 | See GH #33 and RT #130045 52 | 2.72 * fix CVE 2019-6977 colorMatch for older unpatched libgd versions. 53 | This is a severe security problem, an exploitable heap-overflow. 54 | See https://nvd.nist.gov/vuln/detail/CVE-2019-6977 55 | 2.71 * skip Test::Fork on freebsd (GH #25) 56 | 2.70 * fixes for hardened CCFLAGS with -Werror (RT #128167) 57 | 2.69 * little spelling error, GH #29 Xavier Guimard 58 | 2.68 * fix GD::Polygon->clear, RT #124463 Michael Cain 59 | 2.67 * fix thread-safety for GD::Simple %COLORS (#26 melak) 60 | * fix arc start-angle docs, RT #123277 Andrew G Gray 61 | * improve setBrush docs, RT #123194 Andrew G Gray 62 | * improve StringFT docs, RT #123193 63 | * replace MacOSX by darwin, and not by Mac OS X/macOS as suggested 64 | in PR #24 65 | * add GD::Image->_file method as suggested in RT #60488 by Kevin Ryde, 66 | also the helper GD::supportsFileType 67 | 2.66 * throw proper error on newFrom* with not-existing file 68 | * add t/transp.t from RT #40525 69 | * Improve RT #54366 multiple gd.h warning 70 | * better doc for GD::Simple->arc 71 | * fix ANIMGIF with libgd 2.3.0-dev 72 | 2.65 * fix --gdlib_config_path to accept an argument (fperrad) 73 | 2.64 * Update doc for LIBGD_VERSION() 74 | * Fix 5.6.2, which does not have float in its typemap 75 | 2.63 * renamed VERSION() to LIBGD_VERSION(), RT #121307. 76 | It was treated magically by "use GD 2.18" 77 | 2.62 * fixed wrong <5.14 code generated with ExtUtils::Constants 78 | RT #121297. Don't generate const-xs.inc, only when missing. 79 | * add -liconv on hpux also (our pkgconfig parser cannot handle it) 80 | 2.61 * add CONFIGURE_REQUIRES META 81 | * add --gdlib_config_path 82 | * add Image Filters: scatter, pixelate, negate, grayscale, brightness, 83 | contrast, color, selectiveBlur, edgeDetectQuick, gaussianBlur, emboss, 84 | meanRemoval, smooth, copyGaussianBlurred 85 | * add palette methods: createPaletteFromTrueColor, 86 | neuQuant (but discouraged), colorMatch. 87 | * add interpolation methods: copyScale, copyRotateInterpolated, 88 | interpolationMethod. 89 | * add double GD::VERSION 90 | * add all gd.h constants 91 | 2.60 * add missing methods newFromWBMP, newFromXbm, 92 | (RT #68784) and some missing docs 93 | * Add --lib_fontconfig_path, --fcgi options 94 | * rewrote most of the XS code 95 | * cleanup Makefile.PL #20 96 | 2.59 * error on failing libgd calls 97 | * fix colorClosestAlpha, colorAllocateAlpha 98 | * add missing documentation 99 | 2.58 * fix VERSION_STRING for 2.0.x 100 | * honor --lib_gd_path specific gdlib-config 101 | * Loosen the comparison tests with GDIMAGETYPE ne gd2 102 | * Improve gdlib-config parsing (PR #17), esp. with 2.0.34 103 | 2.57 * fix Jpeg magic number detection RT #26146 104 | * fix RGB - HSV roundtrips: RT #120572 by J2N-FORGET 105 | * fix -print-search-dirs errors RT #106265 106 | * co-maint to rurban 107 | * add hv_fetchs, CI smokers 108 | * add GD::VERSION_STRING api 109 | 2.56_03 * add alpha method 110 | * improve option handling 111 | * fix meta data 112 | 2.56_02 * fix feature extraction >= 2.2 [RT #119459] 113 | 2.56_01 * rm Build.PL, fix permissions, fix for missing gdlib-config 114 | 2.56 * Fix Makefile.PL so that it works again. 115 | 2.55 * Great simplification of regression framework ought to fix make test problems. 116 | * Replace ExtUtils::MakeMaker script with Module::Build system 117 | (just in time for Module::Build to be deprecated). 118 | * Remove archaic qd.pl (for creating QuickDraw picts) from distribution. 119 | 2.54 Patch from yurly@unet.net to fix image corruption in rotate180 when image height is odd. 120 | 2.53 Points to Gabor Szabo's GD::Simple tutorial, and fix link to repository. 121 | 2.52 Fix regression tests to run on Ubuntu 12.04 64bit. 122 | 2.51 Fix misleading warning message about location of gd.h file. 123 | 2.50 Fix gdUseFontConfig so that it can be called as a class method. 124 | 2.49 Add GitHub information to README. 125 | 2.48 Fix compile crash on windows and strawberry (https://rt.cpan.org/Public/Bug/Display.html?id=67990). 126 | 2.47 Fix compilation on older perl's without the Newxz macros. 127 | 2.46 Added a basic "use" test for GD::Simple 128 | 2.45 Clarified the GD license. There is now a formal LICENSE file in the package. 129 | 2.44 GD::Group now installed properly. 130 | Quenched compiler warning caused by Newxs() calls. 131 | 2.43 Added "transparent" color to GD::Simple. 132 | Fixed Makefile so that GD/Image.pm depends both on GD/Image.pm.PLS and .config.cache 133 | 2.42 Fixed magic number detection to autodetect certain missed jpeg files (thanks to Mike Walker) 134 | 2.41 Added backend support for grouping features in GD::SVG module. 135 | 2.40 ** Do not use - contains a bug ** 136 | 2.39 Makefile.PL will refuse to run if the proper version of libgd is unavailable. 137 | 2.38 Fixed bizarre warning about /usr/include/gd.h != /usr/include/gd.h. 138 | 2.37 GD/Image.pm did not bring in croak() properly, meaning that incorrect error messages are printed out when any of the newFromXXX() calls are made. 139 | 2.36 Instructions on using gdAntiAliased with palette images. 140 | 2.35 Some instructions on installation for Windows users. 141 | Doesn't push libpng onto @LIBS unless png support is requested. 142 | Supports Storable's freeze/thaw via a custom serializer. 143 | Remove "scale redefined" message during compilation of Polyline. 144 | 2.34 Added a check for stray gd.h include files from older installations. If any are 145 | found, Makefile.PL will issue a warning. 146 | Fixed incorrect documentation of GD::Simple->string() method. The method call 147 | *does* move the pen. 148 | 2.33 Added appropriate #ifdefs to allow to compile under version 5.6.0 (due to lack of 149 | threading macros before 5.8). 150 | 2.32 Added a GD::Simple->HSVtoRGB() method. 151 | Documentation fixes from Mark Manning. 152 | Added a clear() method to GD::Polygon to remove all vertices. 153 | 2.31 Fixed GD::Simple->transparent to support symbolic color names. 154 | Made changes that should render the module thread-safe. 155 | Changed newSVpv calls to newSVpvn, in hopes of improving performance. 156 | Added a GD::Simple->HSVtoRGB() method. 157 | Fixed incorrect freeing of user-provided raw data in newFromGdData() and newFromGd2Data() 158 | (this caused segfaults; patch provided by Nigel Sandever) 159 | 2.30 Migrated polyline() support into GD::Simple. 160 | 2.29 Better support for fonts and brushed patterns in GD::Simple 161 | 2.28 Having troubles getting all the modules installed correctly. Should work now. 162 | 2.27 Reworked the way that GD.pm is created at compile time so that CPAN picks up 163 | correct version information. No code changes. 164 | 2.26 CPAN isn't propagating GD, so I'll upload another version 165 | 2.25 Fixed Makefile.PL so that GD::Polyline and GD::Simple are installed (thanks to Guy Albertelli). 166 | 167 | 2.24 Fixed gif/anim gif support so that you can't have animated gif support without 168 | having gif support. 169 | 170 | 2.23 Added patch from Slaven Rezic which makes it possible to call GD constants 171 | in an OO way (without generating warnings), and removes #! from the 172 | top of autogenerated GD.pm 173 | Rewrote tests 11 and 12 - if they continue to randomly fail on various 174 | platforms, they will be removed. 175 | 2.22 Changed the way the gd and gd2 round-trip tests are evaluated. This 176 | might fix test failures that have been reported on some platforms. 177 | 2.21 Regression tests are now functional for versions of libgd compiled 178 | exclusively with PNG, JPEG or GIF support. 179 | 2.20 GD::Image->newFromGdData() and newFromGd2Data() got broken 180 | somewhere along the line. They are now fixed (and 181 | have a regression test). 182 | Added copyRotated() method. 183 | 2.19 Added a HAVE_FTCIRCLE define to handle versions of libgd that do not 184 | have the gdImageStringFTCircle() function. 185 | 2.18 This version needs libgd 2.0.28 or higher. 186 | Fixed documentation bug in synopsis of GD::Simple. 187 | Updated Polyline to version 0.20 188 | 2.17 Added animated GIF patches from Jaakko Hyvätti. 189 | Added dynamic bitmapped font loading support. 190 | Added fontconfig support. 191 | Added a simplified API called GD::Simple. 192 | Added support for kern control and other libgd-based FT improvements. 193 | Fixed a define that caused gif functions to be miscompiled on some platforms. 194 | Documentation fixes. 195 | 2.16 Fixed bug in GIF #IFDEFs pointed out by BZAJAC 196 | Added #IFDEF for WIN32 provided by Randy Kobes 197 | 2.15 Brought back GIF support (requires libgd 2.0.28 or higher). 198 | Takes advantage of gdlib-config support in libgd 2.0.27 or higher. 199 | 2.14 Support for AMD64 libraries. 200 | 2.12 Fixed regression test 10 to succeed when used with 201 | libgd 2.0.22 202 | 2.11 More alpha functions from Cory Watson 203 | 2.10 Suppress CAPI warning. 204 | Warn about Math::Trig warning 205 | 2.09 VMS documentation patch from Martin Zinser 206 | Non-standard library finding path options from Peter Kruty 207 | 2.08 Applied 5.00503 compatibility patch from Mathieu Arnold 208 | New check for JPEG magic tag returned by some digital cameras. 209 | 2.07 Now compatible with (and requires!) libgd 2.0.12. 210 | Added setThickness() method. 211 | Added support for compression level argument to png(). 212 | Added support for antialiasing drawing using setAntiAliased() and setAntiAliasedDontBled(). 213 | Added extended options to stringFT(). 214 | Added filledArc(), ellipse() and filledEllipse() methods. 215 | Added command-line options to Makefile.PL provided by David Eisenberg. 216 | 2.06 Added saveAlpha() and alphaBlending() methods. 217 | 2.05 Alpha methods courtesy Georges Arnould. 218 | 2.041 Added a regression test to detect certain versions of freetype. 219 | 2.04 Removed the patch file since Tom has begun adding his own configure file. 220 | Changed the context member from free to gd_free to allow for compiling. 221 | Fixed the regression tests since the gd-generated images have changed slightly. 222 | 2.03 Skipped so as to remain version number compatible with libgd. 223 | 2.02 Changed Math::Trig version requirement from 0.0 to 1.0 as Perl 5.8 224 | no long recognizes this as a valid version number. 225 | 2.01 Added Math::Trig to the prerequisites because GD::Polyline needs it. 226 | 2.00 Folded in support for gd version 2.0 from Dan Palermo 227 | Folded in support for splines (GD::Polyline) from Dan Harasty. 228 | Removed all GIF support. 229 | 1.43 Added demo of Type1 fonts to truetype demo from Slaven Rezic. 230 | 1.42 Fixed the patch_gd.pl file 231 | Version 2.0 is coming. 232 | 1.39 Fixed FreeType test, at least on some platforms. 233 | Added patches from Stephen Clouse to allow to build on 5.8.0rc1. 234 | 1.35 Patches to support Philip Warner's GIF-reinstating library 235 | maintained at http://www.rime.com.au/gd/ 236 | 1.34 Fixed problems that arise when compiling against older versions of 237 | libgd that do not have XPM support. 238 | 1.33 Updated patch file for gd 1.8.4 239 | 1.32 Added support for Tru64 UNIX v5.0 240 | 1.29 Fixed a corrupted .xpm file in the regression suite 241 | (caused test 9 to fail) 242 | 1.28 Added support for gd 1.8.3 243 | 1.27 Fixed strict refs problem on 5.00503 and earlier 244 | 1.26 Brought up to date with libgd 1.8.1 245 | 1.24-1.25 More tweaks to Makefile.PL. 246 | 1.23 Added a bunch more libraries and includes... might or might not port 247 | to other platforms now 248 | 1.22 Fix to Makefile.PL to accomodate linking static libraries. 249 | Added newFromGd2Part() method. 250 | Supports libgd 1.7.1. 251 | 1.21 Slight fix in regression tests so that test 8 doesn't fail when compiled 252 | without TrueType support. 253 | 1.20 Rewritten for libgd 1.6.3 254 | 1.19 Fixed Makefile.PL for better compilation on Windoze machines 255 | 256 | -------------------------------------------------------------------------------- /lib/GD/Polyline.pm: -------------------------------------------------------------------------------- 1 | ############################################################################ 2 | # 3 | # Polyline.pm 4 | # 5 | # Author: Dan Harasty 6 | # Email: harasty@cpan.org 7 | # Version: 0.2 8 | # Date: 2002/08/06 9 | # 10 | # For usage documentation: see POD at end of file 11 | # 12 | # For changes: see "Changes" file included with distribution 13 | # 14 | 15 | use strict; 16 | 17 | package GD::Polyline; 18 | 19 | ############################################################################ 20 | # 21 | # GD::Polyline 22 | # 23 | ############################################################################ 24 | # 25 | # What's this? A class with nothing but a $VERSION and @ISA? 26 | # Below, this module overrides and adds several modules to 27 | # the parent class, GD::Polygon. Those updated/new methods 28 | # act on polygons and polylines, and sometimes those behaviours 29 | # vary slightly based on whether the object is a polygon or polyline. 30 | # 31 | 32 | use vars qw($VERSION @ISA); 33 | $VERSION = "0.2"; 34 | @ISA = qw(GD::Polygon); 35 | 36 | 37 | package GD::Polygon; 38 | 39 | ############################################################################ 40 | # 41 | # new methods on GD::Polygon 42 | # 43 | ############################################################################ 44 | 45 | use GD; 46 | use Carp 'croak','carp'; 47 | 48 | use vars qw($bezSegs $csr); 49 | $bezSegs = 20; # number of bezier segs -- number of segments in each portion of the spline produces by toSpline() 50 | $csr = 1/3; # control seg ratio -- the one possibly user-tunable parameter in the addControlPoints() algorithm 51 | 52 | 53 | sub rotate { 54 | my ($self, $angle, $cx, $cy) = @_; 55 | $self->offset(-$cx,-$cy) if $cx or $cy; 56 | $self->transform(cos($angle),sin($angle),-sin($angle),cos($angle),$cx,$cy); 57 | } 58 | 59 | sub centroid { 60 | my ($self, $scale) = @_; 61 | my ($cx,$cy); 62 | $scale = 1 unless defined $scale; 63 | 64 | map {$cx += $_->[0]; $cy += $_->[1]} $self->vertices(); 65 | 66 | $cx *= $scale / $self->length(); 67 | $cy *= $scale / $self->length(); 68 | 69 | return ($cx, $cy); 70 | } 71 | 72 | 73 | sub segLength { 74 | my $self = shift; 75 | my @points = $self->vertices(); 76 | 77 | my ($p1, $p2, @segLengths); 78 | 79 | $p1 = shift @points; 80 | 81 | # put the first vertex on the end to "close" a polygon, but not a polyline 82 | push @points, $p1 unless $self->isa('GD::Polyline'); 83 | 84 | while ($p2 = shift @points) { 85 | push @segLengths, _len($p1, $p2); 86 | $p1 = $p2; 87 | } 88 | 89 | return @segLengths if wantarray; 90 | 91 | my $sum; 92 | map {$sum += $_} @segLengths; 93 | return $sum; 94 | } 95 | 96 | sub segAngle { 97 | my $self = shift; 98 | my @points = $self->vertices(); 99 | 100 | my ($p1, $p2, @segAngles); 101 | 102 | $p1 = shift @points; 103 | 104 | # put the first vertex on the end to "close" a polygon, but not a polyline 105 | push @points, $p1 unless $self->isa('GD::Polyline'); 106 | 107 | while ($p2 = shift @points) { 108 | push @segAngles, _angle_reduce2(_angle($p1, $p2)); 109 | $p1 = $p2; 110 | } 111 | 112 | return @segAngles; 113 | } 114 | 115 | sub vertexAngle { 116 | my $self = shift; 117 | my @points = $self->vertices(); 118 | 119 | my ($p1, $p2, $p3, @vertexAngle); 120 | 121 | $p1 = $points[$#points]; # last vertex 122 | $p2 = shift @points; # current point -- the first vertex 123 | 124 | # put the first vertex on the end to "close" a polygon, but not a polyline 125 | push @points, $p2 unless $self->isa('GD::Polyline'); 126 | 127 | while ($p3 = shift @points) { 128 | push @vertexAngle, _angle_reduce2(_angle($p1, $p2, $p3)); 129 | ($p1, $p2) = ($p2, $p3); 130 | } 131 | 132 | $vertexAngle[0] = undef if defined $vertexAngle[0] and $self->isa("GD::Polyline"); 133 | 134 | return @vertexAngle if wantarray; 135 | 136 | } 137 | 138 | 139 | 140 | sub toSpline { 141 | my $self = shift; 142 | my @points = $self->vertices(); 143 | 144 | # put the first vertex on the end to "close" a polygon, but not a polyline 145 | push @points, [$self->getPt(0)] unless $self->isa('GD::Polyline'); 146 | 147 | unless (@points > 1 and @points % 3 == 1) { 148 | carp "Attempt to call toSpline() with invalid set of control points"; 149 | return undef; 150 | } 151 | 152 | my ($ap1, $dp1, $dp2, $ap2); # ap = anchor point, dp = director point 153 | $ap1 = shift @points; 154 | 155 | my $bez = new ref($self); 156 | 157 | $bez->addPt(@$ap1); 158 | 159 | while (@points) { 160 | ($dp1, $dp2, $ap2) = splice(@points, 0, 3); 161 | 162 | for (1..$bezSegs) { 163 | my ($t0, $t1, $c1, $c2, $c3, $c4, $x, $y); 164 | 165 | $t1 = $_/$bezSegs; 166 | $t0 = (1 - $t1); 167 | 168 | # possible optimization: 169 | # these coefficient could be calculated just once and 170 | # cached in an array for a given value of $bezSegs 171 | 172 | $c1 = $t0 * $t0 * $t0; 173 | $c2 = 3 * $t0 * $t0 * $t1; 174 | $c3 = 3 * $t0 * $t1 * $t1; 175 | $c4 = $t1 * $t1 * $t1; 176 | 177 | $x = $c1 * $ap1->[0] + $c2 * $dp1->[0] + $c3 * $dp2->[0] + $c4 * $ap2->[0]; 178 | $y = $c1 * $ap1->[1] + $c2 * $dp1->[1] + $c3 * $dp2->[1] + $c4 * $ap2->[1]; 179 | 180 | $bez->addPt($x, $y); 181 | } 182 | 183 | $ap1 = $ap2; 184 | } 185 | 186 | # remove the last anchor point if this is a polygon -- since it will autoclose without it 187 | $bez->deletePt($bez->length()-1) unless $self->isa('GD::Polyline'); 188 | 189 | return $bez; 190 | } 191 | 192 | sub addControlPoints { 193 | my $self = shift; 194 | my @points = $self->vertices(); 195 | 196 | unless (@points > 1) { 197 | carp "Attempt to call addControlPoints() with too few vertices in polyline"; 198 | return undef; 199 | } 200 | 201 | my $points = scalar(@points); 202 | my @segAngles = $self->segAngle(); 203 | my @segLengths = $self->segLength(); 204 | 205 | my ($prevLen, $nextLen, $prevAngle, $thisAngle, $nextAngle); 206 | my ($controlSeg, $pt, $ptX, $ptY, @controlSegs); 207 | 208 | # this loop goes about creating polylines -- here called control segments -- 209 | # that hold the control points for the final set of control points 210 | 211 | # each control segment has three points, and these are colinear 212 | 213 | # the first and last will ultimately be "director points", and 214 | # the middle point will ultimately be an "anchor point" 215 | 216 | for my $i (0..$#points) { 217 | 218 | $controlSeg = new GD::Polyline; 219 | 220 | $pt = $points[$i]; 221 | ($ptX, $ptY) = @$pt; 222 | 223 | if ($self->isa('GD::Polyline') and ($i == 0 or $i == $#points)) { 224 | $controlSeg->addPt($ptX, $ptY); # director point 225 | $controlSeg->addPt($ptX, $ptY); # anchor point 226 | $controlSeg->addPt($ptX, $ptY); # director point 227 | next; 228 | } 229 | 230 | $prevLen = $segLengths[$i-1]; 231 | $nextLen = $segLengths[$i]; 232 | $prevAngle = $segAngles[$i-1]; 233 | $nextAngle = $segAngles[$i]; 234 | 235 | # make a control segment with control points (director points) 236 | # before and after the point from the polyline (anchor point) 237 | 238 | $controlSeg->addPt($ptX - $csr * $prevLen, $ptY); # director point 239 | $controlSeg->addPt($ptX , $ptY); # anchor point 240 | $controlSeg->addPt($ptX + $csr * $nextLen, $ptY); # director point 241 | 242 | # note that: 243 | # - the line is parallel to the x-axis, as the points have a common $ptY 244 | # - the points are thus clearly colinear 245 | # - the director point is a distance away from the anchor point in proportion to the length of the segment it faces 246 | 247 | # now, we must come up with a reasonable angle for the control seg 248 | # first, "unwrap" $nextAngle w.r.t. $prevAngle 249 | $nextAngle -= 2*pi() until $nextAngle < $prevAngle + pi(); 250 | $nextAngle += 2*pi() until $nextAngle > $prevAngle - pi(); 251 | # next, use seg lengths as an inverse weighted average 252 | # to "tip" the control segment toward the *shorter* segment 253 | $thisAngle = ($nextAngle * $prevLen + $prevAngle * $nextLen) / ($prevLen + $nextLen); 254 | 255 | # rotate the control segment to $thisAngle about it's anchor point 256 | $controlSeg->rotate($thisAngle, $ptX, $ptY); 257 | 258 | } continue { 259 | # save the control segment for later 260 | push @controlSegs, $controlSeg; 261 | 262 | } 263 | 264 | # post process 265 | 266 | my $controlPoly = new ref($self); 267 | 268 | # collect all the control segments' points in to a single control poly 269 | 270 | foreach my $cs (@controlSegs) { 271 | foreach my $pt ($cs->vertices()) { 272 | $controlPoly->addPt(@$pt); 273 | } 274 | } 275 | 276 | # final clean up based on poly type 277 | 278 | if ($controlPoly->isa('GD::Polyline')) { 279 | # remove the first and last control point 280 | # since they are director points ... 281 | $controlPoly->deletePt(0); 282 | $controlPoly->deletePt($controlPoly->length()-1); 283 | } else { 284 | # move the first control point to the last control point 285 | # since it is supposed to end with two director points ... 286 | $controlPoly->addPt($controlPoly->getPt(0)); 287 | $controlPoly->deletePt(0); 288 | } 289 | 290 | return $controlPoly; 291 | } 292 | 293 | 294 | # The following helper functions are for internal 295 | # use of this module. Input arguments of "points" 296 | # refer to an array ref of two numbers, [$x, $y] 297 | # as is used internally in the GD::Polygon 298 | # 299 | # _len() 300 | # Find the length of a segment, passing in two points. 301 | # Internal function; NOT a class or object method. 302 | # 303 | sub _len { 304 | # my ($p1, $p2) = @_; 305 | # return sqrt(($p2->[0]-$p1->[0])**2 + ($p2->[1]-$p1->[1])**2); 306 | my $pt = _subtract(@_); 307 | return sqrt($pt->[0] ** 2 + $pt->[1] **2); 308 | } 309 | 310 | use Math::Trig; 311 | 312 | # _angle() 313 | # Find the angle of... well, depends on the number of arguments: 314 | # - one point: the angle from x-axis to the point (origin is the center) 315 | # - two points: the angle of the vector defined from point1 to point2 316 | # - three points: 317 | # Internal function; NOT a class or object method. 318 | # 319 | sub _angle { 320 | my ($p1, $p2, $p3) = @_; 321 | my $angle = undef; 322 | if (@_ == 1) { 323 | return atan2($p1->[1], $p1->[0]); 324 | } 325 | if (@_ == 2) { 326 | return _angle(_subtract($p1, $p2)); 327 | } 328 | if (@_ == 3) { 329 | return _angle(_subtract($p2, $p3)) - _angle(_subtract($p2, $p1)); 330 | } 331 | } 332 | 333 | # _subtract() 334 | # Find the difference of two points; returns a point. 335 | # Internal function; NOT a class or object method. 336 | # 337 | sub _subtract { 338 | my ($p1, $p2) = @_; 339 | # print(_print_point($p2), "-", _print_point($p1), "\n"); 340 | return [$p2->[0]-$p1->[0], $p2->[1]-$p1->[1]]; 341 | } 342 | 343 | # _print_point() 344 | # Returns a string suitable for displaying the value of a point. 345 | # Internal function; NOT a class or object method. 346 | # 347 | sub _print_point { 348 | my ($p1) = @_; 349 | return "[" . join(", ", @$p1) . "]"; 350 | } 351 | 352 | # _angle_reduce1() 353 | # "unwraps" angle to interval -pi < angle <= +pi 354 | # Internal function; NOT a class or object method. 355 | # 356 | sub _angle_reduce1 { 357 | my ($angle) = @_; 358 | $angle += 2 * pi() while $angle <= -pi(); 359 | $angle -= 2 * pi() while $angle > pi(); 360 | return $angle; 361 | } 362 | 363 | # _angle_reduce2() 364 | # "unwraps" angle to interval 0 <= angle < 2 * pi 365 | # Internal function; NOT a class or object method. 366 | # 367 | sub _angle_reduce2 { 368 | my ($angle) = @_; 369 | $angle += 2 * pi() while $angle < 0; 370 | $angle -= 2 * pi() while $angle >= 2 * pi(); 371 | return $angle; 372 | } 373 | 374 | ############################################################################ 375 | # 376 | # new methods on GD::Image 377 | # 378 | ############################################################################ 379 | 380 | sub GD::Image::polyline { 381 | my $self = shift; # the GD::Image 382 | my $p = shift; # the GD::Polyline (or GD::Polygon) 383 | my $c = shift; # the color 384 | 385 | my @points = $p->vertices(); 386 | my $p1 = shift @points; 387 | my $p2; 388 | while ($p2 = shift @points) { 389 | $self->line(@$p1, @$p2, $c); 390 | $p1 = $p2; 391 | } 392 | } 393 | 394 | sub GD::Image::polydraw { 395 | my $self = shift; # the GD::Image 396 | my $p = shift; # the GD::Polyline or GD::Polygon 397 | my $c = shift; # the color 398 | 399 | return $self->polyline($p, $c) if $p->isa('GD::Polyline'); 400 | return $self->polygon($p, $c); 401 | } 402 | 403 | 404 | 1; 405 | __END__ 406 | 407 | =pod 408 | 409 | =head1 NAME 410 | 411 | GD::Polyline - Polyline object and Polygon utilities (including splines) for use with GD 412 | 413 | =head1 SYNOPSIS 414 | 415 | use GD; 416 | use GD::Polyline; 417 | 418 | # create an image 419 | $image = GD::Image->new (500,300); 420 | $white = $image->colorAllocate(255,255,255); 421 | $black = $image->colorAllocate( 0, 0, 0); 422 | $red = $image->colorAllocate(255, 0, 0); 423 | 424 | # create a new polyline 425 | $polyline = GD::Polyline->new; 426 | 427 | # add some points 428 | $polyline->addPt( 0, 0); 429 | $polyline->addPt( 0,100); 430 | $polyline->addPt( 50,125); 431 | $polyline->addPt(100, 0); 432 | 433 | # polylines can use polygon methods (and vice versa) 434 | $polyline->offset(200,100); 435 | 436 | # rotate 60 degrees, about the centroid 437 | $polyline->rotate(3.14159/3, $polyline->centroid()); 438 | 439 | # scale about the centroid 440 | $polyline->scale(1.5, 2, $polyline->centroid()); 441 | 442 | # draw the polyline 443 | $image->polydraw($polyline,$black); 444 | 445 | # create a spline, which is also a polyine 446 | $spline = $polyline->addControlPoints->toSpline; 447 | $image->polydraw($spline,$red); 448 | 449 | # output the png 450 | binmode STDOUT; 451 | print $image->png; 452 | 453 | =head1 DESCRIPTION 454 | 455 | B extends the GD module by allowing you to create polylines. Think 456 | of a polyline as "an open polygon", that is, the last vertex is not connected 457 | to the first vertex (unless you expressly add the same value as both points). 458 | 459 | For the remainder of this doc, "polyline" will refer to a GD::Polyline, 460 | "polygon" will refer to a GD::Polygon that is not a polyline, and 461 | "polything" and "$poly" may be either. 462 | 463 | The big feature added to GD by this module is the means 464 | to create splines, which are approximations to curves. 465 | 466 | =head1 The Polyline Object 467 | 468 | GD::Polyline defines the following class: 469 | 470 | =over 5 471 | 472 | =item C 473 | 474 | A polyline object, used for storing lists of vertices prior to 475 | rendering a polyline into an image. 476 | 477 | =item C 478 | 479 | Cnew> I 480 | 481 | Create an empty polyline with no vertices. 482 | 483 | $polyline = GD::Polyline->new; 484 | 485 | $polyline->addPt( 0, 0); 486 | $polyline->addPt( 0,100); 487 | $polyline->addPt( 50,100); 488 | $polyline->addPt(100, 0); 489 | 490 | $image->polydraw($polyline,$black); 491 | 492 | In fact GD::Polyline is a subclass of GD::Polygon, 493 | so all polygon methods (such as B and B) 494 | may be used on polylines. 495 | Some new methods have thus been added to GD::Polygon (such as B) 496 | and a few updated/modified/enhanced (such as B) I. 497 | See section "New or Updated GD::Polygon Methods" for more info. 498 | 499 | =back 500 | 501 | Note that this module is very "young" and should be 502 | considered subject to change in future releases, and/or 503 | possibly folded in to the existing polygon object and/or GD module. 504 | 505 | =head1 Updated Polygon Methods 506 | 507 | The following methods (defined in GD.pm) are OVERRIDDEN if you use this module. 508 | 509 | All effort has been made to provide 100% backward compatibility, but if you 510 | can confirm that has not been achieved, please consider that a bug and let the 511 | the author of Polyline.pm know. 512 | 513 | =over 5 514 | 515 | =item C 516 | 517 | C<$poly-Escale($sx, $sy, $cx, $cy)> I 518 | 519 | Scale a polything in along x-axis by $sx and along the y-axis by $sy, 520 | about centery point ($cx, $cy). 521 | 522 | Center point ($cx, $cy) is optional -- if these are omitted, the function 523 | will scale about the origin. 524 | 525 | To flip a polything, use a scale factor of -1. For example, to 526 | flip the polything top to bottom about line y = 100, use: 527 | 528 | $poly->scale(1, -1, 0, 100); 529 | 530 | =back 531 | 532 | =head1 New Polygon Methods 533 | 534 | The following methods are added to GD::Polygon, and thus can be used 535 | by polygons and polylines. 536 | 537 | Don't forget: a polyline is a GD::Polygon, so GD::Polygon methods 538 | like offset() can be used, and they can be used in 539 | GD::Image methods like filledPolygon(). 540 | 541 | =over 5 542 | 543 | =item C 544 | 545 | C<$poly-Erotate($angle, $cx, $cy)> I 546 | 547 | Rotate a polything through $angle (clockwise, in radians) about center point ($cx, $cy). 548 | 549 | Center point ($cx, $cy) is optional -- if these are omitted, the function 550 | will rotate about the origin 551 | 552 | In this function and other angle-oriented functions in GD::Polyline, 553 | positive $angle corresponds to clockwise rotation. This is opposite 554 | of the usual Cartesian sense, but that is because the raster is opposite 555 | of the usual Cartesian sense in that the y-axis goes "down". 556 | 557 | =item C 558 | 559 | C<($cx, $cy) = $poly-Ecentroid($scale)> I 560 | 561 | Calculate and return ($cx, $cy), the centroid of the vertices of the polything. 562 | For example, to rotate something 180 degrees about it's centroid: 563 | 564 | $poly->rotate(3.14159, $poly->centroid()); 565 | 566 | $scale is optional; if supplied, $cx and $cy are multiplied by $scale 567 | before returning. The main use of this is to shift an polything to the 568 | origin like this: 569 | 570 | $poly->offset($poly->centroid(-1)); 571 | 572 | =item C 573 | 574 | C<@segLengths = $poly-EsegLength()> I 575 | 576 | In array context, returns an array the lengths of the segments in the polything. 577 | Segment n is the segment from vertex n to vertex n+1. 578 | Polygons have as many segments as vertices; polylines have one fewer. 579 | 580 | In a scalar context, returns the sum of the array that would have been returned 581 | in the array context. 582 | 583 | =item C 584 | 585 | C<@segAngles = $poly-EsegAngle()> I 586 | 587 | Returns an array the angles of each segment from the x-axis. 588 | Segment n is the segment from vertex n to vertex n+1. 589 | Polygons have as many segments as vertices; polylines have one fewer. 590 | 591 | Returned angles will be on the interval 0 <= $angle < 2 * pi and 592 | angles increase in a clockwise direction. 593 | 594 | =item C 595 | 596 | C<@vertexAngles = $poly-EvertexAngle()> I 597 | 598 | Returns an array of the angles between the segment into and out of each vertex. 599 | For polylines, the vertex angle at vertex 0 and the last vertex are not defined; 600 | however $vertexAngle[0] will be undef so that $vertexAngle[1] will correspond to 601 | vertex 1. 602 | 603 | Returned angles will be on the interval 0 <= $angle < 2 * pi and 604 | angles increase in a clockwise direction. 605 | 606 | Note that this calculation does not attempt to figure out the "interior" angle 607 | with respect to "inside" or "outside" the polygon, but rather, 608 | just the angle between the adjacent segments 609 | in a clockwise sense. Thus a polygon with all right angles will have vertex 610 | angles of either pi/2 or 3*pi/2, depending on the way the polygon was "wound". 611 | 612 | =item C 613 | 614 | C<$poly-EtoSpline()> I 615 | 616 | Create a new polything which is a reasonably smooth curve 617 | using cubic spline algorithms, often referred to as Bezier 618 | curves. The "source" polything is called the "control polything". 619 | If it is a polyline, the control polyline must 620 | have 4, 7, 10, or some number of vertices of equal to 3n+1. 621 | If it is a polygon, the control polygon must 622 | have 3, 6, 9, or some number of vertices of equal to 3n. 623 | 624 | $spline = $poly->toSpline(); 625 | $image->polydraw($spline,$red); 626 | 627 | In brief, groups of four points from the control polyline 628 | are considered "control 629 | points" for a given portion of the spline: the first and 630 | fourth are "anchor points", and the spline passes through 631 | them; the second and third are "director points". The 632 | spline does not pass through director points, however the 633 | spline is tangent to the line segment from anchor point to 634 | adjacent director point. 635 | 636 | The next portion of the spline reuses the previous portion's 637 | last anchor point. The spline will have a cusp 638 | (non-continuous slope) at an anchor point, unless the anchor 639 | points and its adjacent director point are colinear. 640 | 641 | In the current implementation, toSpline() return a fixed 642 | number of segments in the returned polyline per set-of-four 643 | control points. In the future, this and other parameters of 644 | the algorithm may be configurable. 645 | 646 | =item C 647 | 648 | C<$polyline-EaddControlPoints()> I 649 | 650 | So you say: "OK. Splines sound cool. But how can I 651 | get my anchor points and its adjacent director point to be 652 | colinear so that I have a nice smooth curves from my 653 | polyline?" Relax! For The Lazy: addControlPoints() to the 654 | rescue. 655 | 656 | addControlPoints() returns a polyline that can serve 657 | as the control polyline for toSpline(), which returns 658 | another polyline which is the spline. Is your head spinning 659 | yet? Think of it this way: 660 | 661 | =over 5 662 | 663 | =item + 664 | 665 | If you have a polyline, and you have already put your 666 | control points where you want them, call toSpline() directly. 667 | Remember, only every third vertex will be "on" the spline. 668 | 669 | You get something that looks like the spline "inscribed" 670 | inside the control polyline. 671 | 672 | =item + 673 | 674 | If you have a polyline, and you want all of its vertices on 675 | the resulting spline, call addControlPoints() and then 676 | toSpline(): 677 | 678 | $control = $polyline->addControlPoints(); 679 | $spline = $control->toSpline(); 680 | $image->polyline($spline,$red); 681 | 682 | You get something that looks like the control polyline "inscribed" 683 | inside the spline. 684 | 685 | =back 686 | 687 | Adding "good" control points is subjective; this particular 688 | algorithm reveals its author's tastes. 689 | In the future, you may be able to alter the taste slightly 690 | via parameters to the algorithm. For The Hubristic: please 691 | build a better one! 692 | 693 | And for The Impatient: note that addControlPoints() returns a 694 | polyline, so you can pile up the call like this, 695 | if you'd like: 696 | 697 | $image->polyline($polyline->addControlPoints()->toSpline(),$mauve); 698 | 699 | =back 700 | 701 | =head1 New GD::Image Methods 702 | 703 | =over 5 704 | 705 | =item C 706 | 707 | C<$image-Epolyline(polyline,color)> I 708 | 709 | $image->polyline($polyline,$black) 710 | 711 | This draws a polyline with the specified color. 712 | Both real color indexes and the special 713 | colors gdBrushed, gdStyled and gdStyledBrushed can be specified. 714 | 715 | Neither the polyline() method or the polygon() method are very 716 | picky: you can call either method with either a GD::Polygon or a GD::Polyline. 717 | The I determines if the shape is "closed" or "open" as drawn, I 718 | the object type. 719 | 720 | =item C 721 | 722 | C<$image-Epolydraw(polything,color)> I 723 | 724 | $image->polydraw($poly,$black) 725 | 726 | This method draws the polything as expected (polygons are closed, 727 | polylines are open) by simply checking the object type and calling 728 | either $image->polygon() or $image->polyline(). 729 | 730 | =back 731 | 732 | =head1 Examples 733 | 734 | Please see file "polyline-examples.pl" that is included with the distribution. 735 | 736 | =head1 See Also 737 | 738 | For more info on Bezier splines, see http://www.webreference.com/dlab/9902/bezier.html. 739 | 740 | =head1 Future Features 741 | 742 | On the drawing board are additional features such as: 743 | 744 | - polygon winding algorithms (to determine if a point is "inside" or "outside" the polygon) 745 | 746 | - new polygon from bounding box 747 | 748 | - find bounding polygon (tightest fitting simple convex polygon for a given set of vertices) 749 | 750 | - addPts() method to add many points at once 751 | 752 | - clone() method for polygon 753 | 754 | - functions to interwork GD with SVG 755 | 756 | Please provide input on other possible features you'd like to see. 757 | 758 | =head1 Author 759 | 760 | This module has been written by Daniel J. Harasty. 761 | Please send questions, comments, complaints, and kudos to him 762 | at harasty@cpan.org. 763 | 764 | Thanks to Lincoln Stein for input and patience with me and this, 765 | my first CPAN contribution. 766 | 767 | =head1 Copyright Information 768 | 769 | The Polyline.pm module is copyright 2002, Daniel J. Harasty. It is 770 | distributed under the same terms as Perl itself. See the "Artistic 771 | License" in the Perl source code distribution for licensing terms. 772 | 773 | The latest version of Polyline.pm is available at 774 | your favorite CPAN repository and/or 775 | along with GD.pm by Lincoln D. Stein at http://stein.cshl.org/WWW/software/GD. 776 | 777 | =cut 778 | 779 | # future: 780 | # addPts 781 | # boundingPolygon 782 | # addControlPoints('method' => 'fitToSegments', 'numSegs' => 10) 783 | # toSpline('csr' => 1/4); 784 | 785 | # GD::Color 786 | # colorMap('x11' | 'svg' | ) 787 | # colorByName($image, 'orange'); 788 | # setImage($image); 789 | # cbn('orange'); 790 | # 791 | # 792 | # 793 | --------------------------------------------------------------------------------