# --------------------------------------------------------------------
# Main routines for the Wine test environment
#
# Copyright 2001 John F Sturtz for Codeweavers
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
# --------------------------------------------------------------------

package winetest;

use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK $todo_level
            $successes $failures $todo_successes $todo_failures $winetest_report_success);

require Exporter;

@ISA = qw(Exporter);

# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
             assert
             hd
             ok
             todo
             todo_wine
             trace
             wc
             wclen
            );

# Global variables
$wine::debug = defined($ENV{WINETEST_DEBUG}) ? $ENV{WINETEST_DEBUG} : 1;
$wine::platform = defined($ENV{WINETEST_PLATFORM}) ? $ENV{WINETEST_PLATFORM} : "windows";

$todo_level = 0;
$successes = 0;
$failures = 0;
$todo_successes = 0;
$todo_failures = 0;
$winetest_report_success = defined($ENV{WINETEST_REPORT_SUCCESS}) ? $ENV{WINETEST_REPORT_SUCCESS} : 0;

# ----------------------------------------------------------------------
# | Subroutine:  hd                                                    |
# |                                                                    |
# | Purpose:     Display a hex dump of a string                        |
# |                                                                    |
# | Usage:       hd STR                                                |
# | Usage:       hd STR, LENGTH                                        |
# |                                                                    |
# | Returns:     (none)                                                |
# ----------------------------------------------------------------------
sub hd($;$)
{
    # Locals
    my  ($buf, $length);
    my  $first;
    my  ($str1, $str2, $str, $t);
    my  ($c, $x);

# Begin sub hd

    # --------------------------------------------------------------
    # | Get args; if no BUF specified, blow                        |
    # --------------------------------------------------------------
    $buf = shift;
    $length = (shift or length ($buf));
    return
        if ((not defined ($buf)) || ($length <= 0));

    # --------------------------------------------------------------
    # | Initialize                                                 |
    # --------------------------------------------------------------
    $first = 1;
    $str1 = "00000:";
    $str2 = "";

    # --------------------------------------------------------------
    # | For each character                                         |
    # --------------------------------------------------------------
    for (0 .. ($length - 1))
    {
        $c = substr ($buf, $_, 1);
        $x = sprintf ("%02x", ord ($c));
        $str1 .= (" " . $x);
        $str2 .= (((ord ($c) >= 33) && (ord ($c) <= 126)) ? $c : ".");

        # --------------------------------------------------------------
        # | Every group of 4, add an extra space                       |
        # --------------------------------------------------------------
        if
        (
            ((($_ + 1) % 16) == 4)  ||
            ((($_ + 1) % 16) == 12)
        )
        {
            $str1 .= " ";
            $str2 .= " ";
        }

        # --------------------------------------------------------------
        # | Every group of 8, add a '-'                                |
        # --------------------------------------------------------------
        elsif
        (
            ((($_ + 1) % 16) == 8)
        )
        {
            $str1 .= " -";
            $str2 .= " ";
        }

        # --------------------------------------------------------------
        # | Every group of 16, dump                                    |
        # --------------------------------------------------------------
        if
        (
            ((($_ + 1) % 16) == 0)      ||
            ($_ == ($length - 1))
        )
        {
            $str = sprintf ("%-64s%s", $str1, $str2);
            if ($first)
            {
                $t = ("-" x length ($str));
                print "  $t\n";
                print "  | $length bytes\n";
                print "  $t\n";
                $first = 0;
            }
            print "  $str\n";
            $str1 = sprintf ("%05d:", ($_ + 1));
            $str2 = "";
            if ($_ == ($length - 1))
            {
                print "  $t\n";
            }
        }

    }  # end for


    # --------------------------------------------------------------
    # | Exit point                                                 |
    # --------------------------------------------------------------
    return;

} # End sub hd


# ----------------------------------------------------------------------
# | Subroutine:  wc                                                    |
# |                                                                    |
# | Purpose:     Generate unicode string                               |
# |                                                                    |
# | Usage:       wc ASCII_STRING                                       |
# |                                                                    |
# | Returns:     string generated                                      |
# ----------------------------------------------------------------------
sub wc($)
{
    return pack("S*",unpack("C*",shift));
} # End sub wc


# ----------------------------------------------------------------------
# | Subroutine:  wclen                                                 |
# |                                                                    |
# | Purpose:     Return length of unicode string                       |
# |                                                                    |
# | Usage:       wclen UNICODE_STRING                                  |
# |                                                                    |
# | Returns:     string generated                                      |
# ----------------------------------------------------------------------
sub wclen($)
{
    # Locals
    my  $str = shift;
    my  ($c1, $c2, $n);

# Begin sub wclen

    $n = 0;
    while (length ($str) > 0)
    {
        $c1 = substr ($str, 0, 1, "");
        $c2 = substr ($str, 0, 1, "");
        (($c1 eq "\x00") && ($c2 eq "\x00")) ? last : $n++;
    }

    return ($n);

} # End sub wclen


# ----------------------------------------------------------------------
# Subroutine:  ok
#
# Purpose:     Print warning if something fails
#
# Usage:       ok CONDITION [DESCRIPTION]
#
# Returns:     (none)
# ----------------------------------------------------------------------
sub ok($;$)
{
    my $assertion = shift;
    my $description = shift;
    my ($filename, $line) = (caller (0))[1,2];
    if ($todo_level)
    {
        if ($assertion)
        {
            print STDERR ("$filename:$line: Test succeeded inside todo block" .
                          ($description ? ": $description" : "") . "\n");
            $todo_failures++;
        }
        else { $todo_successes++; }
    }
    else
    {
        if (!$assertion)
        {
            print STDERR ("$filename:$line: Test failed" .
                          ($description ? ": $description" : "") . "\n");
            $failures++;
        }
        else
        {
            print STDERR ("$filename:$line: Test succeeded\n") if ($winetest_report_success);
            $successes++;
        }
    }
}


# ----------------------------------------------------------------------
# Subroutine:  assert
#
# Purpose:     Print error and die if something fails
#
# Usage:       assert CONDITION [DESCRIPTION]
#
# Returns:     (none)
# ----------------------------------------------------------------------
sub assert($;$)
{
    my $assertion = shift;
    my $description = shift;
    my ($filename, $line) = (caller (0))[1,2];
    unless ($assertion)
    {
        die ("$filename:$line: Assertion failed" . ($description ? ": $description" : "") . "\n");
    }
}


# ----------------------------------------------------------------------
# Subroutine:  trace
#
# Purpose:     Print debugging traces
#
# Usage:       trace format [arguments]
# ----------------------------------------------------------------------
sub trace($@)
{
    return unless ($wine::debug > 0);
    my $format = shift;
    my $filename = (caller(0))[1];
    $filename =~ s!.*/!!;
    printf "trace:$filename $format", @_;
}

# ----------------------------------------------------------------------
# Subroutine:  todo
#
# Purpose:     Specify a block of code as todo for a given platform
#
# Usage:       todo name coderef
# ----------------------------------------------------------------------
sub todo($$)
{
    my ($platform,$code) = @_;
    if ($wine::platform eq $platform)
    {
        $todo_level++;
        eval &$code;
        $todo_level--;
    }
    else
    {
        eval &$code;
    }
}


# ----------------------------------------------------------------------
# Subroutine:  todo_wine
#
# Purpose:     Specify a block of test as todo for the Wine platform
#
# Usage:       todo_wine { code }
# ----------------------------------------------------------------------
sub todo_wine(&)
{
    my $code = shift;
    todo( "wine", $code );
}


# ----------------------------------------------------------------------
# Subroutine:  END
#
# Purpose:     Called at the end of execution, print results summary
# ----------------------------------------------------------------------
END
{
    return if $?;  # got some other error already
    if ($wine::debug > 0)
    {
        my $filename = (caller(0))[1];
        printf STDERR ("%s: %d tests executed, %d marked as todo, %d %s.\n",
                       $filename, $successes + $failures + $todo_successes + $todo_failures,
                       $todo_successes, $failures + $todo_failures,
                       ($failures + $todo_failures != 1) ? "failures" : "failure" );
    }
    $? = ($failures + $todo_failures < 255) ? $failures + $todo_failures : 255;
}

1;