Apache-Test
3 results

 view release on metacpan or  search on metacpan

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

# 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;
	    unless (defined $line) { # EOF
		select undef, undef, undef, 0.1;
		$timeout--;

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

        elsif ($ref_a eq 'HASH' && $ref_b eq 'HASH') {
            return 0 unless (keys %$a) == (keys %$b);
            for my $key (sort keys %$a) {
                return 0 unless exists $b->{$key};
                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

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

    t_write_file($file, $shebang, $warning, @_);
    chmod 0755, $file;
}


sub t_mkdir {
    my $dir = shift;
    makepath($dir);
}

# returns a list of dirs successfully created
sub makepath {
    my($path) = @_;

    return if !defined($path) || -e $path;
    my $full_path = $path;

    # remember which dirs were created and should be cleaned up
    while (1) {
        $CLEAN{dirs}{$path} = 1;
        $path = dirname $path;
        last if -e $path;
    }

    return File::Path::mkpath($full_path, 0, 0755);
}

sub t_rmtree {
    die "must pass a dirname" unless defined $_[0];
    File::Path::rmtree((@_ > 1 ? \@_ : $_[0]), 0, 1);
}

#chown a file or directory to the test User/Group
#noop if chown is unsupported

sub t_chown {
    my $file = shift;
    my $config = Apache::Test::config();
    my($uid, $gid);

    eval {
        #XXX cache this lookup
        ($uid, $gid) = (getpwnam($config->{vars}->{user}))[2,3];
    };

    if ($@) {
        if ($@ =~ /^The getpwnam function is unimplemented/) {
            #ok if unsupported, e.g. win32
            return 1;
        }
        else {
            die $@;
        }
    }

    CORE::chown($uid, $gid, $file) || die "chown $file: $!";
}

# $string = struct_as_string($indent_level, $var);
#
# return any nested datastructure via Data::Dumper or ala Data::Dumper
# as a string. undef() is a valid arg.
#
# $indent_level should be 0 (used for nice indentation during
# recursive datastructure traversal)
sub struct_as_string{
    return "???"   unless @_ == 2;
    my $level = shift;

    return "undef" unless defined $_[0];
    my $pad  = ' ' x (($level + 1) * INDENT);
    my $spad = ' ' x ($level       * INDENT);

    if (HAS_DUMPER) {
        local $Data::Dumper::Terse = 1;
        $Data::Dumper::Terse = $Data::Dumper::Terse; # warn
        my $data = Data::Dumper::Dumper(@_);
        $data =~ s/\n$//; # \n is handled by the caller
        return $data;
    }
    else {
        if (ref($_[0]) eq 'ARRAY') {
            my @data = ();
            for my $i (0..$#{ $_[0] }) {
                push @data,
                    struct_as_string($level+1, $_[0]->[$i]);
            }
            return join "\n", "[", map({"$pad$_,"} @data), "$spad\]";
        } elsif ( ref($_[0])eq 'HASH') {
            my @data = ();
            for my $key (keys %{ $_[0] }) {
                push @data,
                    "$key => " .
                    struct_as_string($level+1, $_[0]->{$key});
            }
            return join "\n", "{", map({"$pad$_,"} @data), "$spad\}";
        } else {
            return $_[0];
        }
    }
}

my $banner_format =
    "\n*** The following %s expected and harmless ***\n";

sub is_expected_banner {
    my $type  = shift;
    my $count = @_ ? shift : 1;
    sprintf $banner_format, $count == 1
        ? "$type entry is"
        : "$count $type entries are";
}

sub t_server_log_is_expected {
    print STDERR is_expected_banner(@_);
}

sub t_client_log_is_expected {
    my $vars = Apache::Test::config()->{vars};
    my $log_file = catfile $vars->{serverroot}, "logs", "error_log";

    my $fh = Symbol::gensym();
    open $fh, ">>$log_file" or die "Can't open $log_file: $!";
    my $oldfh = select($fh); $| = 1; select($oldfh);
    print $fh is_expected_banner(@_);
    close $fh;
}

sub t_server_log_error_is_expected { t_server_log_is_expected("error", @_);}
sub t_server_log_warn_is_expected  { t_server_log_is_expected("warn", @_); }
sub t_client_log_error_is_expected { t_client_log_is_expected("error", @_);}
sub t_client_log_warn_is_expected  { t_client_log_is_expected("warn", @_); }

END {
    # remove files that were created via this package
    for (grep {-e $_ && -f _ } keys %{ $CLEAN{files} } ) {
        t_debug("removing file: $_");



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