From: Tony Cook Date: Tue, 8 Mar 2005 08:02:59 +0000 (+0000) Subject: - calling the read() method for a format not included in the Imager build, X-Git-Tag: Imager-0.48^2~208 X-Git-Url: http://git.imager.perl.org/imager.git/commitdiff_plain/66614d6e6ba6b666458e511e186000372c74ab02 - 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 --- diff --git a/Changes b/Changes index 0479119b..a394873a 100644 --- a/Changes +++ b/Changes @@ -1023,6 +1023,14 @@ Revision history for Perl extension Imager. - 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 ================================================================= diff --git a/Imager.pm b/Imager.pm index 5c70b49a..cf8e6351 100644 --- a/Imager.pm +++ b/Imager.pm @@ -1089,23 +1089,22 @@ sub read { 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 ); diff --git a/fileformatdocs/bmp.txt b/fileformatdocs/bmp.txt new file mode 100644 index 00000000..1e37264a --- /dev/null +++ b/fileformatdocs/bmp.txt @@ -0,0 +1,454 @@ +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 diff --git a/fileformatdocs/other.txt b/fileformatdocs/other.txt new file mode 100644 index 00000000..12f91ed6 --- /dev/null +++ b/fileformatdocs/other.txt @@ -0,0 +1,8 @@ +# 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) diff --git a/t/Test/Builder.pm b/t/Test/Builder.pm new file mode 100644 index 00000000..6f3edd8c --- /dev/null +++ b/t/Test/Builder.pm @@ -0,0 +1,1408 @@ +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. + +=head2 Construction + +=over 4 + +=item B + + 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 +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 + + 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 + + $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 + + 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 + + $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 + + $plan = $Test->has_plan + +Find out whether a plan has been defined. $plan is either C (no plan has been set), C (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 + + $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 + + $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(<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 + + $Test->is_eq($got, $expected, $name); + +Like Test::More's is(). Checks if $got eq $expected. This is the +string version. + +=item B + + $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 < + + $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 + + $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 + + $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 + + $Test->unlike($this, qr/$regex/, $name); + $Test->unlike($this, '/$regex/', $name); + +Like Test::More's unlike(). Checks if $this B 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 + + $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 < + + $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 < + + $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 + + $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 + + $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 + + $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 + + $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 + + $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 + + $Test->no_header($no_header); + +If set to true, no "1..N" header will be printed. + +=item B + + $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 + + $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) it "passes through" the failure. + + return ok(...) || diag(...); + +=for blame transfer +Mark Fowler + +=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 + + $Test->output($fh); + $Test->output($file); + +Where normal "ok/not ok" test output should go. + +Defaults to STDOUT. + +=item B + + $Test->failure_output($fh); + $Test->failure_output($file); + +Where diagnostic output on test failures and diag() should go. + +Defaults to STDERR. + +=item B + + $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 + + 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 + + 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
+ + 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 + + 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 + + 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 < + + _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 +Eschwern@pobox.comE + +=head1 COPYRIGHT + +Copyright 2002 by chromatic Echromatic@wgz.orgE, + Michael G Schwern Eschwern@pobox.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + +1; diff --git a/t/Test/More.pm b/t/Test/More.pm new file mode 100644 index 00000000..d82f81d0 --- /dev/null +++ b/t/Test/More.pm @@ -0,0 +1,1248 @@ +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 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 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 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 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($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 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 + +=item B + + is ( $this, $that, $test_name ); + isnt( $this, $that, $test_name ); + +Similar to ok(), is() and isnt() compare their two arguments +with C and C 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 +function which is an alias of isnt(). + +=cut + +sub is ($$;$) { + $Test->is_eq(@_); +} + +sub isnt ($$;$) { + $Test->isnt_eq(@_); +} + +*isn't = \&isnt; + + +=item B + + like( $this, qr/that/, $test_name ); + +Similar to ok(), like() matches $this against the regex C. + +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) 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( $this, qr/that/, $test_name ); + +Works exactly as like(), only it checks if $this B match the +given pattern. + +=cut + +sub unlike { + $Test->unlike(@_); +} + + +=item B + + 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 will interfere: + + cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); + +=cut + +sub cmp_ok($$$;$) { + $Test->cmp_ok(@_); +} + + +=item B + + 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($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 <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 + +=item B + + 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. + +=over 4 + +=item B + + 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 with the mnemonic C. + +B 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 and C. + +=over 4 + +=item B + + 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 <import(\@imports); +USE + + my $ok = $Test->ok( !$@, "use $module;" ); + + unless( $ok ) { + chomp $@; + $Test->diag(< + + 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 <ok( !$@, "require $module;" ); + + unless( $ok ) { + chomp $@; + $Test->diag(<. + +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: { + 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. 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, 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: { + 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: { + 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 with and using C. 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 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, 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, 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 These are NOT well-tested on circular references. Nor am I +quite sure what will happen with filehandles. + +=over 4 + +=item B + + 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 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(\@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(\%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(\@this, \@that); + +Similar to eq_array(), except the order of the elements is B +important. This is a deep check, but the irrelevancy of order only +applies to the top level. + +B 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. + +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 + + 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 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 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 for more ways to test complex data structures. +And it plays well with Test::More. + +L is the old testing module. Its main benefit is that it has +been distributed with Perl since 5.004_05. + +L for details on how your test results are interpreted +by Perl. + +L describes a very featureful unit testing interface. + +L shows the idea of embedded testing. + +L is another approach to embedded testing. + + +=head1 AUTHORS + +Michael G Schwern Eschwern@pobox.comE 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 Eschwern@pobox.comE. + +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +See F + +=cut + +1; diff --git a/t/t101jpeg.t b/t/t101jpeg.t index 4366748e..fdb79d12 100644 --- a/t/t101jpeg.t +++ b/t/t101jpeg.t @@ -1,15 +1,17 @@ +#!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); @@ -18,18 +20,25 @@ i_conv($img,[0.1, 0.2, 0.4, 0.2, 0.1]); 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)); @@ -39,46 +48,31 @@ if (!i_has_format("jpeg")) { 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"; - } -} diff --git a/t/t102png.t b/t/t102png.t index bd81a16f..dc4dc065 100644 --- a/t/t102png.t +++ b/t/t102png.t @@ -1,5 +1,7 @@ #!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' @@ -9,9 +11,8 @@ use strict; # (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"; @@ -33,7 +34,16 @@ i_box_filled($timg, 0, 0, 20, 20, $green); 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); @@ -42,7 +52,7 @@ if (!i_has_format("png")) { 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"; @@ -50,22 +60,22 @@ if (!i_has_format("png")) { $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" @@ -73,11 +83,11 @@ if (!i_has_format("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 @@ -88,7 +98,7 @@ if (!i_has_format("png")) { $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" @@ -96,9 +106,9 @@ if (!i_has_format("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 < 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); @@ -27,33 +27,38 @@ my $trans = i_color_new(255, 0, 0, 127); 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 @@ -61,27 +66,26 @@ if (!i_has_format("gif")) { 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 @@ -92,15 +96,12 @@ if (!i_has_format("gif")) { open 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 @@ -109,40 +110,33 @@ if (!i_has_format("gif")) { # 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); @@ -160,17 +154,16 @@ if (!i_has_format("gif")) { 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; @@ -256,14 +249,10 @@ EOS # 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 @@ -271,11 +260,8 @@ EOS 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 @@ -287,11 +273,10 @@ EOS 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 @@ -313,45 +298,33 @@ EOS 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 @@ -359,27 +332,23 @@ EOS 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: $!"; @@ -388,49 +357,38 @@ EOS 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'; @@ -452,13 +410,13 @@ EOS } # 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"); @@ -467,39 +425,34 @@ EOS # 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); @@ -513,48 +466,46 @@ EOS 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 @@ -566,30 +517,19 @@ EOS # 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) = @_; @@ -602,18 +542,13 @@ sub test_readgif_cb { # 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; } @@ -667,14 +602,17 @@ PROLOG 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; } } @@ -685,7 +623,7 @@ PROLOG return $ok; } else { - return skip($testnum, $count, "could not create test script $script: $!"); + return skip("could not create test script $script: $!"); return 0; } } diff --git a/t/t106tiff.t b/t/t106tiff.t index 8c5b4921..3db8fc2b 100644 --- a/t/t106tiff.t +++ b/t/t106tiff.t @@ -1,15 +1,17 @@ #!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); @@ -21,13 +23,18 @@ my $trans = i_color_new(255, 0, 0, 127); 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 @@ -36,39 +43,32 @@ if (!i_has_format("tiff")) { 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"); @@ -78,11 +78,7 @@ if (!i_has_format("tiff")) { $odata = ; } - 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 @@ -103,63 +99,44 @@ if (!i_has_format("tiff")) { 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"; @@ -170,7 +147,7 @@ if (!i_has_format("tiff")) { # 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; @@ -357,14 +334,3 @@ if (!i_has_format("tiff")) { 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"; - } -}