package Apache::FakeRequest;
# vim: set expandtab ts=4 sts=4:

$Apache::FakeRequest::VERSION = "1.10";

=head1 NAME

Apache::FakeRequest - fake request object for debugging

=head1 SYNOPSIS

    use Apache::FakeRequest;
    my $request = Apache::FakeRequest->new(method_name => 'value', ...);

=head1 DESCRIPTION

B<Apache::FakeRequest> is used to set up an empty Apache request
object that can be used for debugging.  The B<Apache::FakeRequest>
methods just set internal variables of the same name as the method and
return the value of the internal variables.  Initial values for
methods can be specified when the object is created.  The I<print>
method prints to STDOUT.

Subroutines for Apache constants are also defined so that using
B<Apache::Constants> while debugging works, although the values of the
constants are hard-coded rather than extracted from the Apache source
code.

B<Simple example:>

    #!/usr/bin/perl

    use Apache::FakeRequest ();
    use mymodule ();

    my $request = Apache::FakeRequest->new('get_remote_host'=>'foobar.com');
    my $return_value = mymodule::handler($request);

B<Types of options:>

Starting with this version, B<Apache::FakeRequest> supports not only scalar
values for options. This allows you to very easily support more Apache-like
behaviour. And some reasonable (I hope) defaults are provided for many of the
options.

=over 8

=item B<scalar options>

These work just like in the older version:

    my $r = new Apache::FakeRequest( method => "foo" );

    print $r->method(), "\n"; # prints "foo"
    $r->method("bar");
    print $r->method(), "\n"; # prints "bar"

=item B<array options>

These allow a stack-like behavior.

    my $r = new Apache::FakeRequest( method => [] );

    $r->method("foo");
    $r->method("bar");
    $r->method("baz");

    print $r->method->[1], "\n"; # prints "bar"
    print join (',', $r->method), "\n"; # prints "foo,bar,baz"
    pop $r->method;
    print join (',', $r->method), "\n"; # prints "foo,bar"

=item B<hash options>

These work just like $r->header_in() and $r->header_out() and similar key/value
method calls.

    my $r = new Apache::FakeRequest( method => {} );

    $r->method(foo => "bar");
    $r->method(bar => "baz");
    
    for (keys $r->method) { print "$_\n" } # will print foo and bar
    my (%h) = ($r->method); # Get a copy of the hash.
    my $table = $r->method; # Get an instance of Apache::Table referring to the
                            # hash. Can be used as hash reference too.

    print $r->method("bar"), "\n"; # Prints "foo".

=item B<coderef options>

These let you plug in your own subroutine if the other methods are not
sufficiently powerful.

    my $closure;
    {
        my $counter = 1;
        $closure = sub { $counter++ };
    }

    my $r = new Apache::FakeRequest ( method => $closure );

=back

In addition, the constructor takes the following options, which are
distinguished from methods by being upper case:

=over 8

=item B<PRINT_HEADER>

If this option is set, the $r->send_http_header method will print some headers
to STDOUT, including any set through content_xxx and header_out.

=item B<PRINT_LOG>

Will print messages from $r->log_error and the like to STDERR. They
are available as arrays of stacked messages in $r->log_error, $r->warn and
$r->log_reason regardless.

=back

=head1 METHODS

These are methods implemented separately from parameter system just described.

=over 8

=cut

=item B<new Apache::FakeRequest ( method =E<gt> value, OPTION =E<gt> value, ... )>

Pre-sets any methods and sets any options on a new B<Apache::FakeRequest>
object.

=cut
sub new {
    my $class = ref $_[0] || $_[0]; shift;
    my $self  = bless {@_}, $class;

# Set up some defaults.
    $self->{method} ||= 'GET';

    unless (exists $self->{method_number}) {
        no strict 'refs';

        my $method_number =
            *{'Apache::Constants::M_'.$self->{method}}{CODE};

        if (defined $method_number) {
            $self->{method_number} = &$method_number();
        }
    }
    
    $self->{is_main} = 1 unless exists $self->{is_main};
    $self->{is_initial_req} = 1 unless exists $self->{is_initial_req};

    $self->{the_request} ||= $self->{method}.' /'.(caller)[0].
        (exists $self->{args} ? '?'.$self->{args}.' ' : ' ').
        'HTTP/1.0';

    $self->{headers_in} ||= bless {
        'Connection'    => 'Keep-Alive',
        'User-Agent'    => 'Mozilla/4.73 [en] (X11; I; Linux 2.2.15 i586)',
        'Host'          => 'host.domain.com',
        'Accept'        => 'image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, image/png, */*',
        'Accept-Encoding'   => 'gzip',
        'Accept-Language'   => 'en',
        'Accept-Charset'    => 'iso-8859-1,*,utf-8'
    }, 'Apache::Table';

    $self->{get_remote_host}    ||= 'localhost';
    $self->{get_remote_logname} ||= getpwent();

    $self->{dir_config} ||= {};
    $self->{document_root} ||= '.';
    $self->{get_server_port} ||= 80;

    $self->{headers_out} ||= {};
    $self->{header_out}  ||= $self->{headers_out};

    $self->{content_type} ||= "text/html";
    $self->{content_languages} ||= [ qw( en ) ];

    $self->{server} ||= new Apache::Server();

    return $self;
}

=item B<AUTOLOAD>

Creates and installs any methods that aren't explicitly declared in
Apache::FakeRequest, using a slot in the object's hash to hold the data for
that method. See above about behaviour related to data types and contexts.

=cut
sub AUTOLOAD {
    use vars qw($AUTOLOAD);

    my $method = $AUTOLOAD;
    $method   =~ s/.*:://;
	{
        no strict 'refs';

        my $method_handler = sub {
            my ($self, $val, $val2, @rest) = @_;

            my $slot = $self->{$method};

            if (UNIVERSAL::isa($slot, 'ARRAY')) {
                if (UNIVERSAL::isa($val, 'ARRAY')) {
                    $self->{$method} = $val;
                } elsif (defined $val) {
                    push @$slot, $val;
                }
                return wantarray ? @$slot : $slot;
            } elsif (UNIVERSAL::isa($slot, 'HASH')) {
                if (UNIVERSAL::isa($val, 'HASH')) {
                    $self->{$method} = $val;
                } elsif (defined $val) {
                    $slot->{$val} = $val2 if defined $val2;
                    return $slot->{$val};
                }
                return wantarray ? @$slot : bless $slot, 'Apache::Table';
            } elsif (UNIVERSAL::isa($slot, 'CODE')) {
                if (UNIVERSAL::isa($val, 'CODE')) {
                    $self->{$method} = $val;
                } elsif (defined $val) {
                    return $slot->($val, $val2, @rest);
                }
                return $slot;
            } else {
                $self->{$method}  = $val if $val;
                return $self->{$method};
            }
        };
        *{$AUTOLOAD} = $method_handler;

        goto &$method_handler;
    }
}

### Implemented bits of the Apache API.

=item B<$r-E<gt>args( [$val] )>

Should be given to B<new> as a string, will split to a list in a list context,
or return the string in a scalar context, eg.:

    $r->args("foo=bar&bar=baz");
    %args = $r->args;
    # %args now contains ( foo => "bar", bar => "baz" );
    $args = $r->args;
    # $args has "foo=bar&bar=baz"

=cut
sub args {
    my($self,$val) = @_;
    $self->{args} = $val if $val;
    _parseArgs(wantarray, $self->{args});
}

=item B<$r-E<gt>as_string()>

Prints out a dump of the object using Data::Dumper.

=cut
sub as_string {
    use Data::Dumper;
    my $self = shift;
    return Dumper($self);
}

=item B<$r-E<gt>connection()>

Returns an instance of a fake Apache::Connection object, which may or may not
suit your purposes. The class itself is implemented similarly to
Apache::FakeRequest, so you can set various methods on it. The B<fileno> method
just returns STDIN/STDOUT.

=cut
sub connection {
    return new Apache::Connection(@_);
}

=item B<$r-E<gt>content( [$val] )>

Works in the same way as B<$r-E<gt>args( [$val] )>. Used for parsing form data.

=cut
sub content {
    my($r,$val) = @_;
    $r->{content} = $val if $val;
    _parseArgs(wantarray, $r->{content});
}

=item B<$r-E<gt>print( $string )>

Prints a string to STDOUT.

=cut
sub print { shift; CORE::print(@_) }

=item B<$r->E<gt>header_in ( $key [, $value] )>

Just an alias for B<$r->E<gt>header_in ( $key [, $value] )> which behaves in
exactly the same way, on the same data.

=cut
sub header_in {
    my ($self, $header, $value) = @_;
    $self->{headers_in}{$header} = $value if $value;
    return $self->{headers_in}{$header};
}

=item B<$r->E<gt>log_error ( $message )>

Prints a message to STDERR if the PRINT_LOG option is set, also saves the
message.

If called in list context, returns the list of saved messages.

=cut
sub log_error {
    my ($self, $message) = @_;

    if ($message) {
        if ($self->{PRINT_LOG}) {
            print STDERR "$message\n";
        }
    
        push @{$self->{log_error}}, $message;
    }

    return @{$self->{log_error}} if wantarray;
}

=item B<$r->E<gt>log_reason ( $message )>

Prints a message to STDERR if the PRINT_LOG option is set, also saves the
message.

If called in list context, returns the list of saved messages.

=cut
sub log_reason {
    my ($self, $message) = @_;

    if ($message) {
        if ($self->{PRINT_LOG}) {
            print STDERR "The request failed because: $message\n";
        }
    
        push @{$self->{log_reason}}, $message;
    }

    return @{$self->{log_reason}} if wantarray;
}

=item B<$r->E<gt>no_cache ()>

Removes any Expires header from the headers_out.

=cut
sub no_cache {
    my $self = shift;
    delete $self->{headers_out}{Expires};
}

=item B<$r->E<gt>request ( $key [, $value] )>

Alias for B<Apache-E<gt>request>.

=cut
sub request {
    my $self = shift;
    Apache->request(@_);
}

=item B<$r->E<gt>send_fd ( FILE )>

Prints out the contents of FILE on STDOUT.

=cut
sub send_fd {
    my ($self, $fh) = @_;
    print STDOUT <$fh>;
}

=item B<$r->E<gt>send_http_header ()>

Prints out a fake header if the PRINT_HEADER option is set. The header uses
some hardcoded values and anything set via B<header_out> and B<content_xxx>.

=cut
sub send_http_header {
    my $self = shift;

    if ($self->{PRINT_HEADER}) {
        print "HTTP/1.1 200 OK\n";

        my $date = exists $self->{headers_out}{Date} ?
                    $self->{headers_out}{Date} :
                    time2str(time);
        my $server = exists $self->{headers_out}{Server} ?
                    $self->{headers_out}{Server} :
"Apache/1.3.12 (Unix) Debian/GNU mod_perl/1.23 PHP/4.0.1pl2 ApacheJServ/1.1.2";

        print "Date: $date\n";
        print "Server: $server\n";

        for ($self->{headers_out}) {
            print "$_: ", $self->{headers_out}{$_}, "\n";
        }

        print "Connection: close\n";
        # Is this right?
        print "Content-Language: ",
            join (',', @{$self->{content_languages}}), "\n";

        print "Content-Encoding: ", $self->{content_encoding}, "\n"
            if exists $self->{content_encoding};

        print "Content-Type: ", $self->{content_type}, "\n";
    }
}

=item B<$r->E<gt>warn ( $message )>

Prints a message to STDERR if the PRINT_LOG option is set, also saves the
message.

If called in list context, returns the list of saved messages.

=cut
sub warn {
    my ($self, $message) = @_;

    if ($message) {
        if ($self->{PRINT_LOG}) {
            print STDERR "$message\n";
        }
    
        push @{$self->{'warn'}}, $message;
    }

    return @{$self->{'warn'}} if wantarray;
}

# Utilities.

sub _parseArgs {
    my($wantarray,$string) = @_;
    return unless defined $string and $string;
    if(defined $wantarray and $wantarray) {
        return map { 
	    s/%([0-9a-fA-F]{2})/pack("c",hex($1))/ge;
	    $_;
	} split /[=&;]/, $string, -1;
    }
    $string;
}

package Apache;

{
    my $stored_request;

=item B<Apache-E<gt>request ( $request )>

Works just like the real Apache->request, for code that needs to store a
reference to the current request somewhere.

=cut
    sub request {
        my ($self, $r) = @_;

        $stored_request = $r if $r;
        return $stored_request;
    }
}

=item B<Apache-E<gt>server ()>

Returns an instance of a fake B<Apache::Server> class, same as the default
B<$r-E<gt>server>. The B<Apache::Server> comes with some defaults, and works
just like B<Apache::FakeRequest> itself.

=cut
sub server {
    return new Apache::Server(@_);
}

package Apache::Connection;

sub new {
    my $class = ref $_[0] || $_[0]; shift;
    my $self  = bless {@_}, $class;

    $self->{remote_host} ||= 'localhost';
    $self->{remote_ip} ||= 'localhost';
    $self->{remote_logname} ||= getpwent();

    return $self;
}

sub AUTOLOAD {
    goto &Apache::FakeRequest::AUTOLOAD;
}

sub aborted        { eof STDIN  }

sub fileno {
    my ($self, $direction) = @_;

    if (defined $direction && $direction == 0) {
        return fileno STDIN;
    } else {
        return fileno STDOUT;
    }
}

package Apache::Server;

sub new {
    my $class = ref $_[0] || $_[0]; shift;
    my $self  = bless {@_}, $class;

    $self->{server_admin} ||= (scalar getpwent).'@localhost';
    $self->{server_hostname} ||= 'localhost';
    $self->{port} ||= 80;
    $self->{is_virtual} = 0 unless defined $self->{is_virtual};
    $self->{dir_config} ||= {};
    $self->{warn} ||= [];
    $self->{log_error} ||= [];
    $self->{uid} ||= $>;
    $self->{gid} ||= $);
    {
        use Apache::Log;
        $self->{loglevel} ||= Apache::Log::DEBUG;
    }
    $self->{get_handlers}  ||= {};
    $self->{set_handlers}  ||= $self->{get_handlers};
    $self->{push_handlers} ||= $self->{get_handlers};

    return $self;
}

sub AUTOLOAD {
    goto &Apache::FakeRequest::AUTOLOAD;
}

package Apache::Constants;

sub OK          		{  0 }
sub DECLINED    		{ -1 }
sub DONE        		{ -2 }

sub CONTINUE                    { 100 }
sub DOCUMENT_FOLLOWS            { 200 }
sub NOT_AUTHORITATIVE           { 203 }
sub HTTP_NO_CONTENT             { 204 }
sub MOVED                       { 301 }
sub REDIRECT                    { 302 }
sub USE_LOCAL_COPY              { 304 }
sub HTTP_NOT_MODIFIED           { 304 }
sub BAD_REQUEST                 { 400 }
sub AUTH_REQUIRED               { 401 }
sub FORBIDDEN                   { 403 }
sub NOT_FOUND                   { 404 }
sub HTTP_METHOD_NOT_ALLOWED     { 405 }
sub HTTP_NOT_ACCEPTABLE         { 406 }
sub HTTP_LENGTH_REQUIRED        { 411 }
sub HTTP_PRECONDITION_FAILED    { 412 }
sub SERVER_ERROR                { 500 }
sub NOT_IMPLEMENTED             { 501 }
sub BAD_GATEWAY                 { 502 }
sub HTTP_SERVICE_UNAVAILABLE    { 503 }
sub HTTP_VARIANT_ALSO_VARIES    { 506 }

# methods

sub M_GET       { 0 }
sub M_PUT       { 1 }
sub M_POST      { 2 }
sub M_DELETE    { 3 }
sub M_CONNECT   { 4 }
sub M_OPTIONS   { 5 }
sub M_TRACE     { 6 }
sub M_INVALID   { 7 }

# options

sub OPT_NONE      {   0 }
sub OPT_INDEXES   {   1 }
sub OPT_INCLUDES  {   2 }
sub OPT_SYM_LINKS {   4 }
sub OPT_EXECCGI   {   8 }
sub OPT_UNSET     {  16 }
sub OPT_INCNOEXEC {  32 }
sub OPT_SYM_OWNER {  64 }
sub OPT_MULTI     { 128 }
sub OPT_ALL       {  15 }

# satisfy

sub SATISFY_ALL    { 0 }
sub SATISFY_ANY    { 1 }
sub SATISFY_NOSPEC { 2 }

# remotehost

sub REMOTE_HOST       { 0 }
sub REMOTE_NAME       { 1 }
sub REMOTE_NOLOOKUP   { 2 }
sub REMOTE_DOUBLE_REV { 3 }



sub MODULE_MAGIC_NUMBER { "The answer is 42" }
sub SERVER_VERSION      { "1.x" }
sub SERVER_BUILT        { "199908" }


1;

__END__

=back

=head1 OVERRIDING METHODS

If you need different functionality from that provided in one of the simulated
methods, just override it in the following manner:

    ...your code here...

    package Apache::FakeRequest;

    sub print {
        my $self = shift;
        CORE::print(join "\n", @_);
    }

    package main; # back to whatever package you are working in.

=head1 AUTHORS

Original version by Doug MacEachern, with contributions from Andrew Ford
<A.Ford@ford-mason.co.uk>.

Rewritten by Rafael Kitover (caelum@debian.org) around 9/15/2000.

=head1 BUGS

Probably a few.

=head1 TODO

Don't think this thing needs to be perfect, but there's room for improvement.

=head1 SEE ALSO

L<perl>,
L<mod_perl>,
L<Apache>