view release on metacpan or  search on metacpan

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

    my($ext, $shebang);

    if (Apache::TestConfig::WIN32()) {
        $code =~ s/echo$/echo./mg; #required to echo newline
        $ext = 'bat';
        $shebang = "\@echo off\nREM this is a bat";
    }
    else {
        $ext = 'sh';
        $shebang = '#!/bin/sh';
    }

    $file .= ".$ext";
    t_write_file($file, "$shebang\n", $code);
    $ext;
}

sub t_write_perl_script {
    my $file = shift;

    my $shebang = "#!$Config{perlpath}\n";
    my $warning = Apache::TestConfig->thaw->genwarning($file);
    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(@_);
}