programs/winetest/include/winetest.pm

   1 # --------------------------------------------------------------------
   2 # Main routines for the Wine test environment
   3 #
   4 # Copyright 2001 John F Sturtz for Codeweavers
   5 #
   6 # This library is free software; you can redistribute it and/or
   7 # modify it under the terms of the GNU Lesser General Public
   8 # License as published by the Free Software Foundation; either
   9 # version 2.1 of the License, or (at your option) any later version.
  10 #
  11 # This library is distributed in the hope that it will be useful,
  12 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 # Lesser General Public License for more details.
  15 #
  16 # You should have received a copy of the GNU Lesser General Public
  17 # License along with this library; if not, write to the Free Software
  18 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  19 # --------------------------------------------------------------------
  20
  21 package winetest;
  22
  23 use strict;
  24 use vars qw(@ISA @EXPORT @EXPORT_OK $todo_level
  25             $successes $failures $todo_successes $todo_failures $winetest_report_success);
  26
  27 require Exporter;
  28
  29 @ISA = qw(Exporter);
  30
  31 # Items to export into callers namespace by default. Note: do not export
  32 # names by default without a very good reason. Use EXPORT_OK instead.
  33 # Do not simply export all your public functions/methods/constants.
  34 @EXPORT = qw(
  35              assert
  36              hd
  37              ok
  38              todo
  39              todo_wine
  40              trace
  41              wc
  42              wclen
  43             );
  44
  45 # Global variables
  46 $wine::debug = defined($ENV{WINETEST_DEBUG}) ? $ENV{WINETEST_DEBUG} : 1;
  47 $wine::platform = defined($ENV{WINETEST_PLATFORM}) ? $ENV{WINETEST_PLATFORM} : "windows";
  48
  49 $todo_level = 0;
  50 $successes = 0;
  51 $failures = 0;
  52 $todo_successes = 0;
  53 $todo_failures = 0;
  54 $winetest_report_success = defined($ENV{WINETEST_REPORT_SUCCESS}) ? $ENV{WINETEST_REPORT_SUCCESS} : 0;
  55
  56 # ----------------------------------------------------------------------
  57 # | Subroutine:  hd                                                    |
  58 # |                                                                    |
  59 # | Purpose:     Display a hex dump of a string                        |
  60 # |                                                                    |
  61 # | Usage:       hd STR                                                |
  62 # | Usage:       hd STR, LENGTH                                        |
  63 # |                                                                    |
  64 # | Returns:     (none)                                                |
  65 # ----------------------------------------------------------------------
  66 sub hd($;$)
  67 {
  68     # Locals
  69     my  ($buf, $length);
  70     my  $first;
  71     my  ($str1, $str2, $str, $t);
  72     my  ($c, $x);
  73
  74 # Begin sub hd
  75
  76     # --------------------------------------------------------------
  77     # | Get args; if no BUF specified, blow                        |
  78     # --------------------------------------------------------------
  79     $buf = shift;
  80     $length = (shift or length ($buf));
  81     return
  82         if ((not defined ($buf)) || ($length <= 0));
  83
  84     # --------------------------------------------------------------
  85     # | Initialize                                                 |
  86     # --------------------------------------------------------------
  87     $first = 1;
  88     $str1 = "00000:";
  89     $str2 = "";
  90
  91     # --------------------------------------------------------------
  92     # | For each character                                         |
  93     # --------------------------------------------------------------
  94     for (0 .. ($length - 1))
  95     {
  96         $c = substr ($buf, $_, 1);
  97         $x = sprintf ("%02x", ord ($c));
  98         $str1 .= (" " . $x);
  99         $str2 .= (((ord ($c) >= 33) && (ord ($c) <= 126)) ? $c : ".");
 100
 101         # --------------------------------------------------------------
 102         # | Every group of 4, add an extra space                       |
 103         # --------------------------------------------------------------
 104         if
 105         (
 106             ((($_ + 1) % 16) == 4)  ||
 107             ((($_ + 1) % 16) == 12)
 108         )
 109         {
 110             $str1 .= " ";
 111             $str2 .= " ";
 112         }
 113
 114         # --------------------------------------------------------------
 115         # | Every group of 8, add a '-'                                |
 116         # --------------------------------------------------------------
 117         elsif
 118         (
 119             ((($_ + 1) % 16) == 8)
 120         )
 121         {
 122             $str1 .= " -";
 123             $str2 .= " ";
 124         }
 125
 126         # --------------------------------------------------------------
 127         # | Every group of 16, dump                                    |
 128         # --------------------------------------------------------------
 129         if
 130         (
 131             ((($_ + 1) % 16) == 0)      ||
 132             ($_ == ($length - 1))
 133         )
 134         {
 135             $str = sprintf ("%-64s%s", $str1, $str2);
 136             if ($first)
 137             {
 138                 $t = ("-" x length ($str));
 139                 print "  $t\n";
 140                 print "  | $length bytes\n";
 141                 print "  $t\n";
 142                 $first = 0;
 143             }
 144             print "  $str\n";
 145             $str1 = sprintf ("%05d:", ($_ + 1));
 146             $str2 = "";
 147             if ($_ == ($length - 1))
 148             {
 149                 print "  $t\n";
 150             }
 151         }
 152
 153     }  # end for
 154
 155
 156     # --------------------------------------------------------------
 157     # | Exit point                                                 |
 158     # --------------------------------------------------------------
 159     return;
 160
 161 } # End sub hd
 162
 163
 164
 165 # ----------------------------------------------------------------------
 166 # | Subroutine:  wc                                                    |
 167 # |                                                                    |
 168 # | Purpose:     Generate unicode string                               |
 169 # |                                                                    |
 170 # | Usage:       wc ASCII_STRING                                       |
 171 # |                                                                    |
 172 # | Returns:     string generated                                      |
 173 # ----------------------------------------------------------------------
 174 sub wc($)
 175 {
 176     return pack("S*",unpack("C*",shift));
 177 } # End sub wc
 178
 179
 180
 181 # ----------------------------------------------------------------------
 182 # | Subroutine:  wclen                                                 |
 183 # |                                                                    |
 184 # | Purpose:     Return length of unicode string                       |
 185 # |                                                                    |
 186 # | Usage:       wclen UNICODE_STRING                                  |
 187 # |                                                                    |
 188 # | Returns:     string generated                                      |
 189 # ----------------------------------------------------------------------
 190 sub wclen($)
 191 {
 192     # Locals
 193     my  $str = shift;
 194     my  ($c1, $c2, $n);
 195
 196 # Begin sub wclen
 197
 198     $n = 0;
 199     while (length ($str) > 0)
 200     {
 201         $c1 = substr ($str, 0, 1, "");
 202         $c2 = substr ($str, 0, 1, "");
 203         (($c1 eq "\x00") && ($c2 eq "\x00")) ? last : $n++;
 204     }
 205
 206     return ($n);
 207
 208 } # End sub wclen
 209
 210
 211
 212 # ----------------------------------------------------------------------
 213 # Subroutine:  ok
 214 #
 215 # Purpose:     Print warning if something fails
 216 #
 217 # Usage:       ok CONDITION [DESCRIPTION]
 218 #
 219 # Returns:     (none)
 220 # ----------------------------------------------------------------------
 221 sub ok($;$)
 222 {
 223     my $assertion = shift;
 224     my $description = shift;
 225     my ($filename, $line) = (caller (0))[1,2];
 226     if ($todo_level)
 227     {
 228         if ($assertion)
 229         {
 230             print STDERR ("$filename:$line: Test succeeded inside todo block" .
 231                           ($description ? ": $description" : "") . "\n");
 232             $todo_failures++;
 233         }
 234         else { $todo_successes++; }
 235     }
 236     else
 237     {
 238         if (!$assertion)
 239         {
 240             print STDERR ("$filename:$line: Test failed" .
 241                           ($description ? ": $description" : "") . "\n");
 242             $failures++;
 243         }
 244         else
 245         {
 246             print STDERR ("$filename:$line: Test succeeded\n") if ($winetest_report_success);
 247             $successes++;
 248         }
 249     }
 250 }
 251
 252
 253 # ----------------------------------------------------------------------
 254 # Subroutine:  assert
 255 #
 256 # Purpose:     Print error and die if something fails
 257 #
 258 # Usage:       assert CONDITION [DESCRIPTION]
 259 #
 260 # Returns:     (none)
 261 # ----------------------------------------------------------------------
 262 sub assert($;$)
 263 {
 264     my $assertion = shift;
 265     my $description = shift;
 266     my ($filename, $line) = (caller (0))[1,2];
 267     unless ($assertion)
 268     {
 269         die ("$filename:$line: Assertion failed" . ($description ? ": $description" : "") . "\n");
 270     }
 271 }
 272
 273
 274 # ----------------------------------------------------------------------
 275 # Subroutine:  trace
 276 #
 277 # Purpose:     Print debugging traces
 278 #
 279 # Usage:       trace format [arguments]
 280 # ----------------------------------------------------------------------
 281 sub trace($@)
 282 {
 283     return unless ($wine::debug > 0);
 284     my $format = shift;
 285     my $filename = (caller(0))[1];
 286     $filename =~ s!.*/!!;
 287     printf "trace:$filename $format", @_;
 288 }
 289
 290 # ----------------------------------------------------------------------
 291 # Subroutine:  todo
 292 #
 293 # Purpose:     Specify a block of code as todo for a given platform
 294 #
 295 # Usage:       todo name coderef
 296 # ----------------------------------------------------------------------
 297 sub todo($$)
 298 {
 299     my ($platform,$code) = @_;
 300     if ($wine::platform eq $platform)
 301     {
 302         $todo_level++;
 303         eval &$code;
 304         $todo_level--;
 305     }
 306     else
 307     {
 308         eval &$code;
 309     }
 310 }
 311
 312
 313 # ----------------------------------------------------------------------
 314 # Subroutine:  todo_wine
 315 #
 316 # Purpose:     Specify a block of test as todo for the Wine platform
 317 #
 318 # Usage:       todo_wine { code }
 319 # ----------------------------------------------------------------------
 320 sub todo_wine(&)
 321 {
 322     my $code = shift;
 323     todo( "wine", $code );
 324 }
 325
 326
 327 # ----------------------------------------------------------------------
 328 # Subroutine:  END
 329 #
 330 # Purpose:     Called at the end of execution, print results summary
 331 # ----------------------------------------------------------------------
 332 END
 333 {
 334     return if $?;  # got some other error already
 335     if ($wine::debug > 0)
 336     {
 337         my $filename = (caller(0))[1];
 338         printf STDERR ("%s: %d tests executed, %d marked as todo, %d %s.\n",
 339                        $filename, $successes + $failures + $todo_successes + $todo_failures,
 340                        $todo_successes, $failures + $todo_failures,
 341                        ($failures + $todo_failures != 1) ? "failures" : "failure" );
 342     }
 343     $? = ($failures + $todo_failures < 255) ? $failures + $todo_failures : 255;
 344 }
 345
 346 1;