tags/v1_29/t/TestDirectives/TestDirectives.pm

package Apache::TestDirectives;

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

use DynaLoader (); 
use Apache::Constants qw(DECLINE_CMD);

eval {
  require Apache::ModuleConfig;
};
use Data::Dumper 'Dumper';

@ISA = qw(DynaLoader TestDirectives::Base);

$VERSION = '0.01';

if($ENV{MOD_PERL}) {
    bootstrap Apache::TestDirectives $VERSION;
}

sub attr {
    my($self,$k,$v) = @_;
    $self->{$k} = $v;
}

sub Port ($$$) {
    my($cfg, $parms, $port) = @_;
    warn "$cfg->Port will be $port\n";
    $cfg->{Port} = $port;
    return DECLINE_CMD();
}

sub TestCmd ($$$$) {
    my($cfg, $parms, $one, $two) = @_;
    #warn "TestCmd called with args: `$one', `$two'\n";
    $cfg->attr(TestCmd => [$one,$two]);
    $parms->server->isa("Apache::Server") or die "parms->server busted";
    my $or = $parms->override;
    my $limit = $parms->limited;
    #warn Dumper($cfg), $/;
}

sub AnotherCmd () {
    die "prototype check broken [@_]" if @_ > 0;
}

sub CmdIterate ($$@) {
    my($cfg, $parms, @data) = @_;
    $cfg->{CmdIterate} = [@data];
    $cfg->{path} = $parms->path;
}

sub another_cmd {
    my($cfg, $parms, @data) = @_;
    warn "($cfg, $parms, @data)\n";
    $parms->info =~ /YAC/ or die "parms->info busted";
    $cfg->{parms_info_from_another_cmd} = $parms->info;
    warn "$cfg->YAC called\n";
}

sub Container ($$$;*) {
    my($cfg, $parms, $arg, $fh) = @_;
    $arg =~ s/>//;
    warn "ARG=$arg\n";
    #while($parms->getline($line)) {
    while(defined(my $line = <$fh>)) {
	last if $line =~ m:</Container>:i;
	warn "LINE=`$line'\n";
    }
}

sub Container_END () {
    die "</Container> outside a <Container>\n";
}

use Apache::ExtUtils ();
my $proto_perl2c = Apache::ExtUtils->proto_perl2c;

my $code = "";
while(my($pp,$cp) = each %$proto_perl2c) {
    next unless $pp;
    $code .= <<SUB;
sub $cp ($pp) { 
    warn "$cp called with args: ", (map "`\$_', ", \@_), "\n";
    my(\$cfg, \$parms, \@args) = \@_;
    \$cfg->attr($cp => [\@args]) if ref(\$cfg);
}
SUB
}

eval $code; die $@ if $@;

package TestDirectives::Base;

sub DIR_CREATE {
    my($class, $parms) = @_;
    my $info = $parms->info;
    my $o = $parms->override;
    warn "$class->new called info=`$info',override=`$o'\n";
    return bless {
	FromNew => __PACKAGE__,
	path => $parms->path || "",
    }, $class;
}

sub DIR_MERGE {
    my($base, $add) = @_;
    my %new = ();
    @new{ keys %$base, keys %$add} = 
	(values %$base, values %$add);

    return bless \%new, ref($base);
}

*SERVER_MERGE = \&DIR_MERGE;

sub SERVER_CREATE {
    my($class, $parms) = @_;
    warn "$class->SERVER_CREATE\n";
    return bless {
	ServerClass => __PACKAGE__,
    }, $class;
}
 
1;
__END__