view release on metacpan or  search on metacpan

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

    }
    $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;
    }

    catfile @chunks;
}

sub add_inc {
    my $self = shift;
    return if $ENV{MOD_PERL}; #already setup by mod_perl
    require lib;
    # make sure that Apache-Test/lib will be first in @INC,
    # followed by modperl-2.0/lib (or some other project's lib/),
    # followed by blib/ and finally system-wide libs.
    my $top_dir = $self->{vars}->{top_dir};
    my @dirs = map { catdir $top_dir, "blib", $_ } qw(lib arch);

    my $apache_test_dir = catdir $top_dir, "Apache-Test";
    unshift @dirs, $apache_test_dir if -d $apache_test_dir;

    lib::->import(@dirs);

    if ($ENV{APACHE_TEST_LIVE_DEV}) {
        # add lib/ in a separate call to ensure that it'll end up on
        # top of @INC
        my $lib_dir = catdir $top_dir, "lib";
        lib::->import($lib_dir) if -d $lib_dir;
    }

    #print join "\n", "add_inc", @INC, "";
}

#freeze/thaw so other processes can access config

sub thaw {
    my $class = shift;
    $class->new({thaw => 1, @_});
}

sub freeze {
    require Data::Dumper;
    local $Data::Dumper::Terse = 1;
    my $data = Data::Dumper::Dumper(shift);
    chomp $data;
    $data;
}

sub sync_vars {
    my $self = shift;

    return if $self->{save}; #this is not a cached config

    my $changed = 0;
    my $thaw = $self->thaw;
    my $tvars = $thaw->{vars};
    my $svars = $self->{vars};

    for my $key (@_) {
        for my $v ($tvars, $svars) {
            if (exists $v->{$key} and not defined $v->{$key}) {
                $v->{$key} = ''; #rid undef
            }
        }
        next if exists $tvars->{$key} and exists $svars->{$key} and
                       $tvars->{$key} eq $svars->{$key};
        $tvars->{$key} = $svars->{$key};
        $changed = 1;
    }

    return unless $changed;

    $thaw->{save} = 1;
    $thaw->save;
}

sub save {
    my($self) = @_;

    return unless $self->{save};

    # add in the Apache-Test version for later comparisions
    $self->{apache_test_version} = Apache::Test->VERSION;

    my $name = 'apache_test_config';
    my $file = catfile $self->{vars}->{t_conf}, "$name.pm";
    my $fh = $self->genfile($file);

    debug "saving config data to $name.pm";

    (my $obj = $self->freeze) =~ s/^/    /;

    print $fh <<EOF;
package $name;

sub new {
$obj;
}

1;
EOF

    close $fh or die "failed to write $file: $!";
}