PUT results from the CPAN

Apache-Test

# Licensed to the Apache Software Foundation (ASF) under one or more
# contributor license agreements.  See the NOTICE file distributed with
# this work for additional information regarding copyright ownership.
# The ASF licenses this file to You under the Apache License, Version 2.0
# (the "License"); you may not use this file except in compliance with
# the License.  You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
package Apache::TestUtil;

use strict;
use warnings FATAL => 'all';

use File::Find ();
use File::Path ();
use Exporter ();
use Carp ();
use Config;
use File::Basename qw(dirname);
use File::Spec::Functions qw(catfile catdir file_name_is_absolute tmpdir);
use Symbol ();
use Fcntl qw(SEEK_END);

use Apache::Test ();
use Apache::TestConfig ();

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %CLEAN);

$VERSION = '0.02';
@ISA     = qw(Exporter);

@EXPORT = qw(t_cmp t_debug t_append_file t_write_file t_open_file
    t_mkdir t_rmtree t_is_equal t_filepath_cmp t_write_test_lib
    t_server_log_error_is_expected t_server_log_warn_is_expected
    t_client_log_error_is_expected t_client_log_warn_is_expected
);

@EXPORT_OK = qw(t_write_perl_script t_write_shell_script t_chown
                t_catfile_apache t_catfile t_file_watch_for
                t_start_error_log_watch t_finish_error_log_watch
                t_start_file_watch t_read_file_watch t_finish_file_watch);

%CLEAN = ();

$Apache::TestUtil::DEBUG_OUTPUT = \*STDOUT;

# 5.005's Data::Dumper has problems to dump certain datastructures
use constant HAS_DUMPER => eval { $] >= 5.006 && require Data::Dumper; };
use constant INDENT     => 4;

{
    my %files;
    sub t_start_file_watch (;$) {
        my $name = defined $_[0] ? $_[0] : 'error_log';
        $name = File::Spec->catfile(Apache::Test::vars->{t_logs}, $name)
            unless (File::Spec->file_name_is_absolute($name));

        if (open my $fh, '<', $name) {
            seek $fh, 0, SEEK_END;
            $files{$name} = $fh;
        }
        else {
            delete $files{$name};
        }

        return;
    }

    sub t_finish_file_watch (;$) {
        my $name = defined $_[0] ? $_[0] : 'error_log';
        $name = File::Spec->catfile(Apache::Test::vars->{t_logs}, $name)
            unless (File::Spec->file_name_is_absolute($name));

        my $fh = delete $files{$name};
        unless (defined $fh) {
            open $fh, '<', $name or return;
            return readline $fh;
        }

        return readline $fh;
     }

    sub t_read_file_watch (;$) {
        my $name = defined $_[0] ? $_[0] : 'error_log';
        $name = File::Spec->catfile(Apache::Test::vars->{t_logs}, $name)
            unless (File::Spec->file_name_is_absolute($name));

        my $fh = $files{$name};
        unless (defined $fh) {
            open $fh, '<', $name or return;
            $files{$name} = $fh;
        }

        return readline $fh;
    }

    sub t_file_watch_for ($$$) {
	my ($name, $re, $timeout) = @_;
	local $/ = "\n";
	$re = qr/$re/ unless ref $re;
	$timeout *= 10;
	my $buf = '';
	my @acc;
	while ($timeout >= 0) {
	    my $line = t_read_file_watch $name;

lib/Apache/TestUtil.pm view on Meta::CPAN

                t_is_equal($a->{$key}, $b->{$key}) || return 0;
            }
        }
        elsif ($ref_b eq 'Regexp') {
            return $a =~ $b;
        }
        else {
            # try to compare the references
            return $a eq $b;
        }
    }
    else {
        # undef == undef! a valid test
        return (defined $a || defined $b) ? 0 : 1;
    }
    return 1;
}



sub t_cmp ($$;$) {
    Carp::carp(join(":", (caller)[1..2]) .
        ' usage: $res = t_cmp($received, $expected, [$comment])')
            if @_ < 2 || @_ > 3;

    my ($received, $expected) = @_;

    # this was added in Apache::Test::VERSION 1.12 - remove deprecated
    # logic sometime around 1.15 or mid September, 2004.
    if (UNIVERSAL::isa($_[0], 'Regexp')) {
        my @warning = ("WARNING!!! t_cmp() argument order has changed.",
                       "use of a regular expression as the first argument",
                       "is deprecated.  support will be removed soon.");
        t_debug(@warning);
        ($received, $expected) = ($expected, $received);
    }

    t_debug("testing : " . pop) if @_ == 3;
    t_debug("expected: " . struct_as_string(0, $expected));
    t_debug("received: " . struct_as_string(0, $received));
    return t_is_equal($received, $expected);
}

# Essentially t_cmp, but on Win32, first converts pathnames
# to their DOS long name.
sub t_filepath_cmp ($$;$) {
    my @a = (shift, shift);
    if (Apache::TestConfig::WIN32) {
        $a[0] = Win32::GetLongPathName($a[0]) if defined $a[0] && -e $a[0];
        $a[1] = Win32::GetLongPathName($a[1]) if defined $a[1] && -e $a[1];
    }
    return @_ == 1 ? t_cmp($a[0], $a[1], $_[0]) : t_cmp($a[0], $a[1]);
}


*expand = HAS_DUMPER ?
    sub { map { ref $_ ? Data::Dumper::Dumper($_) : $_ } @_ } :
    sub { @_ };

sub t_debug {
    my $out = $Apache::TestUtil::DEBUG_OUTPUT;
    print $out map {"# $_\n"} map {split /\n/} grep {defined} expand(@_);
}

sub t_open_file {
    my $file = shift;

    die "must pass a filename" unless defined $file;

    # create the parent dir if it doesn't exist yet
    makepath(dirname $file);

    my $fh = Symbol::gensym();
    open $fh, ">$file" or die "can't open $file: $!";
    t_debug("writing file: $file");
    $CLEAN{files}{$file}++;

    return $fh;
}

sub _temp_package_dir {
    return catdir(tmpdir(), 'apache_test');
}

sub t_write_test_lib {
    my $file = shift;

    die "must pass a filename" unless defined $file;

    t_write_file(catdir(_temp_package_dir(), $file), @_);
}

sub t_write_file {
    my $file = shift;

    die "must pass a filename" unless defined $file;

    # create the parent dir if it doesn't exist yet
    makepath(dirname $file);

    my $fh = Symbol::gensym();
    open $fh, ">$file" or die "can't open $file: $!";
    t_debug("writing file: $file");
    print $fh join '', @_ if @_;
    close $fh;
    $CLEAN{files}{$file}++;
}

sub t_append_file {
    my $file = shift;

    die "must pass a filename" unless defined $file;

    # create the parent dir if it doesn't exist yet
    makepath(dirname $file);

    # add to the cleanup list only if we created it now
    $CLEAN{files}{$file}++ unless -e $file;

    my $fh = Symbol::gensym();
    open $fh, ">>$file" or die "can't open $file: $!";

lib/Apache/TestUtil.pm view on Meta::CPAN

  # received: 1

then it returns the result of comparison of the I<$expected> and the
I<$received> variables. Usually, the return value of this function is
fed directly to the ok() function, like this:

  ok t_cmp(1, 1, "1 == 1?");

the third argument (I<$comment>) is optional, mostly useful for
telling what the comparison is trying to do.

It is valid to use C<undef> as an expected value. Therefore:

  my $foo;
  t_cmp(undef, $foo, "undef == undef?");

will return a I<true> value.

You can compare any two data-structures with t_cmp(). Just make sure
that if you pass non-scalars, you have to pass their references. The
datastructures can be deeply nested. For example you can compare:

  t_cmp({1 => [2..3,{5..8}], 4 => [5..6]},
        {1 => [2..3,{5..8}], 4 => [5..6]},
        "hash of array of hashes");

You can also compare the second argument against the first as a
regex. Use the C<qr//> function in the second argument. For example:

  t_cmp("abcd", qr/^abc/, "regex compare");

will do:

  "abcd" =~ /^abc/;

This function is exported by default.

=item t_filepath_cmp()

This function is used to compare two filepaths via t_cmp().
For non-Win32, it simply uses t_cmp() for the comparison,
but for Win32, Win32::GetLongPathName() is invoked to convert
the first two arguments to their DOS long pathname. This is useful
when there is a possibility the two paths being compared
are not both represented by their long or short pathname.

This function is exported by default.

=item t_debug()

  t_debug("testing feature foo");
  t_debug("test", [1..3], 5, {a=>[1..5]});

t_debug() prints out any datastructure while prepending C<#> at the
beginning of each line, to make the debug printouts comply with
C<Test::Harness>'s requirements. This function should be always used
for debug prints, since if in the future the debug printing will
change (e.g. redirected into a file) your tests won't need to be
changed.

the special global variable $Apache::TestUtil::DEBUG_OUTPUT can
be used to redirect the output from t_debug() and related calls
such as t_write_file().  for example, from a server-side test
you would probably need to redirect it to STDERR:

  sub handler {
    plan $r, tests => 1;

    local $Apache::TestUtil::DEBUG_OUTPUT = \*STDERR;

    t_write_file('/tmp/foo', 'bar');
    ...
  }

left to its own devices, t_debug() will collide with the standard
HTTP protocol during server-side tests, resulting in a situation
both confusing difficult to debug.  but STDOUT is left as the
default, since you probably don't want debug output under normal
circumstances unless running under verbose mode.

This function is exported by default.

=item t_write_test_lib()

  t_write_test_lib($filename, @lines)

t_write_test_lib() creates a new file at I<$filename> or overwrites
the existing file with the content passed in I<@lines>.  The file
is created in a temporary directory which is added to @INC at
test configuration time.  It is intended to be used for creating
temporary packages for testing which can be modified at run time,
see the Apache::Reload unit tests for an example.

=item t_write_file()

  t_write_file($filename, @lines);

t_write_file() creates a new file at I<$filename> or overwrites the
existing file with the content passed in I<@lines>. If only the
I<$filename> is passed, an empty file will be created.

If parent directories of C<$filename> don't exist they will be
automagically created.

The generated file will be automatically deleted at the end of the
program's execution.

This function is exported by default.

=item t_append_file()

  t_append_file($filename, @lines);

t_append_file() is similar to t_write_file(), but it doesn't clobber
existing files and appends C<@lines> to the end of the file. If the
file doesn't exist it will create it.

If parent directories of C<$filename> don't exist they will be
automagically created.

The generated file will be registered to be automatically deleted at
the end of the program's execution, only if the file was created by
t_append_file().

This function is exported by default.

=item t_write_shell_script()

  Apache::TestUtil::t_write_shell_script($filename, @lines);

( run in 1.163 second using v1.01-cache-2.11-cpan-39bf76dae61 )