- calling the read() method for a format not included in the Imager build,
authorTony Cook <tony@develop=help.com>
Tue, 8 Mar 2005 08:02:59 +0000 (08:02 +0000)
committerTony Cook <tony@develop=help.com>
Tue, 8 Mar 2005 08:02:59 +0000 (08:02 +0000)
  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

Changes
Imager.pm
fileformatdocs/bmp.txt [new file with mode: 0644]
fileformatdocs/other.txt [new file with mode: 0644]
t/Test/Builder.pm [new file with mode: 0644]
t/Test/More.pm [new file with mode: 0644]
t/t101jpeg.t
t/t102png.t
t/t105gif.t
t/t106tiff.t

diff --git a/Changes b/Changes
index 0479119..a394873 100644 (file)
--- 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
 
 =================================================================
 
index 5c70b49..cf8e635 100644 (file)
--- 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 (file)
index 0000000..1e37264
--- /dev/null
@@ -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 (file)
index 0000000..12f91ed
--- /dev/null
@@ -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 (file)
index 0000000..6f3edd8
--- /dev/null
@@ -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<which can
+work together>.
+
+=head2 Construction
+
+=over 4
+
+=item B<new>
+
+  my $Test = Test::Builder->new;
+
+Returns a Test::Builder object representing the current state of the
+test.
+
+Since you only run one test per program, there is B<one and only one>
+Test::Builder object.  No matter how many times you call new(), you're
+getting the same object.  (This is called a singleton).
+
+=cut
+
+my $Test;
+sub new {
+    my($class) = shift;
+    $Test ||= bless ['Move along, nothing to see here'], $class;
+    return $Test;
+}
+
+=back
+
+=head2 Setting up tests
+
+These methods are for setting up tests and declaring how many there
+are.  You usually only want to call one of these methods.
+
+=over 4
+
+=item B<exported_to>
+
+  my $pack = $Test->exported_to;
+  $Test->exported_to($pack);
+
+Tells Test::Builder what package you exported your functions to.
+This is important for getting TODO tests right.
+
+=cut
+
+my $Exported_To;
+sub exported_to {
+    my($self, $pack) = @_;
+
+    if( defined $pack ) {
+        $Exported_To = $pack;
+    }
+    return $Exported_To;
+}
+
+=item B<plan>
+
+  $Test->plan('no_plan');
+  $Test->plan( skip_all => $reason );
+  $Test->plan( tests => $num_tests );
+
+A convenient way to set up your tests.  Call this and Test::Builder
+will print the appropriate headers and take the appropriate actions.
+
+If you call plan(), don't call any of the other methods below.
+
+=cut
+
+sub plan {
+    my($self, $cmd, $arg) = @_;
+
+    return unless $cmd;
+
+    if( $Have_Plan ) {
+        die sprintf "You tried to plan twice!  Second plan at %s line %d\n",
+          ($self->caller)[1,2];
+    }
+
+    if( $cmd eq 'no_plan' ) {
+        $self->no_plan;
+    }
+    elsif( $cmd eq 'skip_all' ) {
+        return $self->skip_all($arg);
+    }
+    elsif( $cmd eq 'tests' ) {
+        if( $arg ) {
+            return $self->expected_tests($arg);
+        }
+        elsif( !defined $arg ) {
+            die "Got an undefined number of tests.  Looks like you tried to ".
+                "say how many tests you plan to run but made a mistake.\n";
+        }
+        elsif( !$arg ) {
+            die "You said to run 0 tests!  You've got to run something.\n";
+        }
+    }
+    else {
+        require Carp;
+        my @args = grep { defined } ($cmd, $arg);
+        Carp::croak("plan() doesn't understand @args");
+    }
+
+    return 1;
+}
+
+=item B<expected_tests>
+
+    my $max = $Test->expected_tests;
+    $Test->expected_tests($max);
+
+Gets/sets the # of tests we expect this test to run and prints out
+the appropriate headers.
+
+=cut
+
+my $Expected_Tests = 0;
+sub expected_tests {
+    my($self, $max) = @_;
+
+    if( defined $max ) {
+        $Expected_Tests = $max;
+        $Have_Plan      = 1;
+
+        $self->_print("1..$max\n") unless $self->no_header;
+    }
+    return $Expected_Tests;
+}
+
+
+=item B<no_plan>
+
+  $Test->no_plan;
+
+Declares that this test will run an indeterminate # of tests.
+
+=cut
+
+my($No_Plan) = 0;
+sub no_plan {
+    $No_Plan    = 1;
+    $Have_Plan  = 1;
+}
+
+=item B<has_plan>
+
+  $plan = $Test->has_plan
+  
+Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
+
+=cut
+
+sub has_plan {
+       return($Expected_Tests) if $Expected_Tests;
+       return('no_plan') if $No_Plan;
+       return(undef);
+};
+
+
+=item B<skip_all>
+
+  $Test->skip_all;
+  $Test->skip_all($reason);
+
+Skips all the tests, using the given $reason.  Exits immediately with 0.
+
+=cut
+
+my $Skip_All = 0;
+sub skip_all {
+    my($self, $reason) = @_;
+
+    my $out = "1..0";
+    $out .= " # Skip $reason" if $reason;
+    $out .= "\n";
+
+    $Skip_All = 1;
+
+    $self->_print($out) unless $self->no_header;
+    exit(0);
+}
+
+=back
+
+=head2 Running tests
+
+These actually run the tests, analogous to the functions in
+Test::More.
+
+$name is always optional.
+
+=over 4
+
+=item B<ok>
+
+  $Test->ok($test, $name);
+
+Your basic test.  Pass if $test is true, fail if $test is false.  Just
+like Test::Simple's ok().
+
+=cut
+
+sub ok {
+    my($self, $test, $name) = @_;
+
+    # $test might contain an object which we don't want to accidentally
+    # store, so we turn it into a boolean.
+    $test = $test ? 1 : 0;
+
+    unless( $Have_Plan ) {
+        require Carp;
+        Carp::croak("You tried to run a test without a plan!  Gotta have a plan.");
+    }
+
+    lock $Curr_Test;
+    $Curr_Test++;
+
+    $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
+    You named your test '$name'.  You shouldn't use numbers for your test names.
+    Very confusing.
+ERR
+
+    my($pack, $file, $line) = $self->caller;
+
+    my $todo = $self->todo($pack);
+
+    my $out;
+    my $result = {};
+    share($result);
+
+    unless( $test ) {
+        $out .= "not ";
+        @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
+    }
+    else {
+        @$result{ 'ok', 'actual_ok' } = ( 1, $test );
+    }
+
+    $out .= "ok";
+    $out .= " $Curr_Test" if $self->use_numbers;
+
+    if( defined $name ) {
+        $name =~ s|#|\\#|g;     # # in a name can confuse Test::Harness.
+        $out   .= " - $name";
+        $result->{name} = $name;
+    }
+    else {
+        $result->{name} = '';
+    }
+
+    if( $todo ) {
+        my $what_todo = $todo;
+        $out   .= " # TODO $what_todo";
+        $result->{reason} = $what_todo;
+        $result->{type}   = 'todo';
+    }
+    else {
+        $result->{reason} = '';
+        $result->{type}   = '';
+    }
+
+    $Test_Results[$Curr_Test-1] = $result;
+    $out .= "\n";
+
+    $self->_print($out);
+
+    unless( $test ) {
+        my $msg = $todo ? "Failed (TODO)" : "Failed";
+        $self->diag("    $msg test ($file at line $line)\n");
+    } 
+
+    return $test ? 1 : 0;
+}
+
+=item B<is_eq>
+
+  $Test->is_eq($got, $expected, $name);
+
+Like Test::More's is().  Checks if $got eq $expected.  This is the
+string version.
+
+=item B<is_num>
+
+  $Test->is_num($got, $expected, $name);
+
+Like Test::More's is().  Checks if $got == $expected.  This is the
+numeric version.
+
+=cut
+
+sub is_eq {
+    my($self, $got, $expect, $name) = @_;
+    local $Level = $Level + 1;
+
+    if( !defined $got || !defined $expect ) {
+        # undef only matches undef and nothing else
+        my $test = !defined $got && !defined $expect;
+
+        $self->ok($test, $name);
+        $self->_is_diag($got, 'eq', $expect) unless $test;
+        return $test;
+    }
+
+    return $self->cmp_ok($got, 'eq', $expect, $name);
+}
+
+sub is_num {
+    my($self, $got, $expect, $name) = @_;
+    local $Level = $Level + 1;
+
+    if( !defined $got || !defined $expect ) {
+        # undef only matches undef and nothing else
+        my $test = !defined $got && !defined $expect;
+
+        $self->ok($test, $name);
+        $self->_is_diag($got, '==', $expect) unless $test;
+        return $test;
+    }
+
+    return $self->cmp_ok($got, '==', $expect, $name);
+}
+
+sub _is_diag {
+    my($self, $got, $type, $expect) = @_;
+
+    foreach my $val (\$got, \$expect) {
+        if( defined $$val ) {
+            if( $type eq 'eq' ) {
+                # quote and force string context
+                $$val = "'$$val'"
+            }
+            else {
+                # force numeric context
+                $$val = $$val+0;
+            }
+        }
+        else {
+            $$val = 'undef';
+        }
+    }
+
+    return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
+         got: %s
+    expected: %s
+DIAGNOSTIC
+
+}    
+
+=item B<isnt_eq>
+
+  $Test->isnt_eq($got, $dont_expect, $name);
+
+Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
+the string version.
+
+=item B<isnt_num>
+
+  $Test->is_num($got, $dont_expect, $name);
+
+Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
+the numeric version.
+
+=cut
+
+sub isnt_eq {
+    my($self, $got, $dont_expect, $name) = @_;
+    local $Level = $Level + 1;
+
+    if( !defined $got || !defined $dont_expect ) {
+        # undef only matches undef and nothing else
+        my $test = defined $got || defined $dont_expect;
+
+        $self->ok($test, $name);
+        $self->_cmp_diag('ne', $got, $dont_expect) unless $test;
+        return $test;
+    }
+
+    return $self->cmp_ok($got, 'ne', $dont_expect, $name);
+}
+
+sub isnt_num {
+    my($self, $got, $dont_expect, $name) = @_;
+    local $Level = $Level + 1;
+
+    if( !defined $got || !defined $dont_expect ) {
+        # undef only matches undef and nothing else
+        my $test = defined $got || defined $dont_expect;
+
+        $self->ok($test, $name);
+        $self->_cmp_diag('!=', $got, $dont_expect) unless $test;
+        return $test;
+    }
+
+    return $self->cmp_ok($got, '!=', $dont_expect, $name);
+}
+
+
+=item B<like>
+
+  $Test->like($this, qr/$regex/, $name);
+  $Test->like($this, '/$regex/', $name);
+
+Like Test::More's like().  Checks if $this matches the given $regex.
+
+You'll want to avoid qr// if you want your tests to work before 5.005.
+
+=item B<unlike>
+
+  $Test->unlike($this, qr/$regex/, $name);
+  $Test->unlike($this, '/$regex/', $name);
+
+Like Test::More's unlike().  Checks if $this B<does not match> the
+given $regex.
+
+=cut
+
+sub like {
+    my($self, $this, $regex, $name) = @_;
+
+    local $Level = $Level + 1;
+    $self->_regex_ok($this, $regex, '=~', $name);
+}
+
+sub unlike {
+    my($self, $this, $regex, $name) = @_;
+
+    local $Level = $Level + 1;
+    $self->_regex_ok($this, $regex, '!~', $name);
+}
+
+=item B<maybe_regex>
+
+  $Test->maybe_regex(qr/$regex/);
+  $Test->maybe_regex('/$regex/');
+
+Convenience method for building testing functions that take regular
+expressions as arguments, but need to work before perl 5.005.
+
+Takes a quoted regular expression produced by qr//, or a string
+representing a regular expression.
+
+Returns a Perl value which may be used instead of the corresponding
+regular expression, or undef if it's argument is not recognised.
+
+For example, a version of like(), sans the useful diagnostic messages,
+could be written as:
+
+  sub laconic_like {
+      my ($self, $this, $regex, $name) = @_;
+      my $usable_regex = $self->maybe_regex($regex);
+      die "expecting regex, found '$regex'\n"
+          unless $usable_regex;
+      $self->ok($this =~ m/$usable_regex/, $name);
+  }
+
+=cut
+
+
+sub maybe_regex {
+       my ($self, $regex) = @_;
+    my $usable_regex = undef;
+    if( ref $regex eq 'Regexp' ) {
+        $usable_regex = $regex;
+    }
+    # Check if it looks like '/foo/'
+    elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
+        $usable_regex = length $opts ? "(?$opts)$re" : $re;
+    };
+    return($usable_regex)
+};
+
+sub _regex_ok {
+    my($self, $this, $regex, $cmp, $name) = @_;
+
+    local $Level = $Level + 1;
+
+    my $ok = 0;
+    my $usable_regex = $self->maybe_regex($regex);
+    unless (defined $usable_regex) {
+        $ok = $self->ok( 0, $name );
+        $self->diag("    '$regex' doesn't look much like a regex to me.");
+        return $ok;
+    }
+
+    {
+        local $^W = 0;
+        my $test = $this =~ /$usable_regex/ ? 1 : 0;
+        $test = !$test if $cmp eq '!~';
+        $ok = $self->ok( $test, $name );
+    }
+
+    unless( $ok ) {
+        $this = defined $this ? "'$this'" : 'undef';
+        my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+        $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
+                  %s
+    %13s '%s'
+DIAGNOSTIC
+
+    }
+
+    return $ok;
+}
+
+=item B<cmp_ok>
+
+  $Test->cmp_ok($this, $type, $that, $name);
+
+Works just like Test::More's cmp_ok().
+
+    $Test->cmp_ok($big_num, '!=', $other_big_num);
+
+=cut
+
+sub cmp_ok {
+    my($self, $got, $type, $expect, $name) = @_;
+
+    my $test;
+    {
+        local $^W = 0;
+        local($@,$!);   # don't interfere with $@
+                        # eval() sometimes resets $!
+        $test = eval "\$got $type \$expect";
+    }
+    local $Level = $Level + 1;
+    my $ok = $self->ok($test, $name);
+
+    unless( $ok ) {
+        if( $type =~ /^(eq|==)$/ ) {
+            $self->_is_diag($got, $type, $expect);
+        }
+        else {
+            $self->_cmp_diag($got, $type, $expect);
+        }
+    }
+    return $ok;
+}
+
+sub _cmp_diag {
+    my($self, $got, $type, $expect) = @_;
+    
+    $got    = defined $got    ? "'$got'"    : 'undef';
+    $expect = defined $expect ? "'$expect'" : 'undef';
+    return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
+    %s
+        %s
+    %s
+DIAGNOSTIC
+}
+
+=item B<BAILOUT>
+
+    $Test->BAILOUT($reason);
+
+Indicates to the Test::Harness that things are going so badly all
+testing should terminate.  This includes running any additional test
+scripts.
+
+It will exit with 255.
+
+=cut
+
+sub BAILOUT {
+    my($self, $reason) = @_;
+
+    $self->_print("Bail out!  $reason");
+    exit 255;
+}
+
+=item B<skip>
+
+    $Test->skip;
+    $Test->skip($why);
+
+Skips the current test, reporting $why.
+
+=cut
+
+sub skip {
+    my($self, $why) = @_;
+    $why ||= '';
+
+    unless( $Have_Plan ) {
+        require Carp;
+        Carp::croak("You tried to run tests without a plan!  Gotta have a plan.");
+    }
+
+    lock($Curr_Test);
+    $Curr_Test++;
+
+    my %result;
+    share(%result);
+    %result = (
+        'ok'      => 1,
+        actual_ok => 1,
+        name      => '',
+        type      => 'skip',
+        reason    => $why,
+    );
+    $Test_Results[$Curr_Test-1] = \%result;
+
+    my $out = "ok";
+    $out   .= " $Curr_Test" if $self->use_numbers;
+    $out   .= " # skip $why\n";
+
+    $Test->_print($out);
+
+    return 1;
+}
+
+
+=item B<todo_skip>
+
+  $Test->todo_skip;
+  $Test->todo_skip($why);
+
+Like skip(), only it will declare the test as failing and TODO.  Similar
+to
+
+    print "not ok $tnum # TODO $why\n";
+
+=cut
+
+sub todo_skip {
+    my($self, $why) = @_;
+    $why ||= '';
+
+    unless( $Have_Plan ) {
+        require Carp;
+        Carp::croak("You tried to run tests without a plan!  Gotta have a plan.");
+    }
+
+    lock($Curr_Test);
+    $Curr_Test++;
+
+    my %result;
+    share(%result);
+    %result = (
+        'ok'      => 1,
+        actual_ok => 0,
+        name      => '',
+        type      => 'todo_skip',
+        reason    => $why,
+    );
+
+    $Test_Results[$Curr_Test-1] = \%result;
+
+    my $out = "not ok";
+    $out   .= " $Curr_Test" if $self->use_numbers;
+    $out   .= " # TODO & SKIP $why\n";
+
+    $Test->_print($out);
+
+    return 1;
+}
+
+
+=begin _unimplemented
+
+=item B<skip_rest>
+
+  $Test->skip_rest;
+  $Test->skip_rest($reason);
+
+Like skip(), only it skips all the rest of the tests you plan to run
+and terminates the test.
+
+If you're running under no_plan, it skips once and terminates the
+test.
+
+=end _unimplemented
+
+=back
+
+
+=head2 Test style
+
+=over 4
+
+=item B<level>
+
+    $Test->level($how_high);
+
+How far up the call stack should $Test look when reporting where the
+test failed.
+
+Defaults to 1.
+
+Setting $Test::Builder::Level overrides.  This is typically useful
+localized:
+
+    {
+        local $Test::Builder::Level = 2;
+        $Test->ok($test);
+    }
+
+=cut
+
+sub level {
+    my($self, $level) = @_;
+
+    if( defined $level ) {
+        $Level = $level;
+    }
+    return $Level;
+}
+
+$CLASS->level(1);
+
+
+=item B<use_numbers>
+
+    $Test->use_numbers($on_or_off);
+
+Whether or not the test should output numbers.  That is, this if true:
+
+  ok 1
+  ok 2
+  ok 3
+
+or this if false
+
+  ok
+  ok
+  ok
+
+Most useful when you can't depend on the test output order, such as
+when threads or forking is involved.
+
+Test::Harness will accept either, but avoid mixing the two styles.
+
+Defaults to on.
+
+=cut
+
+my $Use_Nums = 1;
+sub use_numbers {
+    my($self, $use_nums) = @_;
+
+    if( defined $use_nums ) {
+        $Use_Nums = $use_nums;
+    }
+    return $Use_Nums;
+}
+
+=item B<no_header>
+
+    $Test->no_header($no_header);
+
+If set to true, no "1..N" header will be printed.
+
+=item B<no_ending>
+
+    $Test->no_ending($no_ending);
+
+Normally, Test::Builder does some extra diagnostics when the test
+ends.  It also changes the exit code as described in Test::Simple.
+
+If this is true, none of that will be done.
+
+=cut
+
+my($No_Header, $No_Ending) = (0,0);
+sub no_header {
+    my($self, $no_header) = @_;
+
+    if( defined $no_header ) {
+        $No_Header = $no_header;
+    }
+    return $No_Header;
+}
+
+sub no_ending {
+    my($self, $no_ending) = @_;
+
+    if( defined $no_ending ) {
+        $No_Ending = $no_ending;
+    }
+    return $No_Ending;
+}
+
+
+=back
+
+=head2 Output
+
+Controlling where the test output goes.
+
+It's ok for your test to change where STDOUT and STDERR point to,
+Test::Builder's default output settings will not be affected.
+
+=over 4
+
+=item B<diag>
+
+    $Test->diag(@msgs);
+
+Prints out the given $message.  Normally, it uses the failure_output()
+handle, but if this is for a TODO test, the todo_output() handle is
+used.
+
+Output will be indented and marked with a # so as not to interfere
+with test output.  A newline will be put on the end if there isn't one
+already.
+
+We encourage using this rather than calling print directly.
+
+Returns false.  Why?  Because diag() is often used in conjunction with
+a failing test (C<ok() || diag()>) it "passes through" the failure.
+
+    return ok(...) || diag(...);
+
+=for blame transfer
+Mark Fowler <mark@twoshortplanks.com>
+
+=cut
+
+sub diag {
+    my($self, @msgs) = @_;
+    return unless @msgs;
+
+    # Prevent printing headers when compiling (i.e. -c)
+    return if $^C;
+
+    # Escape each line with a #.
+    foreach (@msgs) {
+        $_ = 'undef' unless defined;
+        s/^/# /gms;
+    }
+
+    push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
+
+    local $Level = $Level + 1;
+    my $fh = $self->todo ? $self->todo_output : $self->failure_output;
+    local($\, $", $,) = (undef, ' ', '');
+    print $fh @msgs;
+
+    return 0;
+}
+
+=begin _private
+
+=item B<_print>
+
+    $Test->_print(@msgs);
+
+Prints to the output() filehandle.
+
+=end _private
+
+=cut
+
+sub _print {
+    my($self, @msgs) = @_;
+
+    # Prevent printing headers when only compiling.  Mostly for when
+    # tests are deparsed with B::Deparse
+    return if $^C;
+
+    local($\, $", $,) = (undef, ' ', '');
+    my $fh = $self->output;
+
+    # Escape each line after the first with a # so we don't
+    # confuse Test::Harness.
+    foreach (@msgs) {
+        s/\n(.)/\n# $1/sg;
+    }
+
+    push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
+
+    print $fh @msgs;
+}
+
+
+=item B<output>
+
+    $Test->output($fh);
+    $Test->output($file);
+
+Where normal "ok/not ok" test output should go.
+
+Defaults to STDOUT.
+
+=item B<failure_output>
+
+    $Test->failure_output($fh);
+    $Test->failure_output($file);
+
+Where diagnostic output on test failures and diag() should go.
+
+Defaults to STDERR.
+
+=item B<todo_output>
+
+    $Test->todo_output($fh);
+    $Test->todo_output($file);
+
+Where diagnostics about todo test failures and diag() should go.
+
+Defaults to STDOUT.
+
+=cut
+
+my($Out_FH, $Fail_FH, $Todo_FH);
+sub output {
+    my($self, $fh) = @_;
+
+    if( defined $fh ) {
+        $Out_FH = _new_fh($fh);
+    }
+    return $Out_FH;
+}
+
+sub failure_output {
+    my($self, $fh) = @_;
+
+    if( defined $fh ) {
+        $Fail_FH = _new_fh($fh);
+    }
+    return $Fail_FH;
+}
+
+sub todo_output {
+    my($self, $fh) = @_;
+
+    if( defined $fh ) {
+        $Todo_FH = _new_fh($fh);
+    }
+    return $Todo_FH;
+}
+
+sub _new_fh {
+    my($file_or_fh) = shift;
+
+    my $fh;
+    unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
+        $fh = do { local *FH };
+        open $fh, ">$file_or_fh" or 
+            die "Can't open test output log $file_or_fh: $!";
+    }
+    else {
+        $fh = $file_or_fh;
+    }
+
+    return $fh;
+}
+
+unless( $^C ) {
+    # We dup STDOUT and STDERR so people can change them in their
+    # test suites while still getting normal test output.
+    open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";
+    open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";
+
+    # Set everything to unbuffered else plain prints to STDOUT will
+    # come out in the wrong order from our own prints.
+    _autoflush(\*TESTOUT);
+    _autoflush(\*STDOUT);
+    _autoflush(\*TESTERR);
+    _autoflush(\*STDERR);
+
+    $CLASS->output(\*TESTOUT);
+    $CLASS->failure_output(\*TESTERR);
+    $CLASS->todo_output(\*TESTOUT);
+}
+
+sub _autoflush {
+    my($fh) = shift;
+    my $old_fh = select $fh;
+    $| = 1;
+    select $old_fh;
+}
+
+
+=back
+
+
+=head2 Test Status and Info
+
+=over 4
+
+=item B<current_test>
+
+    my $curr_test = $Test->current_test;
+    $Test->current_test($num);
+
+Gets/sets the current test # we're on.
+
+You usually shouldn't have to set this.
+
+=cut
+
+sub current_test {
+    my($self, $num) = @_;
+
+    lock($Curr_Test);
+    if( defined $num ) {
+        unless( $Have_Plan ) {
+            require Carp;
+            Carp::croak("Can't change the current test number without a plan!");
+        }
+
+        $Curr_Test = $num;
+        if( $num > @Test_Results ) {
+            my $start = @Test_Results ? $#Test_Results + 1 : 0;
+            for ($start..$num-1) {
+                my %result;
+                share(%result);
+                %result = ( ok        => 1, 
+                            actual_ok => undef, 
+                            reason    => 'incrementing test number', 
+                            type      => 'unknown', 
+                            name      => undef 
+                          );
+                $Test_Results[$_] = \%result;
+            }
+        }
+    }
+    return $Curr_Test;
+}
+
+
+=item B<summary>
+
+    my @tests = $Test->summary;
+
+A simple summary of the tests so far.  True for pass, false for fail.
+This is a logical pass/fail, so todos are passes.
+
+Of course, test #1 is $tests[0], etc...
+
+=cut
+
+sub summary {
+    my($self) = shift;
+
+    return map { $_->{'ok'} } @Test_Results;
+}
+
+=item B<details>
+
+    my @tests = $Test->details;
+
+Like summary(), but with a lot more detail.
+
+    $tests[$test_num - 1] = 
+            { 'ok'       => is the test considered a pass?
+              actual_ok  => did it literally say 'ok'?
+              name       => name of the test (if any)
+              type       => type of test (if any, see below).
+              reason     => reason for the above (if any)
+            };
+
+'ok' is true if Test::Harness will consider the test to be a pass.
+
+'actual_ok' is a reflection of whether or not the test literally
+printed 'ok' or 'not ok'.  This is for examining the result of 'todo'
+tests.  
+
+'name' is the name of the test.
+
+'type' indicates if it was a special test.  Normal tests have a type
+of ''.  Type can be one of the following:
+
+    skip        see skip()
+    todo        see todo()
+    todo_skip   see todo_skip()
+    unknown     see below
+
+Sometimes the Test::Builder test counter is incremented without it
+printing any test output, for example, when current_test() is changed.
+In these cases, Test::Builder doesn't know the result of the test, so
+it's type is 'unkown'.  These details for these tests are filled in.
+They are considered ok, but the name and actual_ok is left undef.
+
+For example "not ok 23 - hole count # TODO insufficient donuts" would
+result in this structure:
+
+    $tests[22] =    # 23 - 1, since arrays start from 0.
+      { ok        => 1,   # logically, the test passed since it's todo
+        actual_ok => 0,   # in absolute terms, it failed
+        name      => 'hole count',
+        type      => 'todo',
+        reason    => 'insufficient donuts'
+      };
+
+=cut
+
+sub details {
+    return @Test_Results;
+}
+
+=item B<todo>
+
+    my $todo_reason = $Test->todo;
+    my $todo_reason = $Test->todo($pack);
+
+todo() looks for a $TODO variable in your tests.  If set, all tests
+will be considered 'todo' (see Test::More and Test::Harness for
+details).  Returns the reason (ie. the value of $TODO) if running as
+todo tests, false otherwise.
+
+todo() is pretty part about finding the right package to look for
+$TODO in.  It uses the exported_to() package to find it.  If that's
+not set, it's pretty good at guessing the right package to look at.
+
+Sometimes there is some confusion about where todo() should be looking
+for the $TODO variable.  If you want to be sure, tell it explicitly
+what $pack to use.
+
+=cut
+
+sub todo {
+    my($self, $pack) = @_;
+
+    $pack = $pack || $self->exported_to || $self->caller(1);
+
+    no strict 'refs';
+    return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
+                                     : 0;
+}
+
+=item B<caller>
+
+    my $package = $Test->caller;
+    my($pack, $file, $line) = $Test->caller;
+    my($pack, $file, $line) = $Test->caller($height);
+
+Like the normal caller(), except it reports according to your level().
+
+=cut
+
+sub caller {
+    my($self, $height) = @_;
+    $height ||= 0;
+
+    my @caller = CORE::caller($self->level + $height + 1);
+    return wantarray ? @caller : $caller[0];
+}
+
+=back
+
+=cut
+
+=begin _private
+
+=over 4
+
+=item B<_sanity_check>
+
+  _sanity_check();
+
+Runs a bunch of end of test sanity checks to make sure reality came
+through ok.  If anything is wrong it will die with a fairly friendly
+error message.
+
+=cut
+
+#'#
+sub _sanity_check {
+    _whoa($Curr_Test < 0,  'Says here you ran a negative number of tests!');
+    _whoa(!$Have_Plan and $Curr_Test, 
+          'Somehow your tests ran without a plan!');
+    _whoa($Curr_Test != @Test_Results,
+          'Somehow you got a different number of results than tests ran!');
+}
+
+=item B<_whoa>
+
+  _whoa($check, $description);
+
+A sanity check, similar to assert().  If the $check is true, something
+has gone horribly wrong.  It will die with the given $description and
+a note to contact the author.
+
+=cut
+
+sub _whoa {
+    my($check, $desc) = @_;
+    if( $check ) {
+        die <<WHOA;
+WHOA!  $desc
+This should never happen!  Please contact the author immediately!
+WHOA
+    }
+}
+
+=item B<_my_exit>
+
+  _my_exit($exit_num);
+
+Perl seems to have some trouble with exiting inside an END block.  5.005_03
+and 5.6.1 both seem to do odd things.  Instead, this function edits $?
+directly.  It should ONLY be called from inside an END block.  It
+doesn't actually exit, that's your job.
+
+=cut
+
+sub _my_exit {
+    $? = $_[0];
+
+    return 1;
+}
+
+
+=back
+
+=end _private
+
+=cut
+
+$SIG{__DIE__} = sub {
+    # We don't want to muck with death in an eval, but $^S isn't
+    # totally reliable.  5.005_03 and 5.6.1 both do the wrong thing
+    # with it.  Instead, we use caller.  This also means it runs under
+    # 5.004!
+    my $in_eval = 0;
+    for( my $stack = 1;  my $sub = (CORE::caller($stack))[3];  $stack++ ) {
+        $in_eval = 1 if $sub =~ /^\(eval\)/;
+    }
+    $Test_Died = 1 unless $in_eval;
+};
+
+sub _ending {
+    my $self = shift;
+
+    _sanity_check();
+
+    # Don't bother with an ending if this is a forked copy.  Only the parent
+    # should do the ending.
+    do{ _my_exit($?) && return } if $Original_Pid != $$;
+
+    # Bailout if plan() was never called.  This is so
+    # "require Test::Simple" doesn't puke.
+    do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died;
+
+    # Figure out if we passed or failed and print helpful messages.
+    if( @Test_Results ) {
+        # The plan?  We have no plan.
+        if( $No_Plan ) {
+            $self->_print("1..$Curr_Test\n") unless $self->no_header;
+            $Expected_Tests = $Curr_Test;
+        }
+
+        # 5.8.0 threads bug.  Shared arrays will not be auto-extended 
+        # by a slice.  Worse, we have to fill in every entry else
+        # we'll get an "Invalid value for shared scalar" error
+        for my $idx ($#Test_Results..$Expected_Tests-1) {
+            my %empty_result = ();
+            share(%empty_result);
+            $Test_Results[$idx] = \%empty_result
+              unless defined $Test_Results[$idx];
+        }
+
+        my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1];
+        $num_failed += abs($Expected_Tests - @Test_Results);
+
+        if( $Curr_Test < $Expected_Tests ) {
+            $self->diag(<<"FAIL");
+Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
+FAIL
+        }
+        elsif( $Curr_Test > $Expected_Tests ) {
+            my $num_extra = $Curr_Test - $Expected_Tests;
+            $self->diag(<<"FAIL");
+Looks like you planned $Expected_Tests tests but ran $num_extra extra.
+FAIL
+        }
+        elsif ( $num_failed ) {
+            $self->diag(<<"FAIL");
+Looks like you failed $num_failed tests of $Expected_Tests.
+FAIL
+        }
+
+        if( $Test_Died ) {
+            $self->diag(<<"FAIL");
+Looks like your test died just after $Curr_Test.
+FAIL
+
+            _my_exit( 255 ) && return;
+        }
+
+        _my_exit( $num_failed <= 254 ? $num_failed : 254  ) && return;
+    }
+    elsif ( $Skip_All ) {
+        _my_exit( 0 ) && return;
+    }
+    elsif ( $Test_Died ) {
+        $self->diag(<<'FAIL');
+Looks like your test died before it could output anything.
+FAIL
+    }
+    else {
+        $self->diag("No tests run!\n");
+        _my_exit( 255 ) && return;
+    }
+}
+
+END {
+    $Test->_ending if defined $Test and !$Test->no_ending;
+}
+
+=head1 THREADS
+
+In perl 5.8.0 and later, Test::Builder is thread-safe.  The test
+number is shared amongst all threads.  This means if one thread sets
+the test number using current_test() they will all be effected.
+
+=head1 EXAMPLES
+
+CPAN can provide the best examples.  Test::Simple, Test::More,
+Test::Exception and Test::Differences all use Test::Builder.
+
+=head1 SEE ALSO
+
+Test::Simple, Test::More, Test::Harness
+
+=head1 AUTHORS
+
+Original code by chromatic, maintained by Michael G Schwern
+E<lt>schwern@pobox.comE<gt>
+
+=head1 COPYRIGHT
+
+Copyright 2002 by chromatic E<lt>chromatic@wgz.orgE<gt>,
+                  Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or 
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
diff --git a/t/Test/More.pm b/t/Test/More.pm
new file mode 100644 (file)
index 0000000..d82f81d
--- /dev/null
@@ -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<STOP!> If you're just getting started writing tests, have a look at
+Test::Simple first.  This is a drop in replacement for Test::Simple
+which you can switch to once you get the hang of basic testing.
+
+The purpose of this module is to provide a wide range of testing
+utilities.  Various ways to say "ok" with better diagnostics,
+facilities to skip tests, test future features and compare complicated
+data structures.  While you can do almost anything with a simple
+C<ok()> function, it doesn't provide good diagnostic output.
+
+
+=head2 I love it when a plan comes together
+
+Before anything else, you need a testing plan.  This basically declares
+how many tests your script is going to run to protect against premature
+failure.
+
+The preferred way to do this is to declare a plan when you C<use Test::More>.
+
+  use Test::More tests => $Num_Tests;
+
+There are rare cases when you will not know beforehand how many tests
+your script is going to run.  In this case, you can declare that you
+have no plan.  (Try to avoid using this as it weakens your test.)
+
+  use Test::More qw(no_plan);
+
+In some cases, you'll want to completely skip an entire testing script.
+
+  use Test::More skip_all => $skip_reason;
+
+Your script will declare a skip with the reason why you skipped and
+exit immediately with a zero (success).  See L<Test::Harness> for
+details.
+
+If you want to control what functions Test::More will export, you
+have to use the 'import' option.  For example, to import everything
+but 'fail', you'd do:
+
+  use Test::More tests => 23, import => ['!fail'];
+
+Alternatively, you can use the plan() function.  Useful for when you
+have to calculate the number of tests.
+
+  use Test::More;
+  plan tests => keys %Stuff * 3;
+
+or for deciding between running the tests at all:
+
+  use Test::More;
+  if( $^O eq 'MacOS' ) {
+      plan skip_all => 'Test irrelevant on MacOS';
+  }
+  else {
+      plan tests => 42;
+  }
+
+=cut
+
+sub plan {
+    my(@plan) = @_;
+
+    my $caller = caller;
+
+    $Test->exported_to($caller);
+
+    my @imports = ();
+    foreach my $idx (0..$#plan) {
+        if( $plan[$idx] eq 'import' ) {
+            my($tag, $imports) = splice @plan, $idx, 2;
+            @imports = @$imports;
+            last;
+        }
+    }
+
+    $Test->plan(@plan);
+
+    __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
+}
+
+sub import {
+    my($class) = shift;
+    goto &plan;
+}
+
+
+=head2 Test names
+
+By convention, each test is assigned a number in order.  This is
+largely done automatically for you.  However, it's often very useful to
+assign a name to each test.  Which would you rather see:
+
+  ok 4
+  not ok 5
+  ok 6
+
+or
+
+  ok 4 - basic multi-variable
+  not ok 5 - simple exponential
+  ok 6 - force == mass * acceleration
+
+The later gives you some idea of what failed.  It also makes it easier
+to find the test in your script, simply search for "simple
+exponential".
+
+All test functions take a name argument.  It's optional, but highly
+suggested that you use it.
+
+
+=head2 I'm ok, you're not ok.
+
+The basic purpose of this module is to print out either "ok #" or "not
+ok #" depending on if a given test succeeded or failed.  Everything
+else is just gravy.
+
+All of the following print "ok" or "not ok" depending on if the test
+succeeded or failed.  They all also return true or false,
+respectively.
+
+=over 4
+
+=item B<ok>
+
+  ok($this eq $that, $test_name);
+
+This simply evaluates any expression (C<$this eq $that> is just a
+simple example) and uses that to determine if the test succeeded or
+failed.  A true expression passes, a false one fails.  Very simple.
+
+For example:
+
+    ok( $exp{9} == 81,                   'simple exponential' );
+    ok( Film->can('db_Main'),            'set_db()' );
+    ok( $p->tests == 4,                  'saw tests' );
+    ok( !grep !defined $_, @items,       'items populated' );
+
+(Mnemonic:  "This is ok.")
+
+$test_name is a very short description of the test that will be printed
+out.  It makes it very easy to find a test in your script when it fails
+and gives others an idea of your intentions.  $test_name is optional,
+but we B<very> strongly encourage its use.
+
+Should an ok() fail, it will produce some diagnostics:
+
+    not ok 18 - sufficient mucus
+    #     Failed test 18 (foo.t at line 42)
+
+This is actually Test::Simple's ok() routine.
+
+=cut
+
+sub ok ($;$) {
+    my($test, $name) = @_;
+    $Test->ok($test, $name);
+}
+
+=item B<is>
+
+=item B<isnt>
+
+  is  ( $this, $that, $test_name );
+  isnt( $this, $that, $test_name );
+
+Similar to ok(), is() and isnt() compare their two arguments
+with C<eq> and C<ne> respectively and use the result of that to
+determine if the test succeeded or failed.  So these:
+
+    # Is the ultimate answer 42?
+    is( ultimate_answer(), 42,          "Meaning of Life" );
+
+    # $foo isn't empty
+    isnt( $foo, '',     "Got some foo" );
+
+are similar to these:
+
+    ok( ultimate_answer() eq 42,        "Meaning of Life" );
+    ok( $foo ne '',     "Got some foo" );
+
+(Mnemonic:  "This is that."  "This isn't that.")
+
+So why use these?  They produce better diagnostics on failure.  ok()
+cannot know what you are testing for (beyond the name), but is() and
+isnt() know what the test was and why it failed.  For example this
+test:
+
+    my $foo = 'waffle';  my $bar = 'yarblokos';
+    is( $foo, $bar,   'Is foo the same as bar?' );
+
+Will produce something like this:
+
+    not ok 17 - Is foo the same as bar?
+    #     Failed test (foo.t at line 139)
+    #          got: 'waffle'
+    #     expected: 'yarblokos'
+
+So you can figure out what went wrong without rerunning the test.
+
+You are encouraged to use is() and isnt() over ok() where possible,
+however do not be tempted to use them to find out if something is
+true or false!
+
+  # XXX BAD!  $pope->isa('Catholic') eq 1
+  is( $pope->isa('Catholic'), 1,        'Is the Pope Catholic?' );
+
+This does not check if C<$pope->isa('Catholic')> is true, it checks if
+it returns 1.  Very different.  Similar caveats exist for false and 0.
+In these cases, use ok().
+
+  ok( $pope->isa('Catholic') ),         'Is the Pope Catholic?' );
+
+For those grammatical pedants out there, there's an C<isn't()>
+function which is an alias of isnt().
+
+=cut
+
+sub is ($$;$) {
+    $Test->is_eq(@_);
+}
+
+sub isnt ($$;$) {
+    $Test->isnt_eq(@_);
+}
+
+*isn't = \&isnt;
+
+
+=item B<like>
+
+  like( $this, qr/that/, $test_name );
+
+Similar to ok(), like() matches $this against the regex C<qr/that/>.
+
+So this:
+
+    like($this, qr/that/, 'this is like that');
+
+is similar to:
+
+    ok( $this =~ /that/, 'this is like that');
+
+(Mnemonic "This is like that".)
+
+The second argument is a regular expression.  It may be given as a
+regex reference (i.e. C<qr//>) or (for better compatibility with older
+perls) as a string that looks like a regex (alternative delimiters are
+currently not supported):
+
+    like( $this, '/that/', 'this is like that' );
+
+Regex options may be placed on the end (C<'/that/i'>).
+
+Its advantages over ok() are similar to that of is() and isnt().  Better
+diagnostics on failure.
+
+=cut
+
+sub like ($$;$) {
+    $Test->like(@_);
+}
+
+
+=item B<unlike>
+
+  unlike( $this, qr/that/, $test_name );
+
+Works exactly as like(), only it checks if $this B<does not> match the
+given pattern.
+
+=cut
+
+sub unlike {
+    $Test->unlike(@_);
+}
+
+
+=item B<cmp_ok>
+
+  cmp_ok( $this, $op, $that, $test_name );
+
+Halfway between ok() and is() lies cmp_ok().  This allows you to
+compare two arguments using any binary perl operator.
+
+    # ok( $this eq $that );
+    cmp_ok( $this, 'eq', $that, 'this eq that' );
+
+    # ok( $this == $that );
+    cmp_ok( $this, '==', $that, 'this == that' );
+
+    # ok( $this && $that );
+    cmp_ok( $this, '&&', $that, 'this || that' );
+    ...etc...
+
+Its advantage over ok() is when the test fails you'll know what $this
+and $that were:
+
+    not ok 1
+    #     Failed test (foo.t at line 12)
+    #     '23'
+    #         &&
+    #     undef
+
+It's also useful in those cases where you are comparing numbers and
+is()'s use of C<eq> will interfere:
+
+    cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
+
+=cut
+
+sub cmp_ok($$$;$) {
+    $Test->cmp_ok(@_);
+}
+
+
+=item B<can_ok>
+
+  can_ok($module, @methods);
+  can_ok($object, @methods);
+
+Checks to make sure the $module or $object can do these @methods
+(works with functions, too).
+
+    can_ok('Foo', qw(this that whatever));
+
+is almost exactly like saying:
+
+    ok( Foo->can('this') && 
+        Foo->can('that') && 
+        Foo->can('whatever') 
+      );
+
+only without all the typing and with a better interface.  Handy for
+quickly testing an interface.
+
+No matter how many @methods you check, a single can_ok() call counts
+as one test.  If you desire otherwise, use:
+
+    foreach my $meth (@methods) {
+        can_ok('Foo', $meth);
+    }
+
+=cut
+
+sub can_ok ($@) {
+    my($proto, @methods) = @_;
+    my $class = ref $proto || $proto;
+
+    unless( @methods ) {
+        my $ok = $Test->ok( 0, "$class->can(...)" );
+        $Test->diag('    can_ok() called with no methods');
+        return $ok;
+    }
+
+    my @nok = ();
+    foreach my $method (@methods) {
+        local($!, $@);  # don't interfere with caller's $@
+                        # eval sometimes resets $!
+        eval { $proto->can($method) } || push @nok, $method;
+    }
+
+    my $name;
+    $name = @methods == 1 ? "$class->can('$methods[0]')" 
+                          : "$class->can(...)";
+    
+    my $ok = $Test->ok( !@nok, $name );
+
+    $Test->diag(map "    $class->can('$_') failed\n", @nok);
+
+    return $ok;
+}
+
+=item B<isa_ok>
+
+  isa_ok($object, $class, $object_name);
+  isa_ok($ref,    $type,  $ref_name);
+
+Checks to see if the given $object->isa($class).  Also checks to make
+sure the object was defined in the first place.  Handy for this sort
+of thing:
+
+    my $obj = Some::Module->new;
+    isa_ok( $obj, 'Some::Module' );
+
+where you'd otherwise have to write
+
+    my $obj = Some::Module->new;
+    ok( defined $obj && $obj->isa('Some::Module') );
+
+to safeguard against your test script blowing up.
+
+It works on references, too:
+
+    isa_ok( $array_ref, 'ARRAY' );
+
+The diagnostics of this test normally just refer to 'the object'.  If
+you'd like them to be more specific, you can supply an $object_name
+(for example 'Test customer').
+
+=cut
+
+sub isa_ok ($$;$) {
+    my($object, $class, $obj_name) = @_;
+
+    my $diag;
+    $obj_name = 'The object' unless defined $obj_name;
+    my $name = "$obj_name isa $class";
+    if( !defined $object ) {
+        $diag = "$obj_name isn't defined";
+    }
+    elsif( !ref $object ) {
+        $diag = "$obj_name isn't a reference";
+    }
+    else {
+        # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+        local($@, $!);  # eval sometimes resets $!
+        my $rslt = eval { $object->isa($class) };
+        if( $@ ) {
+            if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
+                if( !UNIVERSAL::isa($object, $class) ) {
+                    my $ref = ref $object;
+                    $diag = "$obj_name isn't a '$class' it's a '$ref'";
+                }
+            } else {
+                die <<WHOA;
+WHOA! I tried to call ->isa on your object and got some weird error.
+This should never happen.  Please contact the author immediately.
+Here's the error.
+$@
+WHOA
+            }
+        }
+        elsif( !$rslt ) {
+            my $ref = ref $object;
+            $diag = "$obj_name isn't a '$class' it's a '$ref'";
+        }
+    }
+            
+      
+
+    my $ok;
+    if( $diag ) {
+        $ok = $Test->ok( 0, $name );
+        $Test->diag("    $diag\n");
+    }
+    else {
+        $ok = $Test->ok( 1, $name );
+    }
+
+    return $ok;
+}
+
+
+=item B<pass>
+
+=item B<fail>
+
+  pass($test_name);
+  fail($test_name);
+
+Sometimes you just want to say that the tests have passed.  Usually
+the case is you've got some complicated condition that is difficult to
+wedge into an ok().  In this case, you can simply use pass() (to
+declare the test ok) or fail (for not ok).  They are synonyms for
+ok(1) and ok(0).
+
+Use these very, very, very sparingly.
+
+=cut
+
+sub pass (;$) {
+    $Test->ok(1, @_);
+}
+
+sub fail (;$) {
+    $Test->ok(0, @_);
+}
+
+=back
+
+=head2 Diagnostics
+
+If you pick the right test function, you'll usually get a good idea of
+what went wrong when it failed.  But sometimes it doesn't work out
+that way.  So here we have ways for you to write your own diagnostic
+messages which are safer than just C<print STDERR>.
+
+=over 4
+
+=item B<diag>
+
+  diag(@diagnostic_message);
+
+Prints a diagnostic message which is guaranteed not to interfere with
+test output.  Handy for this sort of thing:
+
+    ok( grep(/foo/, @users), "There's a foo user" ) or
+        diag("Since there's no foo, check that /etc/bar is set up right");
+
+which would produce:
+
+    not ok 42 - There's a foo user
+    #     Failed test (foo.t at line 52)
+    # Since there's no foo, check that /etc/bar is set up right.
+
+You might remember C<ok() or diag()> with the mnemonic C<open() or
+die()>.
+
+B<NOTE> The exact formatting of the diagnostic output is still
+changing, but it is guaranteed that whatever you throw at it it won't
+interfere with the test.
+
+=cut
+
+sub diag {
+    $Test->diag(@_);
+}
+
+
+=back
+
+=head2 Module tests
+
+You usually want to test if the module you're testing loads ok, rather
+than just vomiting if its load fails.  For such purposes we have
+C<use_ok> and C<require_ok>.
+
+=over 4
+
+=item B<use_ok>
+
+   BEGIN { use_ok($module); }
+   BEGIN { use_ok($module, @imports); }
+
+These simply use the given $module and test to make sure the load
+happened ok.  It's recommended that you run use_ok() inside a BEGIN
+block so its functions are exported at compile-time and prototypes are
+properly honored.
+
+If @imports are given, they are passed through to the use.  So this:
+
+   BEGIN { use_ok('Some::Module', qw(foo bar)) }
+
+is like doing this:
+
+   use Some::Module qw(foo bar);
+
+don't try to do this:
+
+   BEGIN {
+       use_ok('Some::Module');
+
+       ...some code that depends on the use...
+       ...happening at compile time...
+   }
+
+instead, you want:
+
+  BEGIN { use_ok('Some::Module') }
+  BEGIN { ...some code that depends on the use... }
+
+
+=cut
+
+sub use_ok ($;@) {
+    my($module, @imports) = @_;
+    @imports = () unless @imports;
+
+    my $pack = caller;
+
+    local($@,$!);   # eval sometimes interferes with $!
+    eval <<USE;
+package $pack;
+require $module;
+'$module'->import(\@imports);
+USE
+
+    my $ok = $Test->ok( !$@, "use $module;" );
+
+    unless( $ok ) {
+        chomp $@;
+        $Test->diag(<<DIAGNOSTIC);
+    Tried to use '$module'.
+    Error:  $@
+DIAGNOSTIC
+
+    }
+
+    return $ok;
+}
+
+=item B<require_ok>
+
+   require_ok($module);
+
+Like use_ok(), except it requires the $module.
+
+=cut
+
+sub require_ok ($) {
+    my($module) = shift;
+
+    my $pack = caller;
+
+    local($!, $@); # eval sometimes interferes with $!
+    eval <<REQUIRE;
+package $pack;
+require $module;
+REQUIRE
+
+    my $ok = $Test->ok( !$@, "require $module;" );
+
+    unless( $ok ) {
+        chomp $@;
+        $Test->diag(<<DIAGNOSTIC);
+    Tried to require '$module'.
+    Error:  $@
+DIAGNOSTIC
+
+    }
+
+    return $ok;
+}
+
+=back
+
+=head2 Conditional tests
+
+Sometimes running a test under certain conditions will cause the
+test script to die.  A certain function or method isn't implemented
+(such as fork() on MacOS), some resource isn't available (like a 
+net connection) or a module isn't available.  In these cases it's
+necessary to skip tests, or declare that they are supposed to fail
+but will work in the future (a todo test).
+
+For more details on the mechanics of skip and todo tests see
+L<Test::Harness>.
+
+The way Test::More handles this is with a named block.  Basically, a
+block of tests which can be skipped over or made todo.  It's best if I
+just show you...
+
+=over 4
+
+=item B<SKIP: BLOCK>
+
+  SKIP: {
+      skip $why, $how_many if $condition;
+
+      ...normal testing code goes here...
+  }
+
+This declares a block of tests that might be skipped, $how_many tests
+there are, $why and under what $condition to skip them.  An example is
+the easiest way to illustrate:
+
+    SKIP: {
+        eval { require HTML::Lint };
+
+        skip "HTML::Lint not installed", 2 if $@;
+
+        my $lint = new HTML::Lint;
+        isa_ok( $lint, "HTML::Lint" );
+
+        $lint->parse( $html );
+        is( $lint->errors, 0, "No errors found in HTML" );
+    }
+
+If the user does not have HTML::Lint installed, the whole block of
+code I<won't be run at all>.  Test::More will output special ok's
+which Test::Harness interprets as skipped, but passing, tests.
+It's important that $how_many accurately reflects the number of tests
+in the SKIP block so the # of tests run will match up with your plan.
+
+It's perfectly safe to nest SKIP blocks.  Each SKIP block must have
+the label C<SKIP>, or Test::More can't work its magic.
+
+You don't skip tests which are failing because there's a bug in your
+program, or for which you don't yet have code written.  For that you
+use TODO.  Read on.
+
+=cut
+
+#'#
+sub skip {
+    my($why, $how_many) = @_;
+
+    unless( defined $how_many ) {
+        # $how_many can only be avoided when no_plan is in use.
+        _carp "skip() needs to know \$how_many tests are in the block"
+          unless $Test::Builder::No_Plan;
+        $how_many = 1;
+    }
+
+    for( 1..$how_many ) {
+        $Test->skip($why);
+    }
+
+    local $^W = 0;
+    last SKIP;
+}
+
+
+=item B<TODO: BLOCK>
+
+    TODO: {
+        local $TODO = $why if $condition;
+
+        ...normal testing code goes here...
+    }
+
+Declares a block of tests you expect to fail and $why.  Perhaps it's
+because you haven't fixed a bug or haven't finished a new feature:
+
+    TODO: {
+        local $TODO = "URI::Geller not finished";
+
+        my $card = "Eight of clubs";
+        is( URI::Geller->your_card, $card, 'Is THIS your card?' );
+
+        my $spoon;
+        URI::Geller->bend_spoon;
+        is( $spoon, 'bent',    "Spoon bending, that's original" );
+    }
+
+With a todo block, the tests inside are expected to fail.  Test::More
+will run the tests normally, but print out special flags indicating
+they are "todo".  Test::Harness will interpret failures as being ok.
+Should anything succeed, it will report it as an unexpected success.
+You then know the thing you had todo is done and can remove the
+TODO flag.
+
+The nice part about todo tests, as opposed to simply commenting out a
+block of tests, is it's like having a programmatic todo list.  You know
+how much work is left to be done, you're aware of what bugs there are,
+and you'll know immediately when they're fixed.
+
+Once a todo test starts succeeding, simply move it outside the block.
+When the block is empty, delete it.
+
+
+=item B<todo_skip>
+
+    TODO: {
+        todo_skip $why, $how_many if $condition;
+
+        ...normal testing code...
+    }
+
+With todo tests, it's best to have the tests actually run.  That way
+you'll know when they start passing.  Sometimes this isn't possible.
+Often a failing test will cause the whole program to die or hang, even
+inside an C<eval BLOCK> with and using C<alarm>.  In these extreme
+cases you have no choice but to skip over the broken tests entirely.
+
+The syntax and behavior is similar to a C<SKIP: BLOCK> except the
+tests will be marked as failing but todo.  Test::Harness will
+interpret them as passing.
+
+=cut
+
+sub todo_skip {
+    my($why, $how_many) = @_;
+
+    unless( defined $how_many ) {
+        # $how_many can only be avoided when no_plan is in use.
+        _carp "todo_skip() needs to know \$how_many tests are in the block"
+          unless $Test::Builder::No_Plan;
+        $how_many = 1;
+    }
+
+    for( 1..$how_many ) {
+        $Test->todo_skip($why);
+    }
+
+    local $^W = 0;
+    last TODO;
+}
+
+=item When do I use SKIP vs. TODO?
+
+B<If it's something the user might not be able to do>, use SKIP.
+This includes optional modules that aren't installed, running under
+an OS that doesn't have some feature (like fork() or symlinks), or maybe
+you need an Internet connection and one isn't available.
+
+B<If it's something the programmer hasn't done yet>, use TODO.  This
+is for any code you haven't written yet, or bugs you have yet to fix,
+but want to put tests in your testing script (always a good idea).
+
+
+=back
+
+=head2 Comparison functions
+
+Not everything is a simple eq check or regex.  There are times you
+need to see if two arrays are equivalent, for instance.  For these
+instances, Test::More provides a handful of useful functions.
+
+B<NOTE> These are NOT well-tested on circular references.  Nor am I
+quite sure what will happen with filehandles.
+
+=over 4
+
+=item B<is_deeply>
+
+  is_deeply( $this, $that, $test_name );
+
+Similar to is(), except that if $this and $that are hash or array
+references, it does a deep comparison walking each data structure to
+see if they are equivalent.  If the two structures are different, it
+will display the place where they start differing.
+
+Barrie Slaymaker's Test::Differences module provides more in-depth
+functionality along these lines, and it plays well with Test::More.
+
+B<NOTE> Display of scalar refs is not quite 100%
+
+=cut
+
+use vars qw(@Data_Stack);
+my $DNE = bless [], 'Does::Not::Exist';
+sub is_deeply {
+    my($this, $that, $name) = @_;
+
+    my $ok;
+    if( !ref $this || !ref $that ) {
+        $ok = $Test->is_eq($this, $that, $name);
+    }
+    else {
+        local @Data_Stack = ();
+        if( _deep_check($this, $that) ) {
+            $ok = $Test->ok(1, $name);
+        }
+        else {
+            $ok = $Test->ok(0, $name);
+            $ok = $Test->diag(_format_stack(@Data_Stack));
+        }
+    }
+
+    return $ok;
+}
+
+sub _format_stack {
+    my(@Stack) = @_;
+
+    my $var = '$FOO';
+    my $did_arrow = 0;
+    foreach my $entry (@Stack) {
+        my $type = $entry->{type} || '';
+        my $idx  = $entry->{'idx'};
+        if( $type eq 'HASH' ) {
+            $var .= "->" unless $did_arrow++;
+            $var .= "{$idx}";
+        }
+        elsif( $type eq 'ARRAY' ) {
+            $var .= "->" unless $did_arrow++;
+            $var .= "[$idx]";
+        }
+        elsif( $type eq 'REF' ) {
+            $var = "\${$var}";
+        }
+    }
+
+    my @vals = @{$Stack[-1]{vals}}[0,1];
+    my @vars = ();
+    ($vars[0] = $var) =~ s/\$FOO/     \$got/;
+    ($vars[1] = $var) =~ s/\$FOO/\$expected/;
+
+    my $out = "Structures begin differing at:\n";
+    foreach my $idx (0..$#vals) {
+        my $val = $vals[$idx];
+        $vals[$idx] = !defined $val ? 'undef' : 
+                      $val eq $DNE  ? "Does not exist"
+                                    : "'$val'";
+    }
+
+    $out .= "$vars[0] = $vals[0]\n";
+    $out .= "$vars[1] = $vals[1]\n";
+
+    $out =~ s/^/    /msg;
+    return $out;
+}
+
+
+=item B<eq_array>
+
+  eq_array(\@this, \@that);
+
+Checks if two arrays are equivalent.  This is a deep check, so
+multi-level structures are handled correctly.
+
+=cut
+
+#'#
+sub eq_array  {
+    my($a1, $a2) = @_;
+    return 1 if $a1 eq $a2;
+
+    my $ok = 1;
+    my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
+    for (0..$max) {
+        my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
+        my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
+
+        push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
+        $ok = _deep_check($e1,$e2);
+        pop @Data_Stack if $ok;
+
+        last unless $ok;
+    }
+    return $ok;
+}
+
+sub _deep_check {
+    my($e1, $e2) = @_;
+    my $ok = 0;
+
+    my $eq;
+    {
+        # Quiet uninitialized value warnings when comparing undefs.
+        local $^W = 0; 
+
+        if( $e1 eq $e2 ) {
+            $ok = 1;
+        }
+        else {
+            if( UNIVERSAL::isa($e1, 'ARRAY') and
+                UNIVERSAL::isa($e2, 'ARRAY') )
+            {
+                $ok = eq_array($e1, $e2);
+            }
+            elsif( UNIVERSAL::isa($e1, 'HASH') and
+                   UNIVERSAL::isa($e2, 'HASH') )
+            {
+                $ok = eq_hash($e1, $e2);
+            }
+            elsif( UNIVERSAL::isa($e1, 'REF') and
+                   UNIVERSAL::isa($e2, 'REF') )
+            {
+                push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+                $ok = _deep_check($$e1, $$e2);
+                pop @Data_Stack if $ok;
+            }
+            elsif( UNIVERSAL::isa($e1, 'SCALAR') and
+                   UNIVERSAL::isa($e2, 'SCALAR') )
+            {
+                push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
+                $ok = _deep_check($$e1, $$e2);
+            }
+            else {
+                push @Data_Stack, { vals => [$e1, $e2] };
+                $ok = 0;
+            }
+        }
+    }
+
+    return $ok;
+}
+
+
+=item B<eq_hash>
+
+  eq_hash(\%this, \%that);
+
+Determines if the two hashes contain the same keys and values.  This
+is a deep check.
+
+=cut
+
+sub eq_hash {
+    my($a1, $a2) = @_;
+    return 1 if $a1 eq $a2;
+
+    my $ok = 1;
+    my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
+    foreach my $k (keys %$bigger) {
+        my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
+        my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
+
+        push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
+        $ok = _deep_check($e1, $e2);
+        pop @Data_Stack if $ok;
+
+        last unless $ok;
+    }
+
+    return $ok;
+}
+
+=item B<eq_set>
+
+  eq_set(\@this, \@that);
+
+Similar to eq_array(), except the order of the elements is B<not>
+important.  This is a deep check, but the irrelevancy of order only
+applies to the top level.
+
+B<NOTE> By historical accident, this is not a true set comparision.
+While the order of elements does not matter, duplicate elements do.
+
+=cut
+
+# We must make sure that references are treated neutrally.  It really
+# doesn't matter how we sort them, as long as both arrays are sorted
+# with the same algorithm.
+sub _bogus_sort { local $^W = 0;  ref $a ? 0 : $a cmp $b }
+
+sub eq_set  {
+    my($a1, $a2) = @_;
+    return 0 unless @$a1 == @$a2;
+
+    # There's faster ways to do this, but this is easiest.
+    return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
+}
+
+=back
+
+
+=head2 Extending and Embedding Test::More
+
+Sometimes the Test::More interface isn't quite enough.  Fortunately,
+Test::More is built on top of Test::Builder which provides a single,
+unified backend for any test library to use.  This means two test
+libraries which both use Test::Builder B<can be used together in the
+same program>.
+
+If you simply want to do a little tweaking of how the tests behave,
+you can access the underlying Test::Builder object like so:
+
+=over 4
+
+=item B<builder>
+
+    my $test_builder = Test::More->builder;
+
+Returns the Test::Builder object underlying Test::More for you to play
+with.
+
+=cut
+
+sub builder {
+    return Test::Builder->new;
+}
+
+=back
+
+
+=head1 NOTES
+
+Test::More is B<explicitly> tested all the way back to perl 5.004.
+
+Test::More is thread-safe for perl 5.8.0 and up.
+
+=head1 BUGS and CAVEATS
+
+=over 4
+
+=item Making your own ok()
+
+If you are trying to extend Test::More, don't.  Use Test::Builder
+instead.
+
+=item The eq_* family has some caveats.
+
+=item Test::Harness upgrades
+
+no_plan and todo depend on new Test::Harness features and fixes.  If
+you're going to distribute tests that use no_plan or todo your
+end-users will have to upgrade Test::Harness to the latest one on
+CPAN.  If you avoid no_plan and TODO tests, the stock Test::Harness
+will work fine.
+
+If you simply depend on Test::More, it's own dependencies will cause a
+Test::Harness upgrade.
+
+=back
+
+
+=head1 HISTORY
+
+This is a case of convergent evolution with Joshua Pritikin's Test
+module.  I was largely unaware of its existence when I'd first
+written my own ok() routines.  This module exists because I can't
+figure out how to easily wedge test names into Test's interface (along
+with a few other problems).
+
+The goal here is to have a testing utility that's simple to learn,
+quick to use and difficult to trip yourself up with while still
+providing more flexibility than the existing Test.pm.  As such, the
+names of the most common routines are kept tiny, special cases and
+magic side-effects are kept to a minimum.  WYSIWYG.
+
+
+=head1 SEE ALSO
+
+L<Test::Simple> if all this confuses you and you just want to write
+some tests.  You can upgrade to Test::More later (it's forward
+compatible).
+
+L<Test::Differences> for more ways to test complex data structures.
+And it plays well with Test::More.
+
+L<Test> is the old testing module.  Its main benefit is that it has
+been distributed with Perl since 5.004_05.
+
+L<Test::Harness> for details on how your test results are interpreted
+by Perl.
+
+L<Test::Unit> describes a very featureful unit testing interface.
+
+L<Test::Inline> shows the idea of embedded testing.
+
+L<SelfTest> is another approach to embedded testing.
+
+
+=head1 AUTHORS
+
+Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
+from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, chromatic and the perl-qa gang.
+
+
+=head1 COPYRIGHT
+
+Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
+
+This program is free software; you can redistribute it and/or 
+modify it under the same terms as Perl itself.
+
+See F<http://www.perl.com/perl/misc/Artistic.html>
+
+=cut
+
+1;
index 4366748..fdb79d1 100644 (file)
@@ -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";
-  }
-}
index bd81a16..dc4dc06 100644 (file)
@@ -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 <<EOS;
 # this tests a bug in Imager's png.c v1.1
 # if also tickles a bug in libpng before 1.0.5, so you may need to
index 0d514c6..a73ff51 100644 (file)
@@ -1,14 +1,14 @@
 #!perl -w
 use strict;
 $|=1;
-print "1..69\n";
+use Test::More tests => 69;
 use Imager qw(:all);
 BEGIN { require "t/testtools.pl"; }
+use Carp 'confess';
+$SIG{__DIE__} = sub { confess @_ };
 
 my $buggy_giflib_file = "buggy_giflib.txt";
 
-sub ok ($$$);
-
 init_log("testout/t105gif.log",1);
 
 my $green=i_color_new(0,255,0,255);
@@ -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, "<testimg/scalei.gif") || die "Cannot open testimg/scalei.gif";
     binmode FH;
     my ($imgi) = i_readgif(fileno(FH));
-    $imgi || die "Cannot read testimg/scalei.gif";
+    ok($imgi, "read interlaced") or die "Cannot read testimg/scalei.gif";
     close FH;
-    print "ok 4\n";
     open FH, "<testimg/scale.gif" or die "Cannot open testimg/scale.gif";
     binmode FH;
     my ($imgni) = i_readgif(fileno(FH));
-    $imgni or die "Cannot read testimg/scale.gif";
+    ok($imgni, "read normal") or die "Cannot read testimg/scale.gif";
     close FH;
-    print "ok 5\n";
 
     open FH, ">testout/t105i.ppm" or die "Cannot create testout/t105i.ppm";
     binmode FH;
     my $IO = Imager::io_new_fd( fileno(FH) );
-    i_writeppm_wiol($imgi, $IO) or die "Cannot write testout/t105i.ppm";
+    i_writeppm_wiol($imgi, $IO)
+      or die "Cannot write testout/t105i.ppm";
     close FH;
 
-
     open FH, ">testout/t105ni.ppm" or die "Cannot create testout/t105ni.ppm";
     binmode FH;
     $IO = Imager::io_new_fd( fileno(FH) );
-    i_writeppm_wiol($imgni, $IO) or die "Cannot write testout/t105ni.ppm";
+    i_writeppm_wiol($imgni, $IO)
+      or die "Cannot write testout/t105ni.ppm";
     close FH;
 
     # compare them
@@ -92,15 +96,12 @@ if (!i_has_format("gif")) {
     open FH, "<testout/t105ni.ppm" or die "Cannot open testout/t105ni.ppm";
     my $datani = do { local $/; <FH> };
     close FH;
-    if ($datai eq $datani) {
-      print "ok 6\n";
-    }
-    else {
-      print "not ok 6\n";
-    }
+    is($datai, $datani, "images match");
 
     my $gifver = Imager::i_giflib_version();
-    if ($gifver >= 4.0) {
+  SKIP:
+    {
+      skip("giflib3 doesn't support callbacks", 4) if $gifver >= 4.0;
       # reading with a callback
       # various sizes to make sure the buffering works
       # requested size
@@ -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, "<t/t105gif.t"
       or die "Cannot open this script!: $!";
     binmode FH;
-    my $im2 = i_readgif(fileno(FH));
-    if ($im2) {
-      # this should have failed
-      print "not ok 18 # giflib think script if a GIF file\n";
-    }
-    else {
-      print "ok 18 # ",Imager::_error_as_msg(),"\n";
-    }
+    ok(!i_readgif(fileno(FH)), 
+       "read test script as gif should fail ". Imager::_error_as_msg());
     close FH;
 
     # try to save no images :)
     open FH, ">testout/t105_none.gif"
       or die "Cannot open testout/t105_none.gif: $!";
     binmode FH;
-    if (i_writegif_gen(fileno(FH), {}, "hello")) {
-      print "not ok 19 # shouldn't be able to save strings\n";
-    }
-    else {
-      print "ok 19 # ",Imager::_error_as_msg(),"\n";
+    if (ok(!i_writegif_gen(fileno(FH), {}, "hello"), "shouldn't be able to write a string as a gif")) {
+      print "# ",Imager::_error_as_msg(),"\n";
     }
 
     # try to read a truncated gif (no image descriptors)
-    read_failure('testimg/trimgdesc.gif', 20);
+    read_failure('testimg/trimgdesc.gif');
     # file truncated just after the image descriptor tag
-    read_failure('testimg/trmiddesc.gif', 21);
+    read_failure('testimg/trmiddesc.gif');
     # image has no colour map
-    read_failure('testimg/nocmap.gif', 22);
+    read_failure('testimg/nocmap.gif');
 
-    unless (-e $buggy_giflib_file) {
+    SKIP:
+    {
+      skip("see $buggy_giflib_file", 8) if -e $buggy_giflib_file;
       # image has a local colour map
       open FH, "< testimg/loccmap.gif"
        or die "Cannot open testimg/loccmap.gif: $!";
       binmode FH;
-      if (i_readgif(fileno(FH))) {
-       print "ok 23\n";
-      }
-      else {
-       print "not ok 23 # failed to read image with only a local colour map";
-      }
+      ok(i_readgif(fileno(FH)), "read an image with only a local colour map");
       close FH;
 
       # image has global and local colour maps
@@ -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;
   }
 }
index 8c5b492..3db8fc2 100644 (file)
@@ -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 = <FH>;
   }
   
-  if ($odata eq $tiffdata) {
-    print "ok 8\n";
-  } else {
-    print "not ok 8\n";
-  }
+  is($odata, $tiffdata, "same data in file as in memory");
 
   # test Micksa's tiff writer
   # a shortish fax page
@@ -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";
-  }
-}