- reading a tga image with an idstring of 128 or more bytes would result
in an allocation error, if the platform char type was signed
- tests now check that tga tags are set
+- calling the read() method for a format not included in the Imager build,
+ for example, JPEG with no libjpeg installed, would crash with an
+ undefined function error (modified by DynaLoaders dependence on
+ AutoLoader.
+ http://rt.cpan.org/NoAuth/Bug.html?id=9618
+- some test scripts have been modified to use Test::More, which is now
+ included under the t directory. Eventually all will be modified to use
+ Test::More and the duplicates in t/testtools.pl will be removed
=================================================================
undef($self->{IMG});
}
- # FIXME: Find the format here if not specified
- # yes the code isn't here yet - next week maybe?
- # Next week? Are you high or something? That comment
- # has been there for half a year dude.
- # Look, i just work here, ok?
-
my ($IO, $fh) = $self->_get_reader_io(\%input) or return;
unless ($input{'type'}) {
- $input{'type'} = i_test_format_probe($IO, -1);
- }
+ $input{'type'} = i_test_format_probe($IO, -1);
+ }
unless ($input{'type'}) {
$self->_set_error('type parameter missing and not possible to guess from extension');
return undef;
}
+ unless ($formats{$input{'type'}}) {
+ $self->_set_error("format '$input{'type'}' not supported");
+ return;
+ }
+
# Setup data source
if ( $input{'type'} eq 'jpeg' ) {
($self->{IMG},$self->{IPTCRAW}) = i_readjpeg_wiol( $IO );
--- /dev/null
+BITMAPFILEHEADER [3.0]
+
+Bitmap File Information
+The BITMAPFILEHEADER data structure contains information about the type,
+size, and layout of a device-independent bitmap (DIB) file.
+
+typedef struct tagBITMAPFILEHEADER {
+ WORD bfType;
+ DWORD bfSize;
+ WORD bfReserved1;
+ WORD bfReserved2;
+ DWORD bfOffBits;
+} BITMAPFILEHEADER;
+
+The BITMAPFILEHEADER data structure contains the following fields:
+
+Field Description
+bfType Specifies the type of file. It must be BM.
+bfSize Specifies the size in DWORDs of the file.
+bfReserved1 Is reserved and must be set to zero.
+bfReserved2 Is reserved and must be set to zero.
+bfOffBits Specifies in bytes the offset from the BITMAPFILEHEADER
+ of the actual bitmap in the file.
+
+Comments A BITMAPINFO or BITMAPCOREINFO data structure immediately
+follows the BITMAPFILEHEADER structure in the DIB file.
+
+
+BITMAPINFO [3.0]
+
+Device-Indpendent Bitmap Information
+The BITMAPINFO structure fully defines the dimensions and color
+information for a Windows 3.0 device-independent bitmap.
+
+typedef struct tagBITMAPINFO {
+ BITMAPINFOHEADER bmiHeader;
+ RGBQUAD bmiColors[1];
+} BITMAPINFO;
+
+The BITMAPINFO structure contains the following fields:
+
+Field Description
+bmiHeader Specifies a BITMAPINFOHEADER data structure that
+ contains information about the dimensions and color format of a device-independent bitmap.
+bmiColors Specifies an array of RGBQUAD data structures that
+ define the colors in the bitmap.
+
+Comments: A Windows 3.0 device-independent bitmap consists of two
+distinct parts: a BITMAPINFO data structure that describes the dimensions
+and colors of the bitmap, and an array of bytes that define the pixels of
+the bitmap. The bits in the array are packed together, but each scan line
+must be zero-padded to end on a LONG boundary. Segment boundaries can
+appear anywhere in the bitmap, however. The origin of the bitmap is the
+lower-left corner.
+
+The biBitCount field of the BITMAPINFOHEADER structure determines the
+number of bits which define each pixel and the maximum number of colors
+in the bitmap. This field may be set to any of the following values:
+
+Value Meaning
+1 The bitmap is monochrome, and the bmiColors field must
+ contain two entries. Each bit in the bitmap array represents a
+ pixel. If the bit is clear, the pixel is displayed with the
+ color of the first entry in the bmiColors table; if the bit is
+ set, the pixel has the color of the second entry in the table.
+4 The bitmap has a maximum of 16 colors, and the bmiColors
+ field contains up to 16 entries. Each pixel in the bitmap is
+ represented by a four-bit index into the color table.
+ For example, if the first byte in the bitmap is 0x1F, then the
+ byte represents two pixels. The first pixel contains the color
+ in the second table entry, and the second pixel contains the
+ color in the 16th table entry.
+8 The bitmap has a maximum of 256 colors, and the bmiColors
+ field contains up to 256 entries. In this case, each byte in the
+ array represents a single pixel.
+24 The bitmap has a maximum of 2^24 colors. The bmiColors
+ field is NULL, and each three bytes in the bitmap array
+ represents the relative intensities of red, green, and blue,
+ respectively, of a pixel.
+
+The biClrUsed field of the BITMAPINFOHEADER structure specifies the number
+of color indexes in the color table actually used by the bitmap. If the
+biClrUsed field is set to 0, the bitmap uses the maximum number of colors
+corresponding to the value of the biBitCount field.
+
+The colors in the bmiColors table should appear in order of importance.
+
+Alternatively, for functions that use device-independent bitmaps, the
+bmiColors field can be an array of 16-bit unsigned integers that specify
+an index into the currently realized logical palette instead of explicit
+RGB values. In this case, an application using the bitmap must call
+device-independent bitmap functions with the wUsage parameter set to
+DIB_PAL_COLORS.
+
+Note: The bmiColors field should not contain palette indices if the
+bitmap is to be stored in a file or transferred to another application.
+Unless the application uses the bitmap exclusively and under its complete
+control, the bitmap color table should contain explicit RGB values.
+
+BITMAPINFOHEADER [3.0]
+
+Device-Independent Bitmap Format Information
+The BITMAPINFOHEADER structure contains information about the dimensions
+and color format of a Windows 3.0 device-independent bitmap.
+
+typedef struct tagBITMAPINFOHEADER{
+ DWORD biSize;
+ DWORD biWidth;
+ DWORD biHeight;
+ WORD biPlanes;
+ WORD biBitCount
+ DWORD biCompression;
+ DWORD biSizeImage;
+ DWORD biXPelsPerMeter;
+ DWORD biYPelsPerMeter;
+ DWORD biClrUsed;
+ DWORD biClrImportant;
+} BITMAPINFOHEADER;
+
+The BITMAPINFOHEADER structure has the following fields:
+
+Field Description
+biSize Specifies the number of bytes required by the
+ BITMAPINFOHEADER structure.
+biWidth Specifies the width of the bitmap in pixels.
+biHeight Specifies the height of the bitmap in pixels.
+biPlanes Specifies the number of planes for the target device and
+ must be set to 1.
+biBitCount Specifies the number of bits per pixel. This value must
+ be 1, 4, 8, or 24.
+biCompression Specifies the type of compression for a compressed
+ bitmap. It can be one of the following values:.
+ Value Meaning
+ BI_RGB Specifies that the bitmap is not
+ compressed.
+ BI_RLE8 Specifies a run-length encoded format
+ for bitmaps with 8 bits per pixel. The
+ compression format is a two-byte
+ format consisting of a count byte
+ followed by a byte containing a color
+ index. See the following 'Comments'
+ section for more information.
+ BI_RLE4 Specifies a run-length encoded format
+ for bitmaps with 4 bits per pixel. The
+ compression format is a two-byte
+ format consisting of a count byte
+ followed by two word-length color
+ indexes. See the following 'Comments'
+ section for more information.
+biSizeImage Specifies the size in bytes of the image.
+biXPelsPerMeter Specifies the horizontal resolution in pixels per meter of the target device for the bitmap. An application can use this value to select a bitmap from a resource group that best matches the characteristics of the current device. biYPelsPerMeter Specifies the vertical resolution in pixels per meter of the target device for the bitmap.
+biClrUsed Specifies the number of color indexes in the color table
+ actually used by the bitmap. If this value is 0, the
+ bitmap uses the maximum number of colors corresponding
+ to the value of the biBitCount field. See the
+ description of the BITMAPINFO data structure earlier in
+ this chapter for more information on the maximum sizes
+ of the color table. If biClrUsed is nonzero, then the
+ biClrUsed field specifies the actual number of colors
+ which the graphics engine or device driver will access
+ if the biBitCount field is less than 24. If the
+ biBitCount field is set to 24, the biClrUsed field
+ specifies the size of the reference color table used to
+ optimize performance of Windows color palettes.
+ If the bitmap is a 'packed' bitmap (that is, a bitmap in
+ which the bitmap array immediately follows the
+ BITMAPINFO header and which is referenced by a single
+ pointer), the biClrUsed field must be set to 0 or to the
+ actual size of the color table.
+biClrImportant Specifies the number of color indexes that are considered
+ important for displaying the bitmap. If this value is 0,
+ then all colors are important.
+
+Comments: The BITMAPINFO data structure combines the
+BITMAPINFOHEADER structure and a color table to provide a complete
+definition of the dimensions and colors of a Windows 3.0
+device-independent bitmap. See the description of the BITMAPINFO data
+structure for more information about specifying a Windows 3.0
+device-independent bitmap.
+
+An application should use the information stored in the biSize field to
+locate the color table in a BITMAPINFO data structure with a method such
+as the following:
+
+pColor = ((LPSTR) pBitmapInfo + (WORD) (pBitmapInfo -> biSize))
+
+Bitmap Compression Formats Windows supports formats for compressing
+bitmaps that define their colors with 8 bits per pixel and with 4 bits
+per pixel. Compression reduces the disk and memory storage required for
+the bitmap. The following paragraphs describe these formats.
+
+When the biCompression field is set to BI_RLE8, the bitmap is compressed
+using a run-length encoding format for an 8-bit bitmap. This format may
+be compressed in either of two modes:
+
+7 Encoded
+7 Absolute
+
+
+Both modes can occur anywhere throughout a single bitmap.
+
+Encoded mode consists of two bytes: the first byte specifies the number
+of consecutive pixels to be drawn using the color index contained in the
+second byte. In addition, the first byte of the pair can be set to zero
+to indicate an escape that denotes an end of line, end of bitmap, or a
+delta. The interpretation of the escape depends on the value of the
+second byte of the pair. The following list shows the meaning of the
+second byte:
+
+Second Byte
+Of Escape
+ Meaning
+0 End of line.
+1 End of bitmap.
+2 Delta. The two bytes following the escape contain
+ unsigned values indicating the horizontal and vertical
+ offset of the next pixel from the current position.
+
+Absolute mode is signalled by the first byte set to zero and the second
+byte set to a value between 03H and FFH. In absolute mode, the second
+byte represents the number of bytes which follow, each of which contains
+the color index of a single pixel. When the second byte is set to 2 or
+less, the escape has the same meaning as in encoded mode.
+In absolute mode, each run must be aligned on a word boundary.
+
+The following example shows the hexadecimal values of an 8-bit compressed
+bitmap:
+
+03 04 05 06 00 03 45 56 67 00 02 78 00 02 05 01
+02 78 00 00 09 1E 00 01
+
+This bitmap would expand as follows (two-digit values represent a color
+index for a single pixel):
+
+04 04 04
+06 06 06 06 06
+45 56 67
+78 78
+move current position 5 right and 1 down
+78 78
+end of line
+1E 1E 1E 1E 1E 1E 1E 1E 1E
+end of RLE bitmap
+
+When the biCompression field is set to BI_RLE4, the bitmap is compressed
+using a run-length encoding format for a 4-bit bitmap, which also uses
+encoded and absolute modes. In encoded mode, the first byte of the pair
+contains the number of pixels to be drawn using the color indexes in the
+second byte. The second byte contains two color indexes, one in its
+high-order nibble (that is, its low-order four bits) and one in its
+low-order nibble. The first of the pixels is drawn using the color
+specified by the high-order nibble, the second is drawn using the color
+in the low-order nibble, the third is drawn with the color in the
+high-order nibble, and so on, until all the pixels specified by the
+first byte have been drawn.
+
+In absolute mode, the first byte contains zero, the second byte contains
+the number of color indexes that follow, and subsequent bytes contain
+color indexes in their high- and low-order nibbles, one color index for
+each pixel. In absolute mode, each run must be aligned on a word boundary.
+The end-of-line, end-of-bitmap, and delta escapes also apply to BI_RLE4.
+
+The following example shows the hexadecimal values of a 4-bit compressed
+bitmap:
+
+03 04 05 06 00 06 45 56 67 00 04 78 00 02 05 01
+04 78 00 00 09 1E 00 01
+
+This bitmap would expand as follows (single-digit values represent a
+color index for a single pixel):
+
+0 4 0
+0 6 0 6 0
+4 5 5 6 6 7
+7 8 7 8
+move current position 5 right and 1 down
+7 8 7 8
+end of line
+1 E 1 E 1 E 1 E 1
+end of RLE bitmap
+
+RGBQUAD [3.0]
+
+RGB Color Structure
+The RGBQUAD data structure describes a color consisting of relative
+intensities of red, green, and blue. The bmiColors field of the
+BITMAPINFO data structure consists of an array of RGBQUAD data structures.
+
+typedef struct tagRGBQUAD {
+ BYTE rgbBlue;
+ BYTE rgbGreen;
+ BYTE rgbRed;
+ BYTE rgbReserved;
+} RGBQUAD;
+
+The RGBQUAD structure contains the following fields:
+
+Field Description
+rgbBlue Specifies the intensity of blue in the color.
+rgbGreen Specifies the intensity of green in the color.
+rgbRed Specifies the intensity of red in the color.
+rgbReserved Is not used and must be set to zero.
+
+
+
+#define BI_RGB 0L
+#define BI_RLE8 1L
+#define BI_RLE4 2L
+
+BITMAPCOREINFO [3.0]
+
+Device-Indpendent Bitmap Information
+The BITMAPCOREINFO structure fully defines the dimensions and color
+information for a device-independent bitmap that is compatible with
+Microsoft OS/2 Presentation Manager versions 1.1 and 1.2 bitmaps.
+
+typedef struct _BITMAPCOREINFO {
+ BITMAPCOREHEADER bmciHeader;
+ RGBTRIPLE bmciColors[];
+} BITMAPCOREINFO;
+
+The BITMAPCOREINFO structure contains the following fields:
+
+Field Description
+bmciHeader Specifies a BITMAPCOREHEADER data structure that
+ contains information about the dimensions and color
+ format of a device-independent bitmap.
+bmciColors Specifies an array of RGBTRIPLE data structures that
+ define the colors in the bitmap.
+
+Comments An OS/2 Presentation Manager device-independent bitmap
+consists of two distinct parts: a BITMAPCOREINFO data structure that
+describes the dimensions and colors of the bitmap, and an array of bytes
+which define the pixels of the bitmap. The bits in the array are packed
+together, but each scan line must be zero-padded to end on a LONG
+boundary. Segment boundaries can appear anywhere in the bitmap, however.
+The origin of the bitmap is the lower-left corner.
+
+The bcBitCount field of the BITMAPCOREHEADER structure determines the
+number of bits which define each pixel and the maximum number of colors
+in the bitmap. This field may be set to any of the following values:
+
+Value Meaning
+1 The bitmap is monochrome, and the bmciColors field must
+ contain two entries. Each bit in the bitmap array represents a
+ pixel. If the bit is clear, the pixel is displayed with the
+ color of the first entry in the bmciColors table; if the bit is
+ set, the pixel has the color of the second entry in the table.
+4 The bitmap has a maximum of 16 colors, and the bmciColors
+ field contains 16 entries. Each pixel in the bitmap is represented
+ by a four-bit index into the color table.
+ For example, if the first byte in the bitmap is 0x1F, then the
+ byte represents two pixels. The first pixel contains the color in
+ the second table entry, and the second pixel contains the color
+ in the 16th table entry.
+8 The bitmap has a maximum of 256 colors, and the bmciColors
+ field contains 256 entries. In this case, each byte in the array
+ represents a single pixel.
+24 The bitmap has a maximum of 2^24 colors. The bmciColors
+ field is NULL, and each three bytes in the bitmap array
+ represents the relative intensities of red, green, and blue,
+ respectively, of a pixel.
+
+The colors in the bmciColors table should appear in order of importance.
+
+Alternatively, for functions that use device-independent bitmaps, the
+bmciColors field can be an array of 16-bit unsigned integers that
+specify an index into the currently realized logical palette instead of
+explicit RGB values. In this case, an application using the bitmap must
+call device-independent bitmap functions with the wUsage parameter
+set to DIB_PAL_COLORS.
+
+Note The bmciColors field should not contain palette indexes if the
+bitmap is to be stored in a file or transferred to another application.
+Unless the application uses the bitmap exclusively and under its
+complete control, the bitmap color table should contain explicit
+RGB values.
+
+
+
+BITMAPCOREHEADER [3.0]
+
+Device-Independent Bitmap Format Information
+The BITMAPCOREHEADER structure contains information about the dimensions
+and color format of a device-independent bitmap that is compatible with
+Microsoft OS/2 Presentation Manager versions 1.1 and 1.2 bitmaps.
+
+typedef struct tagBITMAPCOREHEADER {
+ DWORD bcSize;
+ WORD bcWidth;
+ WORD bcHeight;
+ WORD bcPlanes;
+ WORD bcBitCount;
+} BITMAPCOREHEADER;
+
+The BITMAPCOREHEADER structure has the following fields:
+
+Field Description
+bcSize Specifies the number of bytes required by the BITMAPCOREHEADER
+ structure.
+bcWidth Specifies the width of the bitmap in pixels.
+bcHeight Specifies the height of the bitmap in pixels.
+bcPlanes Specifies the number of planes for the target device and
+ must be set to 1.
+bcBitCount Specifies the number of bits per pixel. This value must
+ be 1, 4, 8, or 24.
+
+Comments The BITMAPCOREINFO data structure combines the
+BITMAPCOREHEADER structure and a color table to provide a complete
+definition of the dimensions and colors of a device-independent bitmap.
+See the description of the BITMAPCOREINFO data structure for more
+information about specifying a device-independent bitmap.
+
+An application should use the information stored in the bcSize field to
+locate the color table in a BITMAPCOREINFO data structure with a method
+such as the following:
+
+pColor = ((LPSTR) pBitmapCoreInfo + (WORD) (pBitmapCoreInfo -> bcSize))
+
+
+
+RGBTRIPLE [3.0]
+
+RGB Color Structure
+The RGBTRIPLE data structure describes a color consisting of relative
+intensities of red, green, and blue. The bmciColors field of the
+BITMAPCOREINFO data structure consists of an array of RGBTRIPLE data
+structures.
+
+typedef struct tagRGBTRIPLE {
+ BYTE rgbtBlue;
+ BYTE rgbtGreen;
+ BYTE rgbtRed;
+} RGBTRIPLE;
+
+The RGBTRIPLE structure contains the following fields:
+
+Field Description
+rgbtBlue Specifies the intensity of blue in the color.
+rgbtGreen Specifies the intensity of green in the color.
+rgbtRed Specifies the intensity of red in the color.
+
+
+
+-----------------------------------------------------------------------
+
+ Non official comments
+
+How to distinguish between BITMAPINFO and BITMAPCOREINFO when reading
+in a BMP file.
+
+After reading the BITMAPFILEHEADER read the next DWORD from the file.
+If it is 12 you are reading a BITMAPCOREHEADER, if it is 40 you are
+reading a BITMAPINFOHEADER.
\ No newline at end of file
--- /dev/null
+# man pages on Debian Linux
+pgm - man pgm
+pbm - man pbm
+ppm - man ppm
+pam - man pam (portable arbitrary map)
+png - http://www.w3.org/TR/PNG/
+gif - zless /usr/share/doc/libungif4g/gif89.txt.gz
+bmp - fileformatdocs/bmp.txt (and MSDN)
--- /dev/null
+package Test::Builder;
+
+use 5.004;
+
+# $^C was only introduced in 5.005-ish. We do this to prevent
+# use of uninitialized value warnings in older perls.
+$^C ||= 0;
+
+use strict;
+use vars qw($VERSION $CLASS);
+$VERSION = '0.17';
+$CLASS = __PACKAGE__;
+
+my $IsVMS = $^O eq 'VMS';
+
+# Make Test::Builder thread-safe for ithreads.
+BEGIN {
+ use Config;
+ if( $] >= 5.008 && $Config{useithreads} ) {
+ require threads;
+ require threads::shared;
+ threads::shared->import;
+ }
+ else {
+ *share = sub { 0 };
+ *lock = sub { 0 };
+ }
+}
+
+use vars qw($Level);
+my($Test_Died) = 0;
+my($Have_Plan) = 0;
+my $Original_Pid = $$;
+my $Curr_Test = 0; share($Curr_Test);
+my @Test_Results = (); share(@Test_Results);
+my @Test_Details = (); share(@Test_Details);
+
+
+=head1 NAME
+
+Test::Builder - Backend for building test libraries
+
+=head1 SYNOPSIS
+
+ package My::Test::Module;
+ use Test::Builder;
+ require Exporter;
+ @ISA = qw(Exporter);
+ @EXPORT = qw(ok);
+
+ my $Test = Test::Builder->new;
+ $Test->output('my_logfile');
+
+ sub import {
+ my($self) = shift;
+ my $pack = caller;
+
+ $Test->exported_to($pack);
+ $Test->plan(@_);
+
+ $self->export_to_level(1, $self, 'ok');
+ }
+
+ sub ok {
+ my($test, $name) = @_;
+
+ $Test->ok($test, $name);
+ }
+
+
+=head1 DESCRIPTION
+
+Test::Simple and Test::More have proven to be popular testing modules,
+but they're not always flexible enough. Test::Builder provides the a
+building block upon which to write your own test libraries I<which can
+work together>.
+
+=head2 Construction
+
+=over 4
+
+=item B<new>
+
+ my $Test = Test::Builder->new;
+
+Returns a Test::Builder object representing the current state of the
+test.
+
+Since you only run one test per program, there is B<one and only one>
+Test::Builder object. No matter how many times you call new(), you're
+getting the same object. (This is called a singleton).
+
+=cut
+
+my $Test;
+sub new {
+ my($class) = shift;
+ $Test ||= bless ['Move along, nothing to see here'], $class;
+ return $Test;
+}
+
+=back
+
+=head2 Setting up tests
+
+These methods are for setting up tests and declaring how many there
+are. You usually only want to call one of these methods.
+
+=over 4
+
+=item B<exported_to>
+
+ my $pack = $Test->exported_to;
+ $Test->exported_to($pack);
+
+Tells Test::Builder what package you exported your functions to.
+This is important for getting TODO tests right.
+
+=cut
+
+my $Exported_To;
+sub exported_to {
+ my($self, $pack) = @_;
+
+ if( defined $pack ) {
+ $Exported_To = $pack;
+ }
+ return $Exported_To;
+}
+
+=item B<plan>
+
+ $Test->plan('no_plan');
+ $Test->plan( skip_all => $reason );
+ $Test->plan( tests => $num_tests );
+
+A convenient way to set up your tests. Call this and Test::Builder
+will print the appropriate headers and take the appropriate actions.
+
+If you call plan(), don't call any of the other methods below.
+
+=cut
+
+sub plan {
+ my($self, $cmd, $arg) = @_;
+
+ return unless $cmd;
+
+ if( $Have_Plan ) {
+ die sprintf "You tried to plan twice! Second plan at %s line %d\n",
+ ($self->caller)[1,2];
+ }
+
+ if( $cmd eq 'no_plan' ) {
+ $self->no_plan;
+ }
+ elsif( $cmd eq 'skip_all' ) {
+ return $self->skip_all($arg);
+ }
+ elsif( $cmd eq 'tests' ) {
+ if( $arg ) {
+ return $self->expected_tests($arg);
+ }
+ elsif( !defined $arg ) {
+ die "Got an undefined number of tests. Looks like you tried to ".
+ "say how many tests you plan to run but made a mistake.\n";
+ }
+ elsif( !$arg ) {
+ die "You said to run 0 tests! You've got to run something.\n";
+ }
+ }
+ else {
+ require Carp;
+ my @args = grep { defined } ($cmd, $arg);
+ Carp::croak("plan() doesn't understand @args");
+ }
+
+ return 1;
+}
+
+=item B<expected_tests>
+
+ my $max = $Test->expected_tests;
+ $Test->expected_tests($max);
+
+Gets/sets the # of tests we expect this test to run and prints out
+the appropriate headers.
+
+=cut
+
+my $Expected_Tests = 0;
+sub expected_tests {
+ my($self, $max) = @_;
+
+ if( defined $max ) {
+ $Expected_Tests = $max;
+ $Have_Plan = 1;
+
+ $self->_print("1..$max\n") unless $self->no_header;
+ }
+ return $Expected_Tests;
+}
+
+
+=item B<no_plan>
+
+ $Test->no_plan;
+
+Declares that this test will run an indeterminate # of tests.
+
+=cut
+
+my($No_Plan) = 0;
+sub no_plan {
+ $No_Plan = 1;
+ $Have_Plan = 1;
+}
+
+=item B<has_plan>
+
+ $plan = $Test->has_plan
+
+Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
+
+=cut
+
+sub has_plan {
+ return($Expected_Tests) if $Expected_Tests;
+ return('no_plan') if $No_Plan;
+ return(undef);
+};
+
+
+=item B<skip_all>
+
+ $Test->skip_all;
+ $Test->skip_all($reason);
+
+Skips all the tests, using the given $reason. Exits immediately with 0.
+
+=cut
+
+my $Skip_All = 0;
+sub skip_all {
+ my($self, $reason) = @_;
+
+ my $out = "1..0";
+ $out .= " # Skip $reason" if $reason;
+ $out .= "\n";
+
+ $Skip_All = 1;
+
+ $self->_print($out) unless $self->no_header;
+ exit(0);
+}
+
+=back
+
+=head2 Running tests
+
+These actually run the tests, analogous to the functions in
+Test::More.
+
+$name is always optional.
+
+=over 4
+
+=item B<ok>
+
+ $Test->ok($test, $name);
+
+Your basic test. Pass if $test is true, fail if $test is false. Just
+like Test::Simple's ok().
+
+=cut
+
+sub ok {
+ my($self, $test, $name) = @_;
+
+ # $test might contain an object which we don't want to accidentally
+ # store, so we turn it into a boolean.
+ $test = $test ? 1 : 0;
+
+ unless( $Have_Plan ) {
+ require Carp;
+ Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
+ }
+
+ lock $Curr_Test;
+ $Curr_Test++;
+
+ $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
+ You named your test '$name'. You shouldn't use numbers for your test names.
+ Very confusing.
+ERR
+
+ my($pack, $file, $line) = $self->caller;
+
+ my $todo = $self->todo($pack);
+
+ my $out;
+ my $result = {};
+ share($result);
+
+ unless( $test ) {
+ $out .= "not ";
+ @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
+ }
+ else {
+ @$result{ 'ok', 'actual_ok' } = ( 1, $test );
+ }
+
+ $out .= "ok";
+ $out .= " $Curr_Test" if $self->use_numbers;
+
+ if( defined $name ) {
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $out .= " - $name";
+ $result->{name} = $name;
+ }
+ else {
+ $result->{name} = '';
+ }
+
+ if( $todo ) {
+ my $what_todo = $todo;
+ $out .= " # TODO $what_todo";
+ $result->{reason} = $what_todo;
+ $result->{type} = 'todo';
+ }
+ else {
+ $result->{reason} = '';
+ $result->{type} = '';
+ }
+
+ $Test_Results[$Curr_Test-1] = $result;
+ $out .= "\n";
+
+ $self->_print($out);
+
+ unless( $test ) {
+ my $msg = $todo ? "Failed (TODO)" : "Failed";
+ $self->diag(" $msg test ($file at line $line)\n");
+ }
+
+ return $test ? 1 : 0;
+}
+
+=item B<is_eq>
+
+ $Test->is_eq($got, $expected, $name);
+
+Like Test::More's is(). Checks if $got eq $expected. This is the
+string version.
+
+=item B<is_num>
+
+ $Test->is_num($got, $expected, $name);
+
+Like Test::More's is(). Checks if $got == $expected. This is the
+numeric version.
+
+=cut
+
+sub is_eq {
+ my($self, $got, $expect, $name) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok($test, $name);
+ $self->_is_diag($got, 'eq', $expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, 'eq', $expect, $name);
+}
+
+sub is_num {
+ my($self, $got, $expect, $name) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok($test, $name);
+ $self->_is_diag($got, '==', $expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, '==', $expect, $name);
+}
+
+sub _is_diag {
+ my($self, $got, $type, $expect) = @_;
+
+ foreach my $val (\$got, \$expect) {
+ if( defined $$val ) {
+ if( $type eq 'eq' ) {
+ # quote and force string context
+ $$val = "'$$val'"
+ }
+ else {
+ # force numeric context
+ $$val = $$val+0;
+ }
+ }
+ else {
+ $$val = 'undef';
+ }
+ }
+
+ return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
+ got: %s
+ expected: %s
+DIAGNOSTIC
+
+}
+
+=item B<isnt_eq>
+
+ $Test->isnt_eq($got, $dont_expect, $name);
+
+Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
+the string version.
+
+=item B<isnt_num>
+
+ $Test->is_num($got, $dont_expect, $name);
+
+Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
+the numeric version.
+
+=cut
+
+sub isnt_eq {
+ my($self, $got, $dont_expect, $name) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok($test, $name);
+ $self->_cmp_diag('ne', $got, $dont_expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, 'ne', $dont_expect, $name);
+}
+
+sub isnt_num {
+ my($self, $got, $dont_expect, $name) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok($test, $name);
+ $self->_cmp_diag('!=', $got, $dont_expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, '!=', $dont_expect, $name);
+}
+
+
+=item B<like>
+
+ $Test->like($this, qr/$regex/, $name);
+ $Test->like($this, '/$regex/', $name);
+
+Like Test::More's like(). Checks if $this matches the given $regex.
+
+You'll want to avoid qr// if you want your tests to work before 5.005.
+
+=item B<unlike>
+
+ $Test->unlike($this, qr/$regex/, $name);
+ $Test->unlike($this, '/$regex/', $name);
+
+Like Test::More's unlike(). Checks if $this B<does not match> the
+given $regex.
+
+=cut
+
+sub like {
+ my($self, $this, $regex, $name) = @_;
+
+ local $Level = $Level + 1;
+ $self->_regex_ok($this, $regex, '=~', $name);
+}
+
+sub unlike {
+ my($self, $this, $regex, $name) = @_;
+
+ local $Level = $Level + 1;
+ $self->_regex_ok($this, $regex, '!~', $name);
+}
+
+=item B<maybe_regex>
+
+ $Test->maybe_regex(qr/$regex/);
+ $Test->maybe_regex('/$regex/');
+
+Convenience method for building testing functions that take regular
+expressions as arguments, but need to work before perl 5.005.
+
+Takes a quoted regular expression produced by qr//, or a string
+representing a regular expression.
+
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or undef if it's argument is not recognised.
+
+For example, a version of like(), sans the useful diagnostic messages,
+could be written as:
+
+ sub laconic_like {
+ my ($self, $this, $regex, $name) = @_;
+ my $usable_regex = $self->maybe_regex($regex);
+ die "expecting regex, found '$regex'\n"
+ unless $usable_regex;
+ $self->ok($this =~ m/$usable_regex/, $name);
+ }
+
+=cut
+
+
+sub maybe_regex {
+ my ($self, $regex) = @_;
+ my $usable_regex = undef;
+ if( ref $regex eq 'Regexp' ) {
+ $usable_regex = $regex;
+ }
+ # Check if it looks like '/foo/'
+ elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
+ $usable_regex = length $opts ? "(?$opts)$re" : $re;
+ };
+ return($usable_regex)
+};
+
+sub _regex_ok {
+ my($self, $this, $regex, $cmp, $name) = @_;
+
+ local $Level = $Level + 1;
+
+ my $ok = 0;
+ my $usable_regex = $self->maybe_regex($regex);
+ unless (defined $usable_regex) {
+ $ok = $self->ok( 0, $name );
+ $self->diag(" '$regex' doesn't look much like a regex to me.");
+ return $ok;
+ }
+
+ {
+ local $^W = 0;
+ my $test = $this =~ /$usable_regex/ ? 1 : 0;
+ $test = !$test if $cmp eq '!~';
+ $ok = $self->ok( $test, $name );
+ }
+
+ unless( $ok ) {
+ $this = defined $this ? "'$this'" : 'undef';
+ my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+ $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
+ %s
+ %13s '%s'
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+=item B<cmp_ok>
+
+ $Test->cmp_ok($this, $type, $that, $name);
+
+Works just like Test::More's cmp_ok().
+
+ $Test->cmp_ok($big_num, '!=', $other_big_num);
+
+=cut
+
+sub cmp_ok {
+ my($self, $got, $type, $expect, $name) = @_;
+
+ my $test;
+ {
+ local $^W = 0;
+ local($@,$!); # don't interfere with $@
+ # eval() sometimes resets $!
+ $test = eval "\$got $type \$expect";
+ }
+ local $Level = $Level + 1;
+ my $ok = $self->ok($test, $name);
+
+ unless( $ok ) {
+ if( $type =~ /^(eq|==)$/ ) {
+ $self->_is_diag($got, $type, $expect);
+ }
+ else {
+ $self->_cmp_diag($got, $type, $expect);
+ }
+ }
+ return $ok;
+}
+
+sub _cmp_diag {
+ my($self, $got, $type, $expect) = @_;
+
+ $got = defined $got ? "'$got'" : 'undef';
+ $expect = defined $expect ? "'$expect'" : 'undef';
+ return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
+ %s
+ %s
+ %s
+DIAGNOSTIC
+}
+
+=item B<BAILOUT>
+
+ $Test->BAILOUT($reason);
+
+Indicates to the Test::Harness that things are going so badly all
+testing should terminate. This includes running any additional test
+scripts.
+
+It will exit with 255.
+
+=cut
+
+sub BAILOUT {
+ my($self, $reason) = @_;
+
+ $self->_print("Bail out! $reason");
+ exit 255;
+}
+
+=item B<skip>
+
+ $Test->skip;
+ $Test->skip($why);
+
+Skips the current test, reporting $why.
+
+=cut
+
+sub skip {
+ my($self, $why) = @_;
+ $why ||= '';
+
+ unless( $Have_Plan ) {
+ require Carp;
+ Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
+ }
+
+ lock($Curr_Test);
+ $Curr_Test++;
+
+ my %result;
+ share(%result);
+ %result = (
+ 'ok' => 1,
+ actual_ok => 1,
+ name => '',
+ type => 'skip',
+ reason => $why,
+ );
+ $Test_Results[$Curr_Test-1] = \%result;
+
+ my $out = "ok";
+ $out .= " $Curr_Test" if $self->use_numbers;
+ $out .= " # skip $why\n";
+
+ $Test->_print($out);
+
+ return 1;
+}
+
+
+=item B<todo_skip>
+
+ $Test->todo_skip;
+ $Test->todo_skip($why);
+
+Like skip(), only it will declare the test as failing and TODO. Similar
+to
+
+ print "not ok $tnum # TODO $why\n";
+
+=cut
+
+sub todo_skip {
+ my($self, $why) = @_;
+ $why ||= '';
+
+ unless( $Have_Plan ) {
+ require Carp;
+ Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
+ }
+
+ lock($Curr_Test);
+ $Curr_Test++;
+
+ my %result;
+ share(%result);
+ %result = (
+ 'ok' => 1,
+ actual_ok => 0,
+ name => '',
+ type => 'todo_skip',
+ reason => $why,
+ );
+
+ $Test_Results[$Curr_Test-1] = \%result;
+
+ my $out = "not ok";
+ $out .= " $Curr_Test" if $self->use_numbers;
+ $out .= " # TODO & SKIP $why\n";
+
+ $Test->_print($out);
+
+ return 1;
+}
+
+
+=begin _unimplemented
+
+=item B<skip_rest>
+
+ $Test->skip_rest;
+ $Test->skip_rest($reason);
+
+Like skip(), only it skips all the rest of the tests you plan to run
+and terminates the test.
+
+If you're running under no_plan, it skips once and terminates the
+test.
+
+=end _unimplemented
+
+=back
+
+
+=head2 Test style
+
+=over 4
+
+=item B<level>
+
+ $Test->level($how_high);
+
+How far up the call stack should $Test look when reporting where the
+test failed.
+
+Defaults to 1.
+
+Setting $Test::Builder::Level overrides. This is typically useful
+localized:
+
+ {
+ local $Test::Builder::Level = 2;
+ $Test->ok($test);
+ }
+
+=cut
+
+sub level {
+ my($self, $level) = @_;
+
+ if( defined $level ) {
+ $Level = $level;
+ }
+ return $Level;
+}
+
+$CLASS->level(1);
+
+
+=item B<use_numbers>
+
+ $Test->use_numbers($on_or_off);
+
+Whether or not the test should output numbers. That is, this if true:
+
+ ok 1
+ ok 2
+ ok 3
+
+or this if false
+
+ ok
+ ok
+ ok
+
+Most useful when you can't depend on the test output order, such as
+when threads or forking is involved.
+
+Test::Harness will accept either, but avoid mixing the two styles.
+
+Defaults to on.
+
+=cut
+
+my $Use_Nums = 1;
+sub use_numbers {
+ my($self, $use_nums) = @_;
+
+ if( defined $use_nums ) {
+ $Use_Nums = $use_nums;
+ }
+ return $Use_Nums;
+}
+
+=item B<no_header>
+
+ $Test->no_header($no_header);
+
+If set to true, no "1..N" header will be printed.
+
+=item B<no_ending>
+
+ $Test->no_ending($no_ending);
+
+Normally, Test::Builder does some extra diagnostics when the test
+ends. It also changes the exit code as described in Test::Simple.
+
+If this is true, none of that will be done.
+
+=cut
+
+my($No_Header, $No_Ending) = (0,0);
+sub no_header {
+ my($self, $no_header) = @_;
+
+ if( defined $no_header ) {
+ $No_Header = $no_header;
+ }
+ return $No_Header;
+}
+
+sub no_ending {
+ my($self, $no_ending) = @_;
+
+ if( defined $no_ending ) {
+ $No_Ending = $no_ending;
+ }
+ return $No_Ending;
+}
+
+
+=back
+
+=head2 Output
+
+Controlling where the test output goes.
+
+It's ok for your test to change where STDOUT and STDERR point to,
+Test::Builder's default output settings will not be affected.
+
+=over 4
+
+=item B<diag>
+
+ $Test->diag(@msgs);
+
+Prints out the given $message. Normally, it uses the failure_output()
+handle, but if this is for a TODO test, the todo_output() handle is
+used.
+
+Output will be indented and marked with a # so as not to interfere
+with test output. A newline will be put on the end if there isn't one
+already.
+
+We encourage using this rather than calling print directly.
+
+Returns false. Why? Because diag() is often used in conjunction with
+a failing test (C<ok() || diag()>) it "passes through" the failure.
+
+ return ok(...) || diag(...);
+
+=for blame transfer
+Mark Fowler <mark@twoshortplanks.com>
+
+=cut
+
+sub diag {
+ my($self, @msgs) = @_;
+ return unless @msgs;
+
+ # Prevent printing headers when compiling (i.e. -c)
+ return if $^C;
+
+ # Escape each line with a #.
+ foreach (@msgs) {
+ $_ = 'undef' unless defined;
+ s/^/# /gms;
+ }
+
+ push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
+
+ local $Level = $Level + 1;
+ my $fh = $self->todo ? $self->todo_output : $self->failure_output;
+ local($\, $", $,) = (undef, ' ', '');
+ print $fh @msgs;
+
+ return 0;
+}
+
+=begin _private
+
+=item B<_print>
+
+ $Test->_print(@msgs);
+
+Prints to the output() filehandle.
+
+=end _private
+
+=cut
+
+sub _print {
+ my($self, @msgs) = @_;
+
+ # Prevent printing headers when only compiling. Mostly for when
+ # tests are deparsed with B::Deparse
+ return if $^C;
+
+ local($\, $", $,) = (undef, ' ', '');
+ my $fh = $self->output;
+
+ # Escape each line after the first with a # so we don't
+ # confuse Test::Harness.
+ foreach (@msgs) {
+ s/\n(.)/\n# $1/sg;
+ }
+
+ push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
+
+ print $fh @msgs;
+}
+
+
+=item B<output>
+
+ $Test->output($fh);
+ $Test->output($file);
+
+Where normal "ok/not ok" test output should go.
+
+Defaults to STDOUT.
+
+=item B<failure_output>
+
+ $Test->failure_output($fh);
+ $Test->failure_output($file);
+
+Where diagnostic output on test failures and diag() should go.
+
+Defaults to STDERR.
+
+=item B<todo_output>
+
+ $Test->todo_output($fh);
+ $Test->todo_output($file);
+
+Where diagnostics about todo test failures and diag() should go.
+
+Defaults to STDOUT.
+
+=cut
+
+my($Out_FH, $Fail_FH, $Todo_FH);
+sub output {
+ my($self, $fh) = @_;
+
+ if( defined $fh ) {
+ $Out_FH = _new_fh($fh);
+ }
+ return $Out_FH;
+}
+
+sub failure_output {
+ my($self, $fh) = @_;
+
+ if( defined $fh ) {
+ $Fail_FH = _new_fh($fh);
+ }
+ return $Fail_FH;
+}
+
+sub todo_output {
+ my($self, $fh) = @_;
+
+ if( defined $fh ) {
+ $Todo_FH = _new_fh($fh);
+ }
+ return $Todo_FH;
+}
+
+sub _new_fh {
+ my($file_or_fh) = shift;
+
+ my $fh;
+ unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
+ $fh = do { local *FH };
+ open $fh, ">$file_or_fh" or
+ die "Can't open test output log $file_or_fh: $!";
+ }
+ else {
+ $fh = $file_or_fh;
+ }
+
+ return $fh;
+}
+
+unless( $^C ) {
+ # We dup STDOUT and STDERR so people can change them in their
+ # test suites while still getting normal test output.
+ open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!";
+ open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!";
+
+ # Set everything to unbuffered else plain prints to STDOUT will
+ # come out in the wrong order from our own prints.
+ _autoflush(\*TESTOUT);
+ _autoflush(\*STDOUT);
+ _autoflush(\*TESTERR);
+ _autoflush(\*STDERR);
+
+ $CLASS->output(\*TESTOUT);
+ $CLASS->failure_output(\*TESTERR);
+ $CLASS->todo_output(\*TESTOUT);
+}
+
+sub _autoflush {
+ my($fh) = shift;
+ my $old_fh = select $fh;
+ $| = 1;
+ select $old_fh;
+}
+
+
+=back
+
+
+=head2 Test Status and Info
+
+=over 4
+
+=item B<current_test>
+
+ my $curr_test = $Test->current_test;
+ $Test->current_test($num);
+
+Gets/sets the current test # we're on.
+
+You usually shouldn't have to set this.
+
+=cut
+
+sub current_test {
+ my($self, $num) = @_;
+
+ lock($Curr_Test);
+ if( defined $num ) {
+ unless( $Have_Plan ) {
+ require Carp;
+ Carp::croak("Can't change the current test number without a plan!");
+ }
+
+ $Curr_Test = $num;
+ if( $num > @Test_Results ) {
+ my $start = @Test_Results ? $#Test_Results + 1 : 0;
+ for ($start..$num-1) {
+ my %result;
+ share(%result);
+ %result = ( ok => 1,
+ actual_ok => undef,
+ reason => 'incrementing test number',
+ type => 'unknown',
+ name => undef
+ );
+ $Test_Results[$_] = \%result;
+ }
+ }
+ }
+ return $Curr_Test;
+}
+
+
+=item B<summary>
+
+ my @tests = $Test->summary;
+
+A simple summary of the tests so far. True for pass, false for fail.
+This is a logical pass/fail, so todos are passes.
+
+Of course, test #1 is $tests[0], etc...
+
+=cut
+
+sub summary {
+ my($self) = shift;
+
+ return map { $_->{'ok'} } @Test_Results;
+}
+
+=item B<details>
+
+ my @tests = $Test->details;
+
+Like summary(), but with a lot more detail.
+
+ $tests[$test_num - 1] =
+ { 'ok' => is the test considered a pass?
+ actual_ok => did it literally say 'ok'?
+ name => name of the test (if any)
+ type => type of test (if any, see below).
+ reason => reason for the above (if any)
+ };
+
+'ok' is true if Test::Harness will consider the test to be a pass.
+
+'actual_ok' is a reflection of whether or not the test literally
+printed 'ok' or 'not ok'. This is for examining the result of 'todo'
+tests.
+
+'name' is the name of the test.
+
+'type' indicates if it was a special test. Normal tests have a type
+of ''. Type can be one of the following:
+
+ skip see skip()
+ todo see todo()
+ todo_skip see todo_skip()
+ unknown see below
+
+Sometimes the Test::Builder test counter is incremented without it
+printing any test output, for example, when current_test() is changed.
+In these cases, Test::Builder doesn't know the result of the test, so
+it's type is 'unkown'. These details for these tests are filled in.
+They are considered ok, but the name and actual_ok is left undef.
+
+For example "not ok 23 - hole count # TODO insufficient donuts" would
+result in this structure:
+
+ $tests[22] = # 23 - 1, since arrays start from 0.
+ { ok => 1, # logically, the test passed since it's todo
+ actual_ok => 0, # in absolute terms, it failed
+ name => 'hole count',
+ type => 'todo',
+ reason => 'insufficient donuts'
+ };
+
+=cut
+
+sub details {
+ return @Test_Results;
+}
+
+=item B<todo>
+
+ my $todo_reason = $Test->todo;
+ my $todo_reason = $Test->todo($pack);
+
+todo() looks for a $TODO variable in your tests. If set, all tests
+will be considered 'todo' (see Test::More and Test::Harness for
+details). Returns the reason (ie. the value of $TODO) if running as
+todo tests, false otherwise.
+
+todo() is pretty part about finding the right package to look for
+$TODO in. It uses the exported_to() package to find it. If that's
+not set, it's pretty good at guessing the right package to look at.
+
+Sometimes there is some confusion about where todo() should be looking
+for the $TODO variable. If you want to be sure, tell it explicitly
+what $pack to use.
+
+=cut
+
+sub todo {
+ my($self, $pack) = @_;
+
+ $pack = $pack || $self->exported_to || $self->caller(1);
+
+ no strict 'refs';
+ return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
+ : 0;
+}
+
+=item B<caller>
+
+ my $package = $Test->caller;
+ my($pack, $file, $line) = $Test->caller;
+ my($pack, $file, $line) = $Test->caller($height);
+
+Like the normal caller(), except it reports according to your level().
+
+=cut
+
+sub caller {
+ my($self, $height) = @_;
+ $height ||= 0;
+
+ my @caller = CORE::caller($self->level + $height + 1);
+ return wantarray ? @caller : $caller[0];
+}
+
+=back
+
+=cut
+
+=begin _private
+
+=over 4
+
+=item B<_sanity_check>
+
+ _sanity_check();
+
+Runs a bunch of end of test sanity checks to make sure reality came
+through ok. If anything is wrong it will die with a fairly friendly
+error message.
+
+=cut
+
+#'#
+sub _sanity_check {
+ _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!');
+ _whoa(!$Have_Plan and $Curr_Test,
+ 'Somehow your tests ran without a plan!');
+ _whoa($Curr_Test != @Test_Results,
+ 'Somehow you got a different number of results than tests ran!');
+}
+
+=item B<_whoa>
+
+ _whoa($check, $description);
+
+A sanity check, similar to assert(). If the $check is true, something
+has gone horribly wrong. It will die with the given $description and
+a note to contact the author.
+
+=cut
+
+sub _whoa {
+ my($check, $desc) = @_;
+ if( $check ) {
+ die <<WHOA;
+WHOA! $desc
+This should never happen! Please contact the author immediately!
+WHOA
+ }
+}
+
+=item B<_my_exit>
+
+ _my_exit($exit_num);
+
+Perl seems to have some trouble with exiting inside an END block. 5.005_03
+and 5.6.1 both seem to do odd things. Instead, this function edits $?
+directly. It should ONLY be called from inside an END block. It
+doesn't actually exit, that's your job.
+
+=cut
+
+sub _my_exit {
+ $? = $_[0];
+
+ return 1;
+}
+
+
+=back
+
+=end _private
+
+=cut
+
+$SIG{__DIE__} = sub {
+ # We don't want to muck with death in an eval, but $^S isn't
+ # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
+ # with it. Instead, we use caller. This also means it runs under
+ # 5.004!
+ my $in_eval = 0;
+ for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
+ $in_eval = 1 if $sub =~ /^\(eval\)/;
+ }
+ $Test_Died = 1 unless $in_eval;
+};
+
+sub _ending {
+ my $self = shift;
+
+ _sanity_check();
+
+ # Don't bother with an ending if this is a forked copy. Only the parent
+ # should do the ending.
+ do{ _my_exit($?) && return } if $Original_Pid != $$;
+
+ # Bailout if plan() was never called. This is so
+ # "require Test::Simple" doesn't puke.
+ do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
+
+ # Figure out if we passed or failed and print helpful messages.
+ if( @Test_Results ) {
+ # The plan? We have no plan.
+ if( $No_Plan ) {
+ $self->_print("1..$Curr_Test\n") unless $self->no_header;
+ $Expected_Tests = $Curr_Test;
+ }
+
+ # 5.8.0 threads bug. Shared arrays will not be auto-extended
+ # by a slice. Worse, we have to fill in every entry else
+ # we'll get an "Invalid value for shared scalar" error
+ for my $idx ($#Test_Results..$Expected_Tests-1) {
+ my %empty_result = ();
+ share(%empty_result);
+ $Test_Results[$idx] = \%empty_result
+ unless defined $Test_Results[$idx];
+ }
+
+ my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];
+ $num_failed += abs($Expected_Tests - @Test_Results);
+
+ if( $Curr_Test < $Expected_Tests ) {
+ $self->diag(<<"FAIL");
+Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
+FAIL
+ }
+ elsif( $Curr_Test > $Expected_Tests ) {
+ my $num_extra = $Curr_Test - $Expected_Tests;
+ $self->diag(<<"FAIL");
+Looks like you planned $Expected_Tests tests but ran $num_extra extra.
+FAIL
+ }
+ elsif ( $num_failed ) {
+ $self->diag(<<"FAIL");
+Looks like you failed $num_failed tests of $Expected_Tests.
+FAIL
+ }
+
+ if( $Test_Died ) {
+ $self->diag(<<"FAIL");
+Looks like your test died just after $Curr_Test.
+FAIL
+
+ _my_exit( 255 ) && return;
+ }
+
+ _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return;
+ }
+ elsif ( $Skip_All ) {
+ _my_exit( 0 ) && return;
+ }
+ elsif ( $Test_Died ) {
+ $self->diag(<<'FAIL');
+Looks like your test died before it could output anything.
+FAIL
+ }
+ else {
+ $self->diag("No tests run!\n");
+ _my_exit( 255 ) && return;
+ }
+}
+
+END {
+ $Test->_ending if defined $Test and !$Test->no_ending;
+}
+
+=head1 THREADS
+
+In perl 5.8.0 and later, Test::Builder is thread-safe. The test
+number is shared amongst all threads. This means if one thread sets
+the test number using current_test() they will all be effected.
+
+=head1 EXAMPLES
+
+CPAN can provide the best examples. Test::Simple, Test::More,
+Test::Exception and Test::Differences all use Test::Builder.
+
+=head1 SEE ALSO
+
+Test::Simple, Test::More, Test::Harness
+
+=head1 AUTHORS
+
+Original code by chromatic, maintained by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2002 by chromatic E<lt>chromatic@wgz.orgE<gt>,
+ Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
--- /dev/null
+package Test::More;
+
+use 5.004;
+
+use strict;
+use Test::Builder;
+
+
+# Can't use Carp because it might cause use_ok() to accidentally succeed
+# even though the module being used forgot to use Carp. Yes, this
+# actually happened.
+sub _carp {
+ my($file, $line) = (caller(1))[1,2];
+ warn @_, " at $file line $line\n";
+}
+
+
+
+require Exporter;
+use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
+$VERSION = '0.47';
+@ISA = qw(Exporter);
+@EXPORT = qw(ok use_ok require_ok
+ is isnt like unlike is_deeply
+ cmp_ok
+ skip todo todo_skip
+ pass fail
+ eq_array eq_hash eq_set
+ $TODO
+ plan
+ can_ok isa_ok
+ diag
+ );
+
+my $Test = Test::Builder->new;
+
+
+# 5.004's Exporter doesn't have export_to_level.
+sub _export_to_level
+{
+ my $pkg = shift;
+ my $level = shift;
+ (undef) = shift; # redundant arg
+ my $callpkg = caller($level);
+ $pkg->export($callpkg, @_);
+}
+
+
+=head1 NAME
+
+Test::More - yet another framework for writing test scripts
+
+=head1 SYNOPSIS
+
+ use Test::More tests => $Num_Tests;
+ # or
+ use Test::More qw(no_plan);
+ # or
+ use Test::More skip_all => $reason;
+
+ BEGIN { use_ok( 'Some::Module' ); }
+ require_ok( 'Some::Module' );
+
+ # Various ways to say "ok"
+ ok($this eq $that, $test_name);
+
+ is ($this, $that, $test_name);
+ isnt($this, $that, $test_name);
+
+ # Rather than print STDERR "# here's what went wrong\n"
+ diag("here's what went wrong");
+
+ like ($this, qr/that/, $test_name);
+ unlike($this, qr/that/, $test_name);
+
+ cmp_ok($this, '==', $that, $test_name);
+
+ is_deeply($complex_structure1, $complex_structure2, $test_name);
+
+ SKIP: {
+ skip $why, $how_many unless $have_some_feature;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ TODO: {
+ local $TODO = $why;
+
+ ok( foo(), $test_name );
+ is( foo(42), 23, $test_name );
+ };
+
+ can_ok($module, @methods);
+ isa_ok($object, $class);
+
+ pass($test_name);
+ fail($test_name);
+
+ # Utility comparison functions.
+ eq_array(\@this, \@that);
+ eq_hash(\%this, \%that);
+ eq_set(\@this, \@that);
+
+ # UNIMPLEMENTED!!!
+ my @status = Test::More::status;
+
+ # UNIMPLEMENTED!!!
+ BAIL_OUT($why);
+
+
+=head1 DESCRIPTION
+
+B<STOP!> If you're just getting started writing tests, have a look at
+Test::Simple first. This is a drop in replacement for Test::Simple
+which you can switch to once you get the hang of basic testing.
+
+The purpose of this module is to provide a wide range of testing
+utilities. Various ways to say "ok" with better diagnostics,
+facilities to skip tests, test future features and compare complicated
+data structures. While you can do almost anything with a simple
+C<ok()> function, it doesn't provide good diagnostic output.
+
+
+=head2 I love it when a plan comes together
+
+Before anything else, you need a testing plan. This basically declares
+how many tests your script is going to run to protect against premature
+failure.
+
+The preferred way to do this is to declare a plan when you C<use Test::More>.
+
+ use Test::More tests => $Num_Tests;
+
+There are rare cases when you will not know beforehand how many tests
+your script is going to run. In this case, you can declare that you
+have no plan. (Try to avoid using this as it weakens your test.)
+
+ use Test::More qw(no_plan);
+
+In some cases, you'll want to completely skip an entire testing script.
+
+ use Test::More skip_all => $skip_reason;
+
+Your script will declare a skip with the reason why you skipped and
+exit immediately with a zero (success). See L<Test::Harness> for
+details.
+
+If you want to control what functions Test::More will export, you
+have to use the 'import' option. For example, to import everything
+but 'fail', you'd do:
+
+ use Test::More tests => 23, import => ['!fail'];
+
+Alternatively, you can use the plan() function. Useful for when you
+have to calculate the number of tests.
+
+ use Test::More;
+ plan tests => keys %Stuff * 3;
+
+or for deciding between running the tests at all:
+
+ use Test::More;
+ if( $^O eq 'MacOS' ) {
+ plan skip_all => 'Test irrelevant on MacOS';
+ }
+ else {
+ plan tests => 42;
+ }
+
+=cut
+
+sub plan {
+ my(@plan) = @_;
+
+ my $caller = caller;
+
+ $Test->exported_to($caller);
+
+ my @imports = ();
+ foreach my $idx (0..$#plan) {
+ if( $plan[$idx] eq 'import' ) {
+ my($tag, $imports) = splice @plan, $idx, 2;
+ @imports = @$imports;
+ last;
+ }
+ }
+
+ $Test->plan(@plan);
+
+ __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
+}
+
+sub import {
+ my($class) = shift;
+ goto &plan;
+}
+
+
+=head2 Test names
+
+By convention, each test is assigned a number in order. This is
+largely done automatically for you. However, it's often very useful to
+assign a name to each test. Which would you rather see:
+
+ ok 4
+ not ok 5
+ ok 6
+
+or
+
+ ok 4 - basic multi-variable
+ not ok 5 - simple exponential
+ ok 6 - force == mass * acceleration
+
+The later gives you some idea of what failed. It also makes it easier
+to find the test in your script, simply search for "simple
+exponential".
+
+All test functions take a name argument. It's optional, but highly
+suggested that you use it.
+
+
+=head2 I'm ok, you're not ok.
+
+The basic purpose of this module is to print out either "ok #" or "not
+ok #" depending on if a given test succeeded or failed. Everything
+else is just gravy.
+
+All of the following print "ok" or "not ok" depending on if the test
+succeeded or failed. They all also return true or false,
+respectively.
+
+=over 4
+
+=item B<ok>
+
+ ok($this eq $that, $test_name);
+
+This simply evaluates any expression (C<$this eq $that> is just a
+simple example) and uses that to determine if the test succeeded or
+failed. A true expression passes, a false one fails. Very simple.
+
+For example:
+
+ ok( $exp{9} == 81, 'simple exponential' );
+ ok( Film->can('db_Main'), 'set_db()' );
+ ok( $p->tests == 4, 'saw tests' );
+ ok( !grep !defined $_, @items, 'items populated' );
+
+(Mnemonic: "This is ok.")
+
+$test_name is a very short description of the test that will be printed
+out. It makes it very easy to find a test in your script when it fails
+and gives others an idea of your intentions. $test_name is optional,
+but we B<very> strongly encourage its use.
+
+Should an ok() fail, it will produce some diagnostics:
+
+ not ok 18 - sufficient mucus
+ # Failed test 18 (foo.t at line 42)
+
+This is actually Test::Simple's ok() routine.
+
+=cut
+
+sub ok ($;$) {
+ my($test, $name) = @_;
+ $Test->ok($test, $name);
+}
+
+=item B<is>
+
+=item B<isnt>
+
+ is ( $this, $that, $test_name );
+ isnt( $this, $that, $test_name );
+
+Similar to ok(), is() and isnt() compare their two arguments
+with C<eq> and C<ne> respectively and use the result of that to
+determine if the test succeeded or failed. So these:
+
+ # Is the ultimate answer 42?
+ is( ultimate_answer(), 42, "Meaning of Life" );
+
+ # $foo isn't empty
+ isnt( $foo, '', "Got some foo" );
+
+are similar to these:
+
+ ok( ultimate_answer() eq 42, "Meaning of Life" );
+ ok( $foo ne '', "Got some foo" );
+
+(Mnemonic: "This is that." "This isn't that.")
+
+So why use these? They produce better diagnostics on failure. ok()
+cannot know what you are testing for (beyond the name), but is() and
+isnt() know what the test was and why it failed. For example this
+test:
+
+ my $foo = 'waffle'; my $bar = 'yarblokos';
+ is( $foo, $bar, 'Is foo the same as bar?' );
+
+Will produce something like this:
+
+ not ok 17 - Is foo the same as bar?
+ # Failed test (foo.t at line 139)
+ # got: 'waffle'
+ # expected: 'yarblokos'
+
+So you can figure out what went wrong without rerunning the test.
+
+You are encouraged to use is() and isnt() over ok() where possible,
+however do not be tempted to use them to find out if something is
+true or false!
+
+ # XXX BAD! $pope->isa('Catholic') eq 1
+ is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' );
+
+This does not check if C<$pope->isa('Catholic')> is true, it checks if
+it returns 1. Very different. Similar caveats exist for false and 0.
+In these cases, use ok().
+
+ ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' );
+
+For those grammatical pedants out there, there's an C<isn't()>
+function which is an alias of isnt().
+
+=cut
+
+sub is ($$;$) {
+ $Test->is_eq(@_);
+}
+
+sub isnt ($$;$) {
+ $Test->isnt_eq(@_);
+}
+
+*isn't = \&isnt;
+
+
+=item B<like>
+
+ like( $this, qr/that/, $test_name );
+
+Similar to ok(), like() matches $this against the regex C<qr/that/>.
+
+So this:
+
+ like($this, qr/that/, 'this is like that');
+
+is similar to:
+
+ ok( $this =~ /that/, 'this is like that');
+
+(Mnemonic "This is like that".)
+
+The second argument is a regular expression. It may be given as a
+regex reference (i.e. C<qr//>) or (for better compatibility with older
+perls) as a string that looks like a regex (alternative delimiters are
+currently not supported):
+
+ like( $this, '/that/', 'this is like that' );
+
+Regex options may be placed on the end (C<'/that/i'>).
+
+Its advantages over ok() are similar to that of is() and isnt(). Better
+diagnostics on failure.
+
+=cut
+
+sub like ($$;$) {
+ $Test->like(@_);
+}
+
+
+=item B<unlike>
+
+ unlike( $this, qr/that/, $test_name );
+
+Works exactly as like(), only it checks if $this B<does not> match the
+given pattern.
+
+=cut
+
+sub unlike {
+ $Test->unlike(@_);
+}
+
+
+=item B<cmp_ok>
+
+ cmp_ok( $this, $op, $that, $test_name );
+
+Halfway between ok() and is() lies cmp_ok(). This allows you to
+compare two arguments using any binary perl operator.
+
+ # ok( $this eq $that );
+ cmp_ok( $this, 'eq', $that, 'this eq that' );
+
+ # ok( $this == $that );
+ cmp_ok( $this, '==', $that, 'this == that' );
+
+ # ok( $this && $that );
+ cmp_ok( $this, '&&', $that, 'this || that' );
+ ...etc...
+
+Its advantage over ok() is when the test fails you'll know what $this
+and $that were:
+
+ not ok 1
+ # Failed test (foo.t at line 12)
+ # '23'
+ # &&
+ # undef
+
+It's also useful in those cases where you are comparing numbers and
+is()'s use of C<eq> will interfere:
+
+ cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
+
+=cut
+
+sub cmp_ok($$$;$) {
+ $Test->cmp_ok(@_);
+}
+
+
+=item B<can_ok>
+
+ can_ok($module, @methods);
+ can_ok($object, @methods);
+
+Checks to make sure the $module or $object can do these @methods
+(works with functions, too).
+
+ can_ok('Foo', qw(this that whatever));
+
+is almost exactly like saying:
+
+ ok( Foo->can('this') &&
+ Foo->can('that') &&
+ Foo->can('whatever')
+ );
+
+only without all the typing and with a better interface. Handy for
+quickly testing an interface.
+
+No matter how many @methods you check, a single can_ok() call counts
+as one test. If you desire otherwise, use:
+
+ foreach my $meth (@methods) {
+ can_ok('Foo', $meth);
+ }
+
+=cut
+
+sub can_ok ($@) {
+ my($proto, @methods) = @_;
+ my $class = ref $proto || $proto;
+
+ unless( @methods ) {
+ my $ok = $Test->ok( 0, "$class->can(...)" );
+ $Test->diag(' can_ok() called with no methods');
+ return $ok;
+ }
+
+ my @nok = ();
+ foreach my $method (@methods) {
+ local($!, $@); # don't interfere with caller's $@
+ # eval sometimes resets $!
+ eval { $proto->can($method) } || push @nok, $method;
+ }
+
+ my $name;
+ $name = @methods == 1 ? "$class->can('$methods[0]')"
+ : "$class->can(...)";
+
+ my $ok = $Test->ok( !@nok, $name );
+
+ $Test->diag(map " $class->can('$_') failed\n", @nok);
+
+ return $ok;
+}
+
+=item B<isa_ok>
+
+ isa_ok($object, $class, $object_name);
+ isa_ok($ref, $type, $ref_name);
+
+Checks to see if the given $object->isa($class). Also checks to make
+sure the object was defined in the first place. Handy for this sort
+of thing:
+
+ my $obj = Some::Module->new;
+ isa_ok( $obj, 'Some::Module' );
+
+where you'd otherwise have to write
+
+ my $obj = Some::Module->new;
+ ok( defined $obj && $obj->isa('Some::Module') );
+
+to safeguard against your test script blowing up.
+
+It works on references, too:
+
+ isa_ok( $array_ref, 'ARRAY' );
+
+The diagnostics of this test normally just refer to 'the object'. If
+you'd like them to be more specific, you can supply an $object_name
+(for example 'Test customer').
+
+=cut
+
+sub isa_ok ($$;$) {
+ my($object, $class, $obj_name) = @_;
+
+ my $diag;
+ $obj_name = 'The object' unless defined $obj_name;
+ my $name = "$obj_name isa $class";
+ if( !defined $object ) {
+ $diag = "$obj_name isn't defined";
+ }
+ elsif( !ref $object ) {
+ $diag = "$obj_name isn't a reference";
+ }
+ else {
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ local($@, $!); # eval sometimes resets $!
+ my $rslt = eval { $object->isa($class) };
+ if( $@ ) {
+ if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
+ if( !UNIVERSAL::isa($object, $class) ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ } else {
+ die <<WHOA;
+WHOA! I tried to call ->isa on your object and got some weird error.
+This should never happen. Please contact the author immediately.
+Here's the error.
+$@
+WHOA
+ }
+ }
+ elsif( !$rslt ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' it's a '$ref'";
+ }
+ }
+
+
+
+ my $ok;
+ if( $diag ) {
+ $ok = $Test->ok( 0, $name );
+ $Test->diag(" $diag\n");
+ }
+ else {
+ $ok = $Test->ok( 1, $name );
+ }
+
+ return $ok;
+}
+
+
+=item B<pass>
+
+=item B<fail>
+
+ pass($test_name);
+ fail($test_name);
+
+Sometimes you just want to say that the tests have passed. Usually
+the case is you've got some complicated condition that is difficult to
+wedge into an ok(). In this case, you can simply use pass() (to
+declare the test ok) or fail (for not ok). They are synonyms for
+ok(1) and ok(0).
+
+Use these very, very, very sparingly.
+
+=cut
+
+sub pass (;$) {
+ $Test->ok(1, @_);
+}
+
+sub fail (;$) {
+ $Test->ok(0, @_);
+}
+
+=back
+
+=head2 Diagnostics
+
+If you pick the right test function, you'll usually get a good idea of
+what went wrong when it failed. But sometimes it doesn't work out
+that way. So here we have ways for you to write your own diagnostic
+messages which are safer than just C<print STDERR>.
+
+=over 4
+
+=item B<diag>
+
+ diag(@diagnostic_message);
+
+Prints a diagnostic message which is guaranteed not to interfere with
+test output. Handy for this sort of thing:
+
+ ok( grep(/foo/, @users), "There's a foo user" ) or
+ diag("Since there's no foo, check that /etc/bar is set up right");
+
+which would produce:
+
+ not ok 42 - There's a foo user
+ # Failed test (foo.t at line 52)
+ # Since there's no foo, check that /etc/bar is set up right.
+
+You might remember C<ok() or diag()> with the mnemonic C<open() or
+die()>.
+
+B<NOTE> The exact formatting of the diagnostic output is still
+changing, but it is guaranteed that whatever you throw at it it won't
+interfere with the test.
+
+=cut
+
+sub diag {
+ $Test->diag(@_);
+}
+
+
+=back
+
+=head2 Module tests
+
+You usually want to test if the module you're testing loads ok, rather
+than just vomiting if its load fails. For such purposes we have
+C<use_ok> and C<require_ok>.
+
+=over 4
+
+=item B<use_ok>
+
+ BEGIN { use_ok($module); }
+ BEGIN { use_ok($module, @imports); }
+
+These simply use the given $module and test to make sure the load
+happened ok. It's recommended that you run use_ok() inside a BEGIN
+block so its functions are exported at compile-time and prototypes are
+properly honored.
+
+If @imports are given, they are passed through to the use. So this:
+
+ BEGIN { use_ok('Some::Module', qw(foo bar)) }
+
+is like doing this:
+
+ use Some::Module qw(foo bar);
+
+don't try to do this:
+
+ BEGIN {
+ use_ok('Some::Module');
+
+ ...some code that depends on the use...
+ ...happening at compile time...
+ }
+
+instead, you want:
+
+ BEGIN { use_ok('Some::Module') }
+ BEGIN { ...some code that depends on the use... }
+
+
+=cut
+
+sub use_ok ($;@) {
+ my($module, @imports) = @_;
+ @imports = () unless @imports;
+
+ my $pack = caller;
+
+ local($@,$!); # eval sometimes interferes with $!
+ eval <<USE;
+package $pack;
+require $module;
+'$module'->import(\@imports);
+USE
+
+ my $ok = $Test->ok( !$@, "use $module;" );
+
+ unless( $ok ) {
+ chomp $@;
+ $Test->diag(<<DIAGNOSTIC);
+ Tried to use '$module'.
+ Error: $@
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+=item B<require_ok>
+
+ require_ok($module);
+
+Like use_ok(), except it requires the $module.
+
+=cut
+
+sub require_ok ($) {
+ my($module) = shift;
+
+ my $pack = caller;
+
+ local($!, $@); # eval sometimes interferes with $!
+ eval <<REQUIRE;
+package $pack;
+require $module;
+REQUIRE
+
+ my $ok = $Test->ok( !$@, "require $module;" );
+
+ unless( $ok ) {
+ chomp $@;
+ $Test->diag(<<DIAGNOSTIC);
+ Tried to require '$module'.
+ Error: $@
+DIAGNOSTIC
+
+ }
+
+ return $ok;
+}
+
+=back
+
+=head2 Conditional tests
+
+Sometimes running a test under certain conditions will cause the
+test script to die. A certain function or method isn't implemented
+(such as fork() on MacOS), some resource isn't available (like a
+net connection) or a module isn't available. In these cases it's
+necessary to skip tests, or declare that they are supposed to fail
+but will work in the future (a todo test).
+
+For more details on the mechanics of skip and todo tests see
+L<Test::Harness>.
+
+The way Test::More handles this is with a named block. Basically, a
+block of tests which can be skipped over or made todo. It's best if I
+just show you...
+
+=over 4
+
+=item B<SKIP: BLOCK>
+
+ SKIP: {
+ skip $why, $how_many if $condition;
+
+ ...normal testing code goes here...
+ }
+
+This declares a block of tests that might be skipped, $how_many tests
+there are, $why and under what $condition to skip them. An example is
+the easiest way to illustrate:
+
+ SKIP: {
+ eval { require HTML::Lint };
+
+ skip "HTML::Lint not installed", 2 if $@;
+
+ my $lint = new HTML::Lint;
+ isa_ok( $lint, "HTML::Lint" );
+
+ $lint->parse( $html );
+ is( $lint->errors, 0, "No errors found in HTML" );
+ }
+
+If the user does not have HTML::Lint installed, the whole block of
+code I<won't be run at all>. Test::More will output special ok's
+which Test::Harness interprets as skipped, but passing, tests.
+It's important that $how_many accurately reflects the number of tests
+in the SKIP block so the # of tests run will match up with your plan.
+
+It's perfectly safe to nest SKIP blocks. Each SKIP block must have
+the label C<SKIP>, or Test::More can't work its magic.
+
+You don't skip tests which are failing because there's a bug in your
+program, or for which you don't yet have code written. For that you
+use TODO. Read on.
+
+=cut
+
+#'#
+sub skip {
+ my($why, $how_many) = @_;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "skip() needs to know \$how_many tests are in the block"
+ unless $Test::Builder::No_Plan;
+ $how_many = 1;
+ }
+
+ for( 1..$how_many ) {
+ $Test->skip($why);
+ }
+
+ local $^W = 0;
+ last SKIP;
+}
+
+
+=item B<TODO: BLOCK>
+
+ TODO: {
+ local $TODO = $why if $condition;
+
+ ...normal testing code goes here...
+ }
+
+Declares a block of tests you expect to fail and $why. Perhaps it's
+because you haven't fixed a bug or haven't finished a new feature:
+
+ TODO: {
+ local $TODO = "URI::Geller not finished";
+
+ my $card = "Eight of clubs";
+ is( URI::Geller->your_card, $card, 'Is THIS your card?' );
+
+ my $spoon;
+ URI::Geller->bend_spoon;
+ is( $spoon, 'bent', "Spoon bending, that's original" );
+ }
+
+With a todo block, the tests inside are expected to fail. Test::More
+will run the tests normally, but print out special flags indicating
+they are "todo". Test::Harness will interpret failures as being ok.
+Should anything succeed, it will report it as an unexpected success.
+You then know the thing you had todo is done and can remove the
+TODO flag.
+
+The nice part about todo tests, as opposed to simply commenting out a
+block of tests, is it's like having a programmatic todo list. You know
+how much work is left to be done, you're aware of what bugs there are,
+and you'll know immediately when they're fixed.
+
+Once a todo test starts succeeding, simply move it outside the block.
+When the block is empty, delete it.
+
+
+=item B<todo_skip>
+
+ TODO: {
+ todo_skip $why, $how_many if $condition;
+
+ ...normal testing code...
+ }
+
+With todo tests, it's best to have the tests actually run. That way
+you'll know when they start passing. Sometimes this isn't possible.
+Often a failing test will cause the whole program to die or hang, even
+inside an C<eval BLOCK> with and using C<alarm>. In these extreme
+cases you have no choice but to skip over the broken tests entirely.
+
+The syntax and behavior is similar to a C<SKIP: BLOCK> except the
+tests will be marked as failing but todo. Test::Harness will
+interpret them as passing.
+
+=cut
+
+sub todo_skip {
+ my($why, $how_many) = @_;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "todo_skip() needs to know \$how_many tests are in the block"
+ unless $Test::Builder::No_Plan;
+ $how_many = 1;
+ }
+
+ for( 1..$how_many ) {
+ $Test->todo_skip($why);
+ }
+
+ local $^W = 0;
+ last TODO;
+}
+
+=item When do I use SKIP vs. TODO?
+
+B<If it's something the user might not be able to do>, use SKIP.
+This includes optional modules that aren't installed, running under
+an OS that doesn't have some feature (like fork() or symlinks), or maybe
+you need an Internet connection and one isn't available.
+
+B<If it's something the programmer hasn't done yet>, use TODO. This
+is for any code you haven't written yet, or bugs you have yet to fix,
+but want to put tests in your testing script (always a good idea).
+
+
+=back
+
+=head2 Comparison functions
+
+Not everything is a simple eq check or regex. There are times you
+need to see if two arrays are equivalent, for instance. For these
+instances, Test::More provides a handful of useful functions.
+
+B<NOTE> These are NOT well-tested on circular references. Nor am I
+quite sure what will happen with filehandles.
+
+=over 4
+
+=item B<is_deeply>
+
+ is_deeply( $this, $that, $test_name );
+
+Similar to is(), except that if $this and $that are hash or array
+references, it does a deep comparison walking each data structure to
+see if they are equivalent. If the two structures are different, it
+will display the place where they start differing.
+
+Barrie Slaymaker's Test::Differences module provides more in-depth
+functionality along these lines, and it plays well with Test::More.
+
+B<NOTE> Display of scalar refs is not quite 100%
+
+=cut
+
+use vars qw(@Data_Stack);
+my $DNE = bless [], 'Does::Not::Exist';
+sub is_deeply {
+ my($this, $that, $name) = @_;
+
+ my $ok;
+ if( !ref $this || !ref $that ) {
+ $ok = $Test->is_eq($this, $that, $name);
+ }
+ else {
+ local @Data_Stack = ();
+ if( _deep_check($this, $that) ) {
+ $ok = $Test->ok(1, $name);
+ }
+ else {
+ $ok = $Test->ok(0, $name);
+ $ok = $Test->diag(_format_stack(@Data_Stack));
+ }
+ }
+
+ return $ok;
+}
+
+sub _format_stack {
+ my(@Stack) = @_;
+
+ my $var = '$FOO';
+ my $did_arrow = 0;
+ foreach my $entry (@Stack) {
+ my $type = $entry->{type} || '';
+ my $idx = $entry->{'idx'};
+ if( $type eq 'HASH' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "{$idx}";
+ }
+ elsif( $type eq 'ARRAY' ) {
+ $var .= "->" unless $did_arrow++;
+ $var .= "[$idx]";
+ }
+ elsif( $type eq 'REF' ) {
+ $var = "\${$var}";
+ }
+ }
+
+ my @vals = @{$Stack[-1]{vals}}[0,1];
+ my @vars = ();
+ ($vars[0] = $var) =~ s/\$FOO/ \$got/;
+ ($vars[1] = $var) =~ s/\$FOO/\$expected/;
+
+ my $out = "Structures begin differing at:\n";
+ foreach my $idx (0..$#vals) {
+ my $val = $vals[$idx];
+ $vals[$idx] = !defined $val ? 'undef' :
+ $val eq $DNE ? "Does not exist"
+ : "'$val'";
+ }
+
+ $out .= "$vars[0] = $vals[0]\n";
+ $out .= "$vars[1] = $vals[1]\n";
+
+ $out =~ s/^/ /msg;
+ return $out;
+}
+
+
+=item B<eq_array>
+
+ eq_array(\@this, \@that);
+
+Checks if two arrays are equivalent. This is a deep check, so
+multi-level structures are handled correctly.
+
+=cut
+
+#'#
+sub eq_array {
+ my($a1, $a2) = @_;
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
+ for (0..$max) {
+ my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
+ my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+
+ push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
+ $ok = _deep_check($e1,$e2);
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+ return $ok;
+}
+
+sub _deep_check {
+ my($e1, $e2) = @_;
+ my $ok = 0;
+
+ my $eq;
+ {
+ # Quiet uninitialized value warnings when comparing undefs.
+ local $^W = 0;
+
+ if( $e1 eq $e2 ) {
+ $ok = 1;
+ }
+ else {
+ if( UNIVERSAL::isa($e1, 'ARRAY') and
+ UNIVERSAL::isa($e2, 'ARRAY') )
+ {
+ $ok = eq_array($e1, $e2);
+ }
+ elsif( UNIVERSAL::isa($e1, 'HASH') and
+ UNIVERSAL::isa($e2, 'HASH') )
+ {
+ $ok = eq_hash($e1, $e2);
+ }
+ elsif( UNIVERSAL::isa($e1, 'REF') and
+ UNIVERSAL::isa($e2, 'REF') )
+ {
+ push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+ $ok = _deep_check($$e1, $$e2);
+ pop @Data_Stack if $ok;
+ }
+ elsif( UNIVERSAL::isa($e1, 'SCALAR') and
+ UNIVERSAL::isa($e2, 'SCALAR') )
+ {
+ push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+ $ok = _deep_check($$e1, $$e2);
+ }
+ else {
+ push @Data_Stack, { vals => [$e1, $e2] };
+ $ok = 0;
+ }
+ }
+ }
+
+ return $ok;
+}
+
+
+=item B<eq_hash>
+
+ eq_hash(\%this, \%that);
+
+Determines if the two hashes contain the same keys and values. This
+is a deep check.
+
+=cut
+
+sub eq_hash {
+ my($a1, $a2) = @_;
+ return 1 if $a1 eq $a2;
+
+ my $ok = 1;
+ my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
+ foreach my $k (keys %$bigger) {
+ my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
+ my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+
+ push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
+ $ok = _deep_check($e1, $e2);
+ pop @Data_Stack if $ok;
+
+ last unless $ok;
+ }
+
+ return $ok;
+}
+
+=item B<eq_set>
+
+ eq_set(\@this, \@that);
+
+Similar to eq_array(), except the order of the elements is B<not>
+important. This is a deep check, but the irrelevancy of order only
+applies to the top level.
+
+B<NOTE> By historical accident, this is not a true set comparision.
+While the order of elements does not matter, duplicate elements do.
+
+=cut
+
+# We must make sure that references are treated neutrally. It really
+# doesn't matter how we sort them, as long as both arrays are sorted
+# with the same algorithm.
+sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b }
+
+sub eq_set {
+ my($a1, $a2) = @_;
+ return 0 unless @$a1 == @$a2;
+
+ # There's faster ways to do this, but this is easiest.
+ return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
+}
+
+=back
+
+
+=head2 Extending and Embedding Test::More
+
+Sometimes the Test::More interface isn't quite enough. Fortunately,
+Test::More is built on top of Test::Builder which provides a single,
+unified backend for any test library to use. This means two test
+libraries which both use Test::Builder B<can be used together in the
+same program>.
+
+If you simply want to do a little tweaking of how the tests behave,
+you can access the underlying Test::Builder object like so:
+
+=over 4
+
+=item B<builder>
+
+ my $test_builder = Test::More->builder;
+
+Returns the Test::Builder object underlying Test::More for you to play
+with.
+
+=cut
+
+sub builder {
+ return Test::Builder->new;
+}
+
+=back
+
+
+=head1 NOTES
+
+Test::More is B<explicitly> tested all the way back to perl 5.004.
+
+Test::More is thread-safe for perl 5.8.0 and up.
+
+=head1 BUGS and CAVEATS
+
+=over 4
+
+=item Making your own ok()
+
+If you are trying to extend Test::More, don't. Use Test::Builder
+instead.
+
+=item The eq_* family has some caveats.
+
+=item Test::Harness upgrades
+
+no_plan and todo depend on new Test::Harness features and fixes. If
+you're going to distribute tests that use no_plan or todo your
+end-users will have to upgrade Test::Harness to the latest one on
+CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness
+will work fine.
+
+If you simply depend on Test::More, it's own dependencies will cause a
+Test::Harness upgrade.
+
+=back
+
+
+=head1 HISTORY
+
+This is a case of convergent evolution with Joshua Pritikin's Test
+module. I was largely unaware of its existence when I'd first
+written my own ok() routines. This module exists because I can't
+figure out how to easily wedge test names into Test's interface (along
+with a few other problems).
+
+The goal here is to have a testing utility that's simple to learn,
+quick to use and difficult to trip yourself up with while still
+providing more flexibility than the existing Test.pm. As such, the
+names of the most common routines are kept tiny, special cases and
+magic side-effects are kept to a minimum. WYSIWYG.
+
+
+=head1 SEE ALSO
+
+L<Test::Simple> if all this confuses you and you just want to write
+some tests. You can upgrade to Test::More later (it's forward
+compatible).
+
+L<Test::Differences> for more ways to test complex data structures.
+And it plays well with Test::More.
+
+L<Test> is the old testing module. Its main benefit is that it has
+been distributed with Perl since 5.004_05.
+
+L<Test::Harness> for details on how your test results are interpreted
+by Perl.
+
+L<Test::Unit> describes a very featureful unit testing interface.
+
+L<Test::Inline> shows the idea of embedded testing.
+
+L<SelfTest> is another approach to embedded testing.
+
+
+=head1 AUTHORS
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
+from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, chromatic and the perl-qa gang.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
+#!perl -w
+use strict;
+use lib 't';
use Imager qw(:all);
-
-print "1..9\n";
+use Test::More tests => 9;
init_log("testout/t101jpeg.log",1);
-$green=i_color_new(0,255,0,255);
-$blue=i_color_new(0,0,255,255);
-$red=i_color_new(255,0,0,255);
+my $green=i_color_new(0,255,0,255);
+my $blue=i_color_new(0,0,255,255);
+my $red=i_color_new(255,0,0,255);
-$img=Imager::ImgRaw::new(150,150,3);
-$cmpimg=Imager::ImgRaw::new(150,150,3);
+my $img=Imager::ImgRaw::new(150,150,3);
+my $cmpimg=Imager::ImgRaw::new(150,150,3);
i_box_filled($img,70,25,130,125,$green);
i_box_filled($img,20,25,80,125,$blue);
i_has_format("jpeg") && print "# has jpeg\n";
if (!i_has_format("jpeg")) {
- for (1..9) {
- print "ok $_ # skip no jpeg support\n";
+ # previously we'd crash if we tried to save/read an image via the OO
+ # interface when there was no jpeg support
+ SKIP:
+ {
+ my $im = Imager->new;
+ ok(!$im->read(file=>"testimg/base.jpg"), "should fail to read jpeg");
+ cmp_ok($im->errstr, '=~', qr/format 'jpeg' not supported/, "check no jpeg message");
+ $im = Imager->new(xsize=>2, ysize=>2);
+ ok(!$im->write(file=>"testout/nojpeg.jpg"), "should fail to write jpeg");
+ cmp_ok($im->errstr, '=~', qr/format not supported/, "check no jpeg message");
+ skip("no jpeg support", 5);
}
} else {
open(FH,">testout/t101.jpg") || die "cannot open testout/t101.jpg for writing\n";
binmode(FH);
- $IO = Imager::io_new_fd(fileno(FH));
- i_writejpeg_wiol($img,$IO,30);
+ my $IO = Imager::io_new_fd(fileno(FH));
+ ok(i_writejpeg_wiol($img,$IO,30), "write jpeg low level");
close(FH);
- print "ok 1\n";
-
open(FH, "testout/t101.jpg") || die "cannot open testout/t101.jpg\n";
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
print "$cmpimg\n";
my $diff = sqrt(i_img_diff($img,$cmpimg))/150*150;
print "# jpeg average mean square pixel difference: ",$diff,"\n";
- print "ok 2\n";
+ ok($cmpimg, "read jpeg low level");
- $diff < 10000 or print "not ";
- print "ok 3\n";
+ ok($diff < 10000, "difference between original and jpeg within bounds");
Imager::log_entry("Starting 4\n", 1);
my $imoo = Imager->new;
- $imoo->read(file=>'testout/t101.jpg') or print "not ";
- print "ok 4\n";
- $imoo->write(file=>'testout/t101_oo.jpg') or print "not ";
+ ok($imoo->read(file=>'testout/t101.jpg'), "read jpeg OO");
+ ok($imoo->write(file=>'testout/t101_oo.jpg'), "write jpeg OO");
Imager::log_entry("Starting 5\n", 1);
- print "ok 5\n";
my $oocmp = Imager->new;
- $oocmp->read(file=>'testout/t101_oo.jpg') or print "not ";
- print "ok 6\n";
+ ok($oocmp->read(file=>'testout/t101_oo.jpg'), "read jpeg OO for comparison");
$diff = sqrt(i_img_diff($imoo->{IMG},$oocmp->{IMG}))/150*150;
print "# OO image difference $diff\n";
- $diff < 10000 or print "not ";
- print "ok 7\n";
+ ok($diff < 10000, "difference between original and jpeg within bounds");
# write failure test
open FH, "< testout/t101.jpg" or die "Cannot open testout/t101.jpg: $!";
binmode FH;
- ok(8, !$imoo->write(fd=>fileno(FH), type=>'jpeg'), 'failure handling');
+ ok(!$imoo->write(fd=>fileno(FH), type=>'jpeg'), 'failure handling');
close FH;
print "# ",$imoo->errstr,"\n";
# check that the i_format tag is set
my @fmt = $imoo->tags(name=>'i_format');
- ok(9, @fmt == 1 && $fmt[0] eq 'jpeg', 'i_format tag');
+ is($fmt[0], 'jpeg', 'i_format tag');
}
-sub ok {
- my ($num, $test, $msg) = @_;
-
- if ($test) {
- print "ok $num\n";
- }
- else {
- print "not ok $num # $msg\n";
- }
-}
#!perl -w
use strict;
+use lib 't';
+use Test::More tests => 13;
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'
# (It may become useful if the test is moved to ./t subdirectory.)
use lib qw(blib/lib blib/arch);
-BEGIN { $| = 1; print "1..13\n"; }
BEGIN { require 't/testtools.pl'; }
-BEGIN { useokx('Imager', 'load Imager', ':all') }
+BEGIN { use_ok('Imager', ':all') }
init_log("testout/t102png.log",1);
i_has_format("png") && print "# has png\n";
i_box_filled($timg, 2, 2, 18, 18, $trans);
if (!i_has_format("png")) {
- skipx(12, "no png support");
+ SKIP:
+ {
+ my $im = Imager->new;
+ ok(!$im->read(file=>"testimg/palette.png"), "should fail to read png");
+ is($im->errstr, "format 'png' not supported", "check no png message");
+ $im = Imager->new(xsize=>2, ysize=>2);
+ ok(!$im->write(file=>"testout/nopng.png"), "should fail to write png");
+ is($im->errstr, 'format not supported', "check no png message");
+ skip("no png support", 8);
+ }
} else {
Imager::i_tags_add($img, "i_xres", 0, "300", 0);
Imager::i_tags_add($img, "i_yres", 0, undef, 200);
open(FH,">testout/t102.png") || die "cannot open testout/t102.png for writing\n";
binmode(FH);
my $IO = Imager::io_new_fd(fileno(FH));
- okx(i_writepng_wiol($img, $IO), "write");
+ ok(i_writepng_wiol($img, $IO), "write");
close(FH);
open(FH,"testout/t102.png") || die "cannot open testout/t102.png\n";
$IO = Imager::io_new_fd(fileno(FH));
my $cmpimg = i_readpng_wiol($IO, -1);
close(FH);
- okx($cmpimg, "read png");
+ ok($cmpimg, "read png");
print "# png average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
- isx(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
+ is(i_img_diff($img, $cmpimg), 0, "compare saved and original images");
my %tags = map { Imager::i_tags_get($cmpimg, $_) }
0..Imager::i_tags_count($cmpimg) - 1;
- okx(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
- okx(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
- isx($tags{i_format}, "png", "i_format: $tags{i_format}");
+ ok(abs($tags{i_xres} - 300) < 1, "i_xres: $tags{i_xres}");
+ ok(abs($tags{i_yres} - 200) < 1, "i_yres: $tags{i_yres}");
+ is($tags{i_format}, "png", "i_format: $tags{i_format}");
open FH, "> testout/t102_trans.png"
or die "Cannot open testout/t102_trans.png: $!";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
- okx(i_writepng_wiol($timg, $IO), "write tranparent");
+ ok(i_writepng_wiol($timg, $IO), "write tranparent");
close FH;
open FH,"testout/t102_trans.png"
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
$cmpimg = i_readpng_wiol($IO, -1);
- okx($cmpimg, "read transparent");
+ ok($cmpimg, "read transparent");
close(FH);
print "# png average mean square pixel difference: ",sqrt(i_img_diff($timg,$cmpimg))/150*150,"\n";
- isx(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");
+ is(i_img_diff($timg, $cmpimg), 0, "compare saved and original transparent");
# REGRESSION TEST
# png.c 1.1 would produce an incorrect image when loading images with
$IO = Imager::io_new_fd(fileno(FH));
# 1.1 may segfault here (it does with libefence)
my $pimg = i_readpng_wiol($IO,-1);
- okx($pimg, "read transparent paletted image");
+ ok($pimg, "read transparent paletted image");
close FH;
open FH, "< testimg/palette_out.png"
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
my $poimg = i_readpng_wiol($IO, -1);
- okx($poimg, "read palette_out image");
+ ok($poimg, "read palette_out image");
close FH;
- if (!isx(i_img_diff($pimg, $poimg), 0, "images the same")) {
+ if (!is(i_img_diff($pimg, $poimg), 0, "images the same")) {
print <<EOS;
# this tests a bug in Imager's png.c v1.1
# if also tickles a bug in libpng before 1.0.5, so you may need to
#!perl -w
use strict;
$|=1;
-print "1..69\n";
+use Test::More tests => 69;
use Imager qw(:all);
BEGIN { require "t/testtools.pl"; }
+use Carp 'confess';
+$SIG{__DIE__} = sub { confess @_ };
my $buggy_giflib_file = "buggy_giflib.txt";
-sub ok ($$$);
-
init_log("testout/t105gif.log",1);
my $green=i_color_new(0,255,0,255);
i_box_filled($timg, 0, 0, 20, 20, $green);
i_box_filled($timg, 2, 2, 18, 18, $trans);
-if (!i_has_format("gif")) {
- skipn(1, 69, "no gif support");
-} else {
+
+SKIP:
+{
+ unless (i_has_format("gif")) {
+ my $im = Imager->new;
+ ok(!$im->read(file=>"testimg/scale.gif"), "should fail to read gif");
+ is($im->errstr, "format 'gif' not supported", "check no gif message");
+ $im = Imager->new(xsize=>2, ysize=>2);
+ ok(!$im->write(file=>"testout/nogif.gif"), "should fail to write gif");
+ is($im->errstr, 'format not supported', "check no gif message");
+ skip("no gif support", 65);
+ }
open(FH,">testout/t105.gif") || die "Cannot open testout/t105.gif\n";
binmode(FH);
- i_writegifmc($img,fileno(FH),6) || die "Cannot write testout/t105.gif\n";
+ ok(i_writegifmc($img,fileno(FH),6), "write low") or
+ die "Cannot write testout/t105.gif\n";
close(FH);
- print "ok 1\n";
-
open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
binmode(FH);
- $img=i_readgif(fileno(FH)) || die "Cannot read testout/t105.gif\n";
+ ok($img=i_readgif(fileno(FH)), "read low")
+ or die "Cannot read testout/t105.gif\n";
close(FH);
- print "ok 2\n";
-
open(FH,"testout/t105.gif") || die "Cannot open testout/t105.gif\n";
binmode(FH);
($img, my $palette)=i_readgif(fileno(FH));
- $img || die "Cannot read testout/t105.gif\n";
+ ok($img, "read palette") or die "Cannot read testout/t105.gif\n";
close(FH);
$palette=''; # just to skip a warning.
- print "ok 3\n";
-
# check that reading interlaced/non-interlaced versions of
# the same GIF produce the same image
# I could replace this with code that used Imager's built-in
open(FH, "<testimg/scalei.gif") || die "Cannot open testimg/scalei.gif";
binmode FH;
my ($imgi) = i_readgif(fileno(FH));
- $imgi || die "Cannot read testimg/scalei.gif";
+ ok($imgi, "read interlaced") or die "Cannot read testimg/scalei.gif";
close FH;
- print "ok 4\n";
open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
binmode FH;
my ($imgni) = i_readgif(fileno(FH));
- $imgni or die "Cannot read testimg/scale.gif";
+ ok($imgni, "read normal") or die "Cannot read testimg/scale.gif";
close FH;
- print "ok 5\n";
open FH, ">testout/t105i.ppm" or die "Cannot create testout/t105i.ppm";
binmode FH;
my $IO = Imager::io_new_fd( fileno(FH) );
- i_writeppm_wiol($imgi, $IO) or die "Cannot write testout/t105i.ppm";
+ i_writeppm_wiol($imgi, $IO)
+ or die "Cannot write testout/t105i.ppm";
close FH;
-
open FH, ">testout/t105ni.ppm" or die "Cannot create testout/t105ni.ppm";
binmode FH;
$IO = Imager::io_new_fd( fileno(FH) );
- i_writeppm_wiol($imgni, $IO) or die "Cannot write testout/t105ni.ppm";
+ i_writeppm_wiol($imgni, $IO)
+ or die "Cannot write testout/t105ni.ppm";
close FH;
# compare them
open FH, "<testout/t105ni.ppm" or die "Cannot open testout/t105ni.ppm";
my $datani = do { local $/; <FH> };
close FH;
- if ($datai eq $datani) {
- print "ok 6\n";
- }
- else {
- print "not ok 6\n";
- }
+ is($datai, $datani, "images match");
my $gifver = Imager::i_giflib_version();
- if ($gifver >= 4.0) {
+ SKIP:
+ {
+ skip("giflib3 doesn't support callbacks", 4) if $gifver >= 4.0;
# reading with a callback
# various sizes to make sure the buffering works
# requested size
# no callback version in giflib3, so don't overwrite a good image
my $img2 = i_readgif_callback(sub { my $tmp; read(FH, $tmp, $_[0]) and $tmp });
close FH;
- print $img ? "ok 7\n" : "not ok 7\n";
+ ok($img, "reading with a callback");
- print test_readgif_cb(1) ? "ok 8\n" : "not ok 8\n";
- print test_readgif_cb(512) ? "ok 9\n" : "not ok 9\n";
- print test_readgif_cb(1024) ? "ok 10\n" : "not ok 10\n";
- }
- else {
- for (7..10) {
- print "ok $_ # skip giflib3 doesn't support callbacks\n";
- }
+ ok(test_readgif_cb(1), "read callback 1 char buffer");
+ ok(test_readgif_cb(512), "read callback 512 char buffer");
+ ok(test_readgif_cb(1024), "read callback 1024 char buffer");
}
open FH, ">testout/t105_mc.gif" or die "Cannot open testout/t105_mc.gif";
binmode FH;
- i_writegifmc($img, fileno(FH), 7) or print "not ";
+ ok(i_writegifmc($img, fileno(FH), 7), "writegifmc");
close(FH);
- print "ok 11\n";
# new writegif_gen
# test webmap, custom errdiff map
# (looks fairly awful)
open FH, ">testout/t105_gen.gif" or die $!;
binmode FH;
- i_writegif_gen(fileno(FH), { make_colors=>'webmap',
+ ok(i_writegif_gen(fileno(FH), { make_colors=>'webmap',
translate=>'errdiff',
errdiff=>'custom',
errdiff_width=>2,
errdiff_height=>2,
- errdiff_map=>[0, 1, 1, 0]}, $img)
- or print "not ";
+ errdiff_map=>[0, 1, 1, 0]}, $img),
+ "webmap, custom errdif map");
close FH;
- print "ok 12\n";
print "# the following tests are fairly slow\n";
-
+
# test animation, mc_addi, error diffusion, ordered transparency
my @imgs;
my $sortagreen = i_color_new(0, 255, 0, 63);
my @gif_disposal = (2) x 5;
open FH, ">testout/t105_anim.gif" or die $!;
binmode FH;
- i_writegif_gen(fileno(FH), { make_colors=>'addi',
+ ok(i_writegif_gen(fileno(FH), { make_colors=>'addi',
translate=>'closest',
gif_delays=>\@gif_delays,
gif_disposal=>\@gif_disposal,
gif_positions=> [ map [ $_*10, $_*10 ], 0..4 ],
gif_user_input=>[ 1, 0, 1, 0, 1 ],
transp=>'ordered',
- tr_orddith=>'dot8'}, @imgs)
- or die "Cannot write anim gif";
+ 'tr_orddith'=>'dot8'}, @imgs),
+ "write anim gif");
close FH;
- print "ok 13\n";
my $can_write_callback = 0;
unlink $buggy_giflib_file;
# output looks moderately horrible
open FH, ">testout/t105_mult_pall.gif" or die "Cannot create file: $!";
binmode FH;
- if (i_writegif_gen(fileno(FH), { #make_colors=>'webmap',
+ ok(i_writegif_gen(fileno(FH), { #make_colors=>'webmap',
translate=>'giflib',
- }, @imgs)) {
- print "ok 15\n";
- }
- else {
- print "not ok 15 # ", join(":", map $_->[1], Imager::i_errors()),"\n";
- }
+ }, @imgs), "write multiple palettes")
+ or print "# ", join(":", map $_->[1], Imager::i_errors()),"\n";
close FH;
# regression test: giflib doesn't like 1 colour images
i_box_filled($img1, 0, 0, 100, 100, $red);
open FH, ">testout/t105_onecol.gif" or die $!;
binmode FH;
- if (i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1)) {
- print "ok 16 # single colour write regression\n";
- } else {
- print "not ok 16 # single colour write regression\n";
- }
+ ok(i_writegif_gen(fileno(FH), { translate=>'giflib'}, $img1),
+ "single colour write regression");
close FH;
# transparency test
i_box_filled($timg, 2, 2, 18, 18, $trans);
open FH, ">testout/t105_trans.gif" or die $!;
binmode FH;
- i_writegif_gen(fileno(FH), { make_colors=>'addi',
+ ok(i_writegif_gen(fileno(FH), { make_colors=>'addi',
translate=>'closest',
transp=>'ordered',
- }, $timg) or print "not ";
- print "ok 17\n";
+ }, $timg), "write transparent");
close FH;
# some error handling tests
open FH, "<t/t105gif.t"
or die "Cannot open this script!: $!";
binmode FH;
- my $im2 = i_readgif(fileno(FH));
- if ($im2) {
- # this should have failed
- print "not ok 18 # giflib think script if a GIF file\n";
- }
- else {
- print "ok 18 # ",Imager::_error_as_msg(),"\n";
- }
+ ok(!i_readgif(fileno(FH)),
+ "read test script as gif should fail ". Imager::_error_as_msg());
close FH;
# try to save no images :)
open FH, ">testout/t105_none.gif"
or die "Cannot open testout/t105_none.gif: $!";
binmode FH;
- if (i_writegif_gen(fileno(FH), {}, "hello")) {
- print "not ok 19 # shouldn't be able to save strings\n";
- }
- else {
- print "ok 19 # ",Imager::_error_as_msg(),"\n";
+ if (ok(!i_writegif_gen(fileno(FH), {}, "hello"), "shouldn't be able to write a string as a gif")) {
+ print "# ",Imager::_error_as_msg(),"\n";
}
# try to read a truncated gif (no image descriptors)
- read_failure('testimg/trimgdesc.gif', 20);
+ read_failure('testimg/trimgdesc.gif');
# file truncated just after the image descriptor tag
- read_failure('testimg/trmiddesc.gif', 21);
+ read_failure('testimg/trmiddesc.gif');
# image has no colour map
- read_failure('testimg/nocmap.gif', 22);
+ read_failure('testimg/nocmap.gif');
- unless (-e $buggy_giflib_file) {
+ SKIP:
+ {
+ skip("see $buggy_giflib_file", 8) if -e $buggy_giflib_file;
# image has a local colour map
open FH, "< testimg/loccmap.gif"
or die "Cannot open testimg/loccmap.gif: $!";
binmode FH;
- if (i_readgif(fileno(FH))) {
- print "ok 23\n";
- }
- else {
- print "not ok 23 # failed to read image with only a local colour map";
- }
+ ok(i_readgif(fileno(FH)), "read an image with only a local colour map");
close FH;
# image has global and local colour maps
or die "Cannot open testimg/screen2.gif: $!";
binmode FH;
my $ims = i_readgif(fileno(FH));
- if ($ims) {
- print "ok 24\n";
- }
- else {
- print "not ok 24 # ",Imager::_error_as_msg(),"\n";
+ unless (ok($ims, "read an image with global and local colour map")) {
+ print "# ",Imager::_error_as_msg(),"\n";
}
close FH;
+
open FH, "< testimg/expected.gif"
or die "Cannot open testimg/expected.gif: $!";
binmode FH;
my $ime = i_readgif(fileno(FH));
close FH;
- if ($ime) {
- print "ok 25\n";
- }
- else {
- print "not ok 25 # ",Imager::_error_as_msg(),"\n";
- }
- if ($ims && $ime) {
- if (i_img_diff($ime, $ims)) {
- print "not ok 26 # mismatch ",i_img_diff($ime, $ims),"\n";
+ ok($ime, "reading testimg/expected.gif");
+ SKIP:
+ {
+ skip("could not read one or both of expected.gif or loccamp.gif", 1)
+ unless $ims and $ime;
+ unless (is(i_img_diff($ime, $ims), 0,
+ "compare loccmap and expected")) {
# save the bad one
open FH, "> testout/t105_screen2.gif"
or die "Cannot create testout/t105_screen.gif: $!";
or print "# could not save t105_screen.gif\n";
close FH;
}
- else {
- print "ok 26\n";
- }
- }
- else {
- print "ok 26 # skipped\n";
}
# test reading a multi-image file into multiple images
open FH, "< testimg/screen2.gif"
or die "Cannot open testimg/screen2.gif: $!";
binmode FH;
- @imgs = Imager::i_readgif_multi(fileno(FH))
- or print "not ";
- print "ok 27\n";
+ @imgs = Imager::i_readgif_multi(fileno(FH));
+ ok(@imgs, "read multi-image file into multiple images");
close FH;
- @imgs == 2 or print "not ";
- print "ok 28\n";
+ is(@imgs, 2, "should be 2 images");
+ my $paletted = 1;
for my $img (@imgs) {
unless (Imager::i_img_type($img) == 1) {
- print "not ";
+ $paletted = 0;
last;
}
}
- print "ok 29\n";
- Imager::i_colorcount($imgs[0]) == 4 or print "not ";
- print "ok 30\n";
- Imager::i_colorcount($imgs[1]) == 2 or print "not ";
- print "ok 31\n";
- Imager::i_tags_find($imgs[0], "gif_left", 0) or print "not ";
- print "ok 32\n";
+ ok($paletted, "both images should be paletted");
+ is(Imager::i_colorcount($imgs[0]), 4, "4 colours in first image");
+ is(Imager::i_colorcount($imgs[1]), 2, "2 colours in second image");
+ ok(Imager::i_tags_find($imgs[0], "gif_left", 0),
+ "gif_left tag should be there");
my @tags = map {[ Imager::i_tags_get($imgs[1], $_) ]} 0..Imager::i_tags_count($imgs[1])-1;
my ($left) = grep $_->[0] eq 'gif_left', @tags;
- $left && $left->[1] == 3 or print "not ";
- print "ok 33\n";
+ ok($left && $left->[1] == 3, "check gif_left value");
# screen3.gif was saved with
open FH, "< testimg/screen3.gif"
or die "Cannot open testimg/screen3.gif: $!";
binmode FH;
- @imgs = Imager::i_readgif_multi(fileno(FH))
- or print "not ";
- print "ok 34\n";
+ @imgs = Imager::i_readgif_multi(fileno(FH));
+ ok(@imgs, "read screen3.gif");
close FH;
eval {
require 'Data/Dumper.pm';
}
# at this point @imgs should contain only paletted images
- ok(35, Imager::i_img_type($imgs[0]) == 1, "imgs[0] not paletted");
- ok(36, Imager::i_img_type($imgs[1]) == 1, "imgs[1] not paletted");
+ ok(Imager::i_img_type($imgs[0]) == 1, "imgs[0] paletted");
+ ok(Imager::i_img_type($imgs[1]) == 1, "imgs[1] paletted");
# see how we go saving it
open FH, ">testout/t105_pal.gif" or die $!;
binmode FH;
- ok(37, i_writegif_gen(fileno(FH), { make_colors=>'addi',
+ ok(i_writegif_gen(fileno(FH), { make_colors=>'addi',
translate=>'closest',
transp=>'ordered',
}, @imgs), "write from paletted");
# make sure nothing bad happened
open FH, "< testout/t105_pal.gif" or die $!;
binmode FH;
- ok(38, (my @imgs2 = Imager::i_readgif_multi(fileno(FH))) == 2,
+ ok((my @imgs2 = Imager::i_readgif_multi(fileno(FH))) == 2,
"re-reading saved paletted images");
- ok(39, i_img_diff($imgs[0], $imgs2[0]) == 0, "imgs[0] mismatch");
- ok(40, i_img_diff($imgs[1], $imgs2[1]) == 0, "imgs[1] mismatch");
- }
- else {
- for (23..40) {
- print "ok $_ # skip see $buggy_giflib_file\n";
- }
+ ok(i_img_diff($imgs[0], $imgs2[0]) == 0, "imgs[0] mismatch");
+ ok(i_img_diff($imgs[1], $imgs2[1]) == 0, "imgs[1] mismatch");
}
+
# test that the OO interface warns when we supply old options
{
my @warns;
local $SIG{__WARN__} = sub { push(@warns, "@_") };
my $ooim = Imager->new;
- ok(41, $ooim->read(file=>"testout/t105.gif"), "read into object");
- ok(42, $ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
+ ok($ooim->read(file=>"testout/t105.gif"), "read into object");
+ ok($ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
"save from object");
- ok(43, grep(/Obsolete .* interlace .* gif_interlace/, @warns),
+ ok(grep(/Obsolete .* interlace .* gif_interlace/, @warns),
"check for warning");
init(warn_obsolete=>0);
@warns = ();
- ok(44, $ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
+ ok($ooim->write(file=>"testout/t105_warn.gif", interlace=>1),
"save from object");
- ok(45, !grep(/Obsolete .* interlace .* gif_interlace/, @warns),
+ ok(!grep(/Obsolete .* interlace .* gif_interlace/, @warns),
"check for warning");
}
# test that we get greyscale from 1 channel images
# we check for each makemap, and for each translate
print "# test writes of grayscale images - ticket #365\n";
- my $num = 46;
my $ooim = Imager->new(xsize=>50, ysize=>50, channels=>1);
for (my $y = 0; $y < 50; $y += 10) {
$ooim->box(box=>[ 0, $y, 49, $y+9], color=>NC($y*5,0,0), filled=>1);
errdiff => 0 );
for my $makemap (qw(mediancut addi)) {
print "# make_colors => $makemap\n";
- ok($num++, $ooim->write(file=>"testout/t105gray-$makemap.gif",
+ ok( $ooim->write(file=>"testout/t105gray-$makemap.gif",
make_colors=>$makemap,
gifquant=>'gen'),
"writing gif with makemap $makemap");
my $im2 = Imager->new;
- if (ok($num++, $im2->read(file=>"testout/t105gray-$makemap.gif"),
+ if (ok($im2->read(file=>"testout/t105gray-$makemap.gif"),
"reading written grayscale gif")) {
my $diff = i_img_diff($ooim3->{IMG}, $im2->{IMG});
- ok($num++, $diff <= $maxerror{$makemap}, "comparing images $diff");
+ ok($diff <= $maxerror{$makemap}, "comparing images $diff");
#$im2->write(file=>"testout/t105gray-$makemap.ppm");
}
else {
- print "ok $num # skip\n";
- ++$num;
+ SKIP: { skip("could not get test image", 1); }
}
}
for my $translate (qw(closest perturb errdiff)) {
print "# translate => $translate\n";
my @colors = map NC($_*50, $_*50, $_*50), 0..4;
- ok($num++, $ooim->write(file=>"testout/t105gray-$translate.gif",
- translate=>$translate,
- make_colors=>'none',
- colors=>\@colors,
- gifquant=>'gen'),
+ ok($ooim->write(file=>"testout/t105gray-$translate.gif",
+ translate=>$translate,
+ make_colors=>'none',
+ colors=>\@colors,
+ gifquant=>'gen'),
"writing gif with translate $translate");
my $im2 = Imager->new;
- if (ok($num++, $im2->read(file=>"testout/t105gray-$translate.gif"),
+ if (ok($im2->read(file=>"testout/t105gray-$translate.gif"),
"reading written grayscale gif")) {
my $diff = i_img_diff($ooim3->{IMG}, $im2->{IMG});
- ok($num++, $diff <= $maxerror{$translate}, "comparing images $diff");
+ ok($diff <= $maxerror{$translate}, "comparing images $diff");
#$im2->write(file=>"testout/t105gray-$translate.ppm");
}
else {
- print "ok $num # skip\n";
- ++$num;
+ SKIP: { skip("could not load test image", 1) }
}
}
# try to write an image with no colors - should error
- ok($num++, !$ooim->write(file=>"testout/t105nocolors.gif",
- make_colors=>'none',
- colors=>[], gifquant=>'gen'),
+ ok(!$ooim->write(file=>"testout/t105nocolors.gif",
+ make_colors=>'none',
+ colors=>[], gifquant=>'gen'),
"write with no colors");
# try to write multiple with no colors, with separate maps
# image reads
{
my @anim = Imager->read_multi(file=>"testout/t105_anim.gif");
- okn($num++, @anim == 5, "check we got all the images");
+ ok(@anim == 5, "check we got all the images");
for my $frame (@anim) {
my ($type) = $frame->tags(name=>'i_format');
- isn($num++, $type, 'gif', "check i_format for animation frame");
+ is($type, 'gif', "check i_format for animation frame");
}
my $im = Imager->new;
- okn($num++, $im->read(file=>"testout/t105.gif"), "read some gif");
+ ok($im->read(file=>"testout/t105.gif"), "read some gif");
my ($type) = $im->tags(name=>'i_format');
- isn($num++, $type, 'gif', 'check i_format for single image read');
+ is($type, 'gif', 'check i_format for single image read');
}
}
-sub ok ($$$) {
- my ($num, $ok, $comment) = @_;
-
- if ($ok) {
- print "ok $num\n";
- }
- else {
- print "not ok $num # line ",(caller)[2],": $comment \n";
- }
-}
-
sub test_readgif_cb {
my ($size) = @_;
# tests for reading bad gif files
sub read_failure {
- my ($filename, $testnum) = @_;
+ my ($filename) = @_;
open FH, "< $filename"
or die "Cannot open $filename: $!";
binmode FH;
my ($result, $map) = i_readgif(fileno(FH));
- if ($result) {
- print "not ok $testnum # this is an invalid file, we succeeded\n";
- }
- else {
- print "ok $testnum # ",Imager::_error_as_msg(),"\n";
- }
+ ok(!$result, "attempt to read invalid image $filename ".Imager::_error_as_msg());
close FH;
}
my $ok = 1;
my @out = `$cmd`; # should work on DOS and Win32
- print @out;
my $found = 0;
for (@out) {
- if (/^not ok/) {
+ if (/^not ok\s+(?:\d+\s*)?#(.*)/ || /^not ok/) {
+ my $msg = $1 || '';
+ ok(0, $msg);
$ok = 0;
++$found;
}
- elsif (/^ok/) {
+ elsif (/^ok\s+(?:\d+\s*)?#(.*)/ || /^ok/) {
+ my $msg = $1 || '';
+ ok(1, $msg);
++$found;
}
}
return $ok;
}
else {
- return skip($testnum, $count, "could not create test script $script: $!");
+ return skip("could not create test script $script: $!");
return 0;
}
}
#!perl -w
-print "1..76\n";
+use strict;
+use lib 't';
+use Test::More tests => 77;
use Imager qw(:all);
$^W=1; # warnings during command-line tests
$|=1; # give us some progress in the test harness
init_log("testout/t106tiff.log",1);
-$green=i_color_new(0,255,0,255);
-$blue=i_color_new(0,0,255,255);
-$red=i_color_new(255,0,0,255);
+my $green=i_color_new(0,255,0,255);
+my $blue=i_color_new(0,0,255,255);
+my $red=i_color_new(255,0,0,255);
-$img=Imager::ImgRaw::new(150,150,3);
+my $img=Imager::ImgRaw::new(150,150,3);
i_box_filled($img,70,25,130,125,$green);
i_box_filled($img,20,25,80,125,$blue);
i_box_filled($timg, 0, 0, 20, 20, $green);
i_box_filled($timg, 2, 2, 18, 18, $trans);
-my $test_num;
-
-if (!i_has_format("tiff")) {
- for (1..76) {
- print "ok $_ # skip no tiff support\n";
+SKIP:
+{
+ unless (i_has_format("tiff")) {
+ my $im = Imager->new;
+ ok(!$im->read(file=>"testimg/comp4.tif"), "should fail to read tif");
+ is($im->errstr, "format 'tiff' not supported", "check no tiff message");
+ $im = Imager->new(xsize=>2, ysize=>2);
+ ok(!$im->write(file=>"testout/notiff.tif"), "should fail to write tiff");
+ is($im->errstr, 'format not supported', "check no tiff message");
+ skip("no tiff support", 73);
}
-} else {
+
Imager::i_tags_add($img, "i_xres", 0, "300", 0);
Imager::i_tags_add($img, "i_yres", 0, undef, 250);
# resolutionunit is centimeters
open(FH,">testout/t106.tiff") || die "cannot open testout/t106.tiff for writing\n";
binmode(FH);
my $IO = Imager::io_new_fd(fileno(FH));
- i_writetiff_wiol($img, $IO);
+ ok(i_writetiff_wiol($img, $IO), "write low level");
close(FH);
- print "ok 1\n";
-
open(FH,"testout/t106.tiff") or die "cannot open testout/t106.tiff\n";
binmode(FH);
$IO = Imager::io_new_fd(fileno(FH));
- $cmpimg = i_readtiff_wiol($IO, -1);
+ my $cmpimg = i_readtiff_wiol($IO, -1);
+ ok($cmpimg, "read low-level");
close(FH);
print "# tiff average mean square pixel difference: ",sqrt(i_img_diff($img,$cmpimg))/150*150,"\n";
- print "ok 2\n";
- i_img_diff($img, $cmpimg) and print "not ";
- print "ok 3\n";
+ ok(!i_img_diff($img, $cmpimg), "compare written and read image");
# check the tags are ok
my %tags = map { Imager::i_tags_get($cmpimg, $_) }
0 .. Imager::i_tags_count($cmpimg) - 1;
- abs($tags{i_xres} - 300) < 0.5 or print "not ";
- print "ok 4\n";
- abs($tags{i_yres} - 250) < 0.5 or print "not ";
- print "ok 5\n";
- $tags{tiff_resolutionunit} == 3 or print "not ";
- print "ok 6\n";
- $tags{tiff_software} eq 't106tiff.t' or print "not ";
- print "ok 7\n";
+ ok(abs($tags{i_xres} - 300) < 0.5, "i_xres in range");
+ ok(abs($tags{i_yres} - 250) < 0.5, "i_yres in range");
+ is($tags{tiff_resolutionunit}, 3, "tiff_resolutionunit");
+ is($tags{tiff_software}, 't106tiff.t', "tiff_software");
$IO = Imager::io_new_bufchain();
- Imager::i_writetiff_wiol($img, $IO) or die "Cannot write to bufferchain\n";
+ ok(Imager::i_writetiff_wiol($img, $IO), "write to buffer chain");
my $tiffdata = Imager::io_slurp($IO);
open(FH,"testout/t106.tiff");
$odata = <FH>;
}
- if ($odata eq $tiffdata) {
- print "ok 8\n";
- } else {
- print "not ok 8\n";
- }
+ is($odata, $tiffdata, "same data in file as in memory");
# test Micksa's tiff writer
# a shortish fax page
or die "Cannot create testout/t106tiff_fax.tiff: $!";
binmode FH;
$IO = Imager::io_new_fd(fileno(FH));
- i_writetiff_wiol_faxable($faximg, $IO, 1)
- or print "not ";
- print "ok 9\n";
+ ok(i_writetiff_wiol_faxable($faximg, $IO, 1), "write faxable, low level");
close FH;
# test the OO interface
my $ooim = Imager->new;
- $ooim->read(file=>'testout/t106.tiff')
- or print "not ";
- print "ok 10\n";
- $ooim->write(file=>'testout/t106_oo.tiff')
- or print "not ";
- print "ok 11\n";
+ ok($ooim->read(file=>'testout/t106.tiff'), "read OO");
+ ok($ooim->write(file=>'testout/t106_oo.tiff'), "write OO");
# OO with the fax image
my $oofim = Imager->new;
- $oofim->read(file=>'testout/t106tiff_fax.tiff')
- or print "not ";
- print "ok 12\n";
+ ok($oofim->read(file=>'testout/t106tiff_fax.tiff'),
+ "read fax OO");
# this should have tags set for the resolution
%tags = map @$_, $oofim->tags;
- $tags{i_xres} == 204 or print "not ";
- print "ok 13\n";
- $tags{i_yres} == 196 or print "not ";
- print "ok 14\n";
- $tags{i_aspect_only} and print "not ";
- print "ok 15\n";
+ is($tags{i_xres}, 204, "fax i_xres");
+ is($tags{i_yres}, 196, "fax i_yres");
+ ok(!$tags{i_aspect_only}, "i_aspect_only");
# resunit_inches
- $tags{tiff_resolutionunit} == 2 or print "not ";
- print "ok 16\n";
+ is($tags{tiff_resolutionunit}, 2, "tiff_resolutionunit");
- $oofim->write(file=>'testout/t106_oo_fax.tiff', class=>'fax')
- or print "not ";
- print "ok 17\n";
+ ok($oofim->write(file=>'testout/t106_oo_fax.tiff', class=>'fax'),
+ "write OO, faxable");
# the following should fail since there's no type and no filename
my $oodata;
- $ooim->write(data=>\$oodata)
- and print "not ";
- print "ok 18\n";
+ ok(!$ooim->write(data=>\$oodata), "write with no type and no filename to guess with");
# OO to data
- $ooim->write(data=>\$oodata, type=>'tiff')
- or print "# ",$ooim->errstr, "\nnot ";
- print "ok 19\n";
- $oodata eq $tiffdata or print "not ";
- print "ok 20\n";
+ ok($ooim->write(data=>\$oodata, type=>'tiff'), "write to data")
+ or print "# ",$ooim->errstr, "\n";
+ is($oodata, $tiffdata, "check data matches between memory and file");
# make sure we can write non-fine mode
- $oofim->write(file=>'testout/t106_oo_faxlo.tiff', class=>'fax', fax_fine=>0)
- or print "not ";
- print "ok 21\n";
+ ok($oofim->write(file=>'testout/t106_oo_faxlo.tiff', class=>'fax', fax_fine=>0), "write OO, fax standard mode");
# paletted reads
my $img4 = Imager->new;
- $test_num = 22;
ok($img4->read(file=>'testimg/comp4.tif'), "reading 4-bit paletted");
ok($img4->type eq 'paletted', "image isn't paletted");
print "# colors: ", $img4->colorcount,"\n";
# as comp4.bmp
my $bmp4 = Imager->new;
ok($bmp4->read(file=>'testimg/comp4.bmp'), "reading 4-bit bmp!");
- $diff = i_img_diff($img4->{IMG}, $bmp4->{IMG});
+ my $diff = i_img_diff($img4->{IMG}, $bmp4->{IMG});
print "# diff $diff\n";
ok($diff == 0, "image mismatch");
my $img8 = Imager->new;
ok(defined $warning && $warning =~ /unknown field with tag 28712/,
"check that warning tag set and correct");
}
-
-sub ok {
- my ($ok, $msg) = @_;
-
- if ($ok) {
- print "ok ",$test_num++,"\n";
- }
- else {
- print "not ok ", $test_num++," # line ",(caller)[2]," $msg\n";
- }
-}
projects / imager.git / commitdiff