view release on metacpan or  search on metacpan

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

    # if the generated config was created with a version of Apache-Test
    # less than the current version
    {
      my $current = Apache::Test->VERSION;
      my $config  = $self->{apache_test_version};

      if (! $config || $config < $current) {
          push @reasons, "configuration generated with old Apache-Test";
      }
    }

    return @reasons;
}

sub error_log {
    my($self, $rel) = @_;
    my $file = catfile $self->{vars}->{t_logs}, 'error_log';
    my $rfile = abs2rel $file, $self->{vars}->{top_dir};
    return wantarray ? ($file, $rfile) :
      $rel ? $rfile : $file;
}

#utils

#For Win32 systems, stores the extensions used for executable files
#They may be . prefixed, so we will strip the leading periods.

my @path_ext = ();

if (WIN32) {
    if ($ENV{PATHEXT}) {
        push @path_ext, split ';', $ENV{PATHEXT};
        for my $ext (@path_ext) {
            $ext =~ s/^\.*(.+)$/$1/;
        }
    }
    else {
        #Win9X: doesn't have PATHEXT
        push @path_ext, qw(com exe bat);
    }
}

sub which {
    my $program = shift;

    return undef unless $program;

    # No need to search PATH components
    # if $program already contains a path
    return $program if !OSX and !WINFU and
        $program =~ /\// and -f $program and -x $program;

    my @dirs = File::Spec->path();

    require Config;
    my $perl_bin = $Config::Config{bin} || '';
    push @dirs, $perl_bin if $perl_bin and -d $perl_bin;

    for my $base (map { catfile $_, $program } @dirs) {
        if ($ENV{HOME} and not WIN32) {
            # only works on Unix, but that's normal:
            # on Win32 the shell doesn't have special treatment of '~'
            $base =~ s/~/$ENV{HOME}/o;
        }

        return $base if -x $base && -f _;

        if (WIN32) {
            for my $ext (@path_ext) {
                return "$base.$ext" if -x "$base.$ext" && -f _;
            }
        }
    }
}

sub apxs {
    my($self, $q, $ok_fail) = @_;
    return unless $self->{APXS};
    my $val;
    unless (exists $self->{_apxs}{$q}) {
        local @ENV{ qw(IFS CDPATH ENV BASH_ENV) };
        local $ENV{PATH} = untaint_path($ENV{PATH});
        my $devnull = devnull();
        my $apxs = shell_ready($self->{APXS});
        $val = qx($apxs -q $q 2>$devnull);
        chomp $val if defined $val; # apxs post-2.0.40 adds a new line
        if ($val) {
            $self->{_apxs}{$q} = $val;
        }
        unless ($val) {
            if ($ok_fail) {
                return "";
            }
            else {
                warn "APXS ($self->{APXS}) query for $q failed\n";
                return $val;
            }
        }
    }
    $self->{_apxs}{$q};
}

# return an untainted PATH
sub untaint_path {
    my $path = shift;
    return '' unless defined $path;
    ($path) = ( $path =~ /(.*)/ );
    # win32 uses ';' for a path separator, assume others use ':'
    my $sep = WIN32 ? ';' : ':';
    # -T disallows relative and empty directories in the PATH
    return join $sep, grep File::Spec->file_name_is_absolute($_),
        grep length($_), split /$sep/, $path;
}

sub pop_dir {
    my $dir = shift;

    my @chunks = splitdir $dir;
    while (my $remove = shift) {
        pop @chunks if $chunks[-1] eq $remove;
    }