#!/usr/local/bin/perl
# ========================================================================
# tsp - fake an Apache request object
# Andrew Ho (andrew@tellme.com)
# Jim Li (jiml@tellme.com)
#
# Usage: tsp [script]
#
# Provides a fake Apache request object to use for testing, for example,
# an Apache::Registry script. Prompts for name=value pairs just like the
# CGI module does. Apache::Request and Apache::Cookie are also overridden
# with fake methods that try to do the right thing.
#
# The file does some special handling for Tellme-Apache-TSP files.  It
# will route calls through the handler, to fake the entire TSP process.
#
# Copyright (c) 2001 Tellme Networks, Inc. All rights reserved.
#
# You may freely use, redistribute, or edit this script as long as this
# comment block, and attribution of authorship, is kept intact.
#
# Last modified April 16, 2001
# ========================================================================

package Apache;
require 5.6.0;
use strict;
use warnings;
no warnings qw(redefine);

use Tie::IxHash;
use File::Basename;

use vars qw($VERSION);
$VERSION = 1.0;


# ------------------------------------------------------------------------
# THE REQUEST OBJECT

# When a new Apache request is created, create a few tied hashes to use
# for header fields and, if run interactively, prompt for name=value
# pairs like CGI.pm does.

sub request {
    my $class = shift;
    my $self = {};


    # The headers_in and headers_out attributes are just tied hashes
    # that maintain insertion order. Unfortunately, this means that
    # they will function incorrectly in that repeated HTTP headers
    # will be chomped.

    $self->{headers_in} = {};
    tie %{$self->{headers_in}}, 'Tie::IxHash';

    $self->{headers_out} = {};
    tie %{$self->{headers_out}}, 'Tie::IxHash';


    # A little levity doesn't hurt.

    $self->{headers_out}->{Server} = 'Schmapache 1.0';


    # These are our internal book-keeping fields in which we stash
    # CGI parameters and cookies as hashes. When we create an Apache
    # request object, prompt the user for CGI parameters (cookies will
    # only be added if you use Apache::Cookie and call fetch()).

    $self->{_apr_param} = {};
    $self->{_apr_cookie} = {};

    if(-t STDIN && -t STDERR) {
        print STDERR "(offline mode: enter name=value pairs on standard input)\n";
        while(<STDIN>) {
            chomp; s/^\s+//; s/\s+$//; s/^[\?&]+//;
            while($_ && s/^([^&]+)\&*//) {
                my($key, $value) = split(/=/, $1, 2);
                if(defined($key) && defined($value)) {
                    $self->{_apr_param}->{$key} = $value;
                } elsif($1) {
                    $self->{_apr_param}->{$1} = undef;
                }
            }
        }
    }


    return bless $self, $class;
}

sub as_string {
    my $self = shift;
    print "as_string()\n";
}


# These are all meaningless without the context of a real Apache request
# chain, so we provide as reasonable defaults as we can.

sub main           { undef }
sub prev           { undef }
sub next           { undef }
sub last           { undef }
sub is_main        { 1 }
sub is_initial_req { 1 }


# ------------------------------------------------------------------------
# Request object parameters

sub finfo    { 
    my $self = shift;

    #$self->{_stat} or do { stat shift->filename; $self->{_stat} = _ };
    $self->filename;
}
sub filename { shift->_access_or_mutate('filename', @_) }
sub chdir_file { chdir(dirname shift->filename) }


# ------------------------------------------------------------------------
# SUB REQUESTS

sub lookup_uri  {}
sub lookup_file {}
sub run {}


# ------------------------------------------------------------------------
# CLIENT REQUEST PARAMETERS

sub method { shift->_access_or_mutate('method', @_) }

# sub method_number { }
# sub bytes_sent { }
# sub the_request { }

sub proxyreq    { return }
sub header_only { return }

sub protocol { 'HTTP/1.0' }

sub hostname { require Sys::Hostname; Sys::Hostname::hostname() }
sub request_time { time }

# sub uri
# sub filename
# sub path_info

sub args {
    my $self = shift;
    wantarray ?
        $self->{_apr_param} :
        join '&', map { ( $_ => $self->{_apr_param}->{$_} ) }
                      keys %{$self->{_apr_param}} ;
}

# sub headers_in { }
# sub header_in { }
# sub content { }
# sub read { }
# sub get_remote_host { }
# sub get_remote_logname { }


# Internal method that encapsulates the typical functionality of "access,
# or mutate if an argument was given" that is very common.

sub _access_or_mutate {
    my($self, $key, $value) = @_;
    if($self && $key) {
        $self->{$key} = $value if $value;
        return $self->{$key};
    } else {
        return;
    }
}


# ------------------------------------------------------------------------
# SERVER CONFIGURATION INFORMATION

# ------------------------------------------------------------------------
# SETTING UP THE RESPONSE

sub send_http_header {
    my $self = shift;

    $self->{_status} = 200 unless defined $self->{_status};

    print "\n\nHTTP/x.x $self->{_status}\n";
    my $header_set = ($self->{_status} >= 400) ? 
                     "err_headers_out" :"headers_out";

    while(my($key, $value) = each %{$self->{headers_out}}) {
        print $key, ': ', $value, "\n" unless not defined $value;
    }
    print "\n";
}

# sub get_basic_auth_pw { }
# sub note_basic_auth_failure { }
# sub handler { }
# sub notes { }
# sub pnotes { }
# sub subprocess_env { }

sub content_type      { shift->header_out( 'Content-Type' => shift ) }
sub content_encoding  { shift->header_out( 'Content-Encoding' => shift ) }
sub content_languages {
    my $languages = shift;
    shift->header_out( 'Content-Language' => join ',', @{$languages} );
}

sub status { 
    my ($self, $status) = @_;  
    if (defined $status) { 
        $self->{_status} = $status; 
    } else { 
        $self->{_status};
    }
}
# sub status_line { }

# sub headers_out { }

sub header_out {
    my $self = shift;
    my($key, $value) = @_;
    die 'usage: $r->header_out($key => $value)' unless $key;
    $self->{headers_out}->{$key} = $value;
}

# sub err_headers_out { }
sub err_header_out {
    my $self = shift;
    my($key, $value) = @_;
    die 'usage: $r->err_header_out($key => $value)' unless $key;
    $self->{err_headers_out}->{$key} = $value;
}

sub no_cache {
    my $self = shift;
    if(shift) {
        $self->header_out( 'Cache-Control' => 'no-cache' );
        $self->header_out( 'Pragma' => 'no-cache' );
    }
}

sub print {
    my $self = shift;
    my @args = @_;

    CORE::print(map { (ref $_ eq 'SCALAR') ? $$_ : $_ } @args) if @args;
}

sub send_fd {
    my $self = shift;
    my $fh = shift;
    $self->print($_) while <$fh>;
}

# sub internal_redirect { }
# sub internal_redirect_handler { }
# sub custom_response { }


# ------------------------------------------------------------------------
# SERVER CORE FUNCTIONS

# "General... you must look to your division."
# "General... I have no division."

sub soft_timeout  { shift->log_warn('soft_timeout() is a noop') }
sub hard_timeout  { shift->log_warn('hard_timeout() is a noop') }
sub kill_timeout  { shift->log_warn('kill_timeout() is a noop') }
sub reset_timeout { shift->log_warn('reset_timeout() is a noop') }

sub post_connection  { shift->log_warn('post_connection() is a noop') }
sub register_cleanup { shift->log_warn('register_cleanup() is a noop') }


# ------------------------------------------------------------------------
# CGI SUPPORT

sub send_cgi_header { shift->send_http_header }
sub allow_options { 0xFFFF; }


# ------------------------------------------------------------------------
# ERROR LOGGING

# Everything just goes to STDERR, but we try to make the messages look
# as Apache-ish as possible.

sub log_reason {
    shift;
    my($message, $file) = @_;
    _error_log('error', join ' ', 'access to', $file,
        'failed for you, reason:', $message);
}

sub log_error { shift; _error_log('error', shift) }
sub warn      { shift; _error_log('warn',  shift) }


# Some internal functions to generate the Apache-ish look.

sub _error_log {
    my($level, $message) = @_;
    print STDERR '[', _error_log_date(), '] [', $level, '] [client you] ',
        $message, "\n";
}

sub _error_log_date {
    my($sec, $min, $hour, $day, $mon, $year, $wday) = localtime(shift || time);
    sprintf '%-3s %-3s %02d %02d:%02d:%02d %04d',
        (qw(Sun Mon Tue Wed Thu Fri Sat))[$wday],
        (qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec))[$mon],
        $day, $hour, $min, $sec, $year + 1900;
}


# ------------------------------------------------------------------------
# UTILITY FUNCTIONS

use URI::Escape;

sub unescape_url {
    uri_escape(shift);
}

sub unescape_url_info {
    local $_ = uri_escape(shift);
    s/\+/ /gsm;
}


# ------------------------------------------------------------------------
# GLOBAL VARIABLES

$Apache::Server::Starting   = undef;
$Apache::Server::ReStarting = undef;

# Use those variables so Perl does not warn gratuitously
1 if $Apache::Server::Starting || $Apache::Server::ReStarting;


# ========================================================================
# Apache::Constants replacement

# perhaps this is more effort than needed since allow_options is
#   stubbed to always return 0xFFFF ?

package Apache::Constants;

sub OK { 0 };
sub DECLINED { -1 };
sub DONE { -2 };
sub NOT_FOUND { 404 };
sub FORBIDDEN { 403 };
sub AUTH_REQUIRED { 401 };
sub SERVER_ERROR { 500 };
sub DOCUMENT_FOLLOWS { 200 };
sub MOVED { 301 };
sub REDIRECT { 302 };
sub USE_LOCAL_COPY { 304 };
sub BAD_REQUEST { 400 };
sub BAD_GATEWAY { 502 };
sub RESPONSE_CODES { 55 };
sub NOT_IMPLEMENTED { 501 };
sub CONTINUE { -1 };
sub NOT_AUTHORITATIVE { -1 };
sub METHODS { 16 };
sub M_CONNECT { 4 };
sub M_DELETE { 3 };
sub M_GET { 0 };
sub M_INVALID { 15 };
sub M_OPTIONS { 5 };
sub M_POST { 2 };
sub M_PUT { 1 };
sub M_TRACE { 6 };
sub M_PATCH { 7 };
sub M_PROPFIND { 8 };
sub M_PROPPATCH { 9 };
sub M_MKCOL { 10 };
sub M_COPY { 11 };
sub M_MOVE { 12 };
sub M_LOCK { 13 };
sub M_UNLOCK { 14 };
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 };
sub SATISFY_ALL { 0 };
sub SATISFY_ANY { 1 };
sub SATISFY_NOSPEC { 2 };
sub REMOTE_HOST { 0 };
sub REMOTE_NAME { 1 };
sub REMOTE_NOLOOKUP { 2 };
sub REMOTE_DOUBLE_REV { 3 };
sub HTTP_OK { 200 };
sub HTTP_MOVED_TEMPORARILY { 302 };
sub HTTP_MOVED_PERMANENTLY { 301 };
sub HTTP_METHOD_NOT_ALLOWED { 405 };
sub HTTP_NOT_MODIFIED { 304 };
sub HTTP_UNAUTHORIZED { 401 };
sub HTTP_FORBIDDEN { 403 };
sub HTTP_NOT_FOUND { 404 };
sub HTTP_BAD_REQUEST { 400 };
sub HTTP_INTERNAL_SERVER_ERROR { 500 };
sub HTTP_NOT_ACCEPTABLE { 406 };
sub HTTP_NO_CONTENT { 204 };
sub HTTP_PRECONDITION_FAILED { 412 };
sub HTTP_SERVICE_UNAVAILABLE { 503 };
sub HTTP_VARIANT_ALSO_VARIES { 506 };
sub MODULE_MAGIC_NUMBER { 19990320 };
sub SERVER_VERSION { 'Apache/1.3.19 (Unix) mod_perl/1.25' };
sub SERVER_BUILT { 'Mar 28 2001 13:48:43' };
sub DECLINE_CMD { undef };
sub DIR_MAGIC_TYPE { 'httpd/unix-directory' };
sub OR_NONE { 0 };
sub OR_LIMIT { 1 };
sub OR_OPTIONS { 2 };
sub OR_FILEINFO { 4 };
sub OR_AUTHCFG { 8 };
sub OR_INDEXES { 16 };
sub OR_UNSET { 32 };
sub OR_ALL { 31 };
sub ACCESS_CONF { 64 };
sub RSRC_CONF { 128 };
sub RAW_ARGS { 0 };
sub TAKE1 { 1 };
sub TAKE2 { 2 };
sub TAKE12 { 7 };
sub TAKE3 { 8 };
sub TAKE23 { 9 };
sub TAKE123 { 10 };
sub ITERATE { 3 };
sub ITERATE2 { 4 };
sub FLAG { 5 };
sub NO_ARGS { 6 };

# ========================================================================
# Apache::Request replacement

package Apache::Request;

use Apache::Constants qw(:common);
use URI::Escape;

use vars qw(@ISA);
@ISA = qw(Apache);

sub new {
    my $class = shift;
    my $r = shift;
    $r->{_apr_param} = {} unless exists $r->{_apr_param};
    return bless $r, $class;
}

sub instance { &new }

sub parse    {  OK  }

sub param {
    my $self = shift;
    my $key = shift;
    my $value = shift;
    if($value) {
        $self->{_apr_param}->{$key} = $value;
    }
    if(not defined $key and not defined $value) {
        return keys %{$self->{_apr_param}};
    } elsif(exists $self->{_apr_param}->{$key}) {
        return uri_unescape($self->{_apr_param}->{$key});
    } else {
        return;
    }
}

# ========================================================================
# Apache::Cookie replacement

package Apache::Cookie;


# When we do a Apache::Cookie->fetch, really prompt the user for cookies
# in a similar style to CGI.pm (and the faked out Apache request object).
# These are stored in a package global (@_Apr_Cookies) which is returned
# at the end as a hash ref or an array.

use CGI::Cookie;
use URI::Escape;

use vars qw(@_Apr_Cookies);

sub fetch {
    my $self = shift;
    my @cookies;
    unless(@_Apr_Cookies) {
        if(-t STDIN && -t STDERR) {
            print STDERR "(offline cookies: enter name=value pairs on standard input)\n";
            while(<STDIN>) {
                chomp; s/^\s+//; s/\s+$//; s/^[\?&]+//;
                while($_ && s/^([^&]+)\&*//) {
                    my($name, $value) = split(/=/, $1, 2);
                    my $cookie = CGI::Cookie->new(
                        -name => $name,
                        -value => &uri_unescape($value),
                    );
                    push @_Apr_Cookies, $name => $cookie;
                }
            }
        }
    }
    return wantarray ? @_Apr_Cookies : { @_Apr_Cookies };
}


# When we create an Apache::Cookie, really create a CGI::Cookie instead
# (the interface is identical by design) and re-bless it into the
# Apache::Cookie class along with an Apache request object. The bake()
# method then does, more or less, the right thing.

sub new {
    my $class = shift;
    my $r = shift;
    my $cookie = CGI::Cookie->new(@_);
    bless [ $r, $cookie ], $class;
}

sub bake {
    my $self = shift;
    $self->[0]->header_out('Set-Cookie' => $self->[1]->as_string);
}


# ========================================================================
# Run a file, or STDIN

package main;
require 5.6.0;
use strict;
use warnings;
no warnings qw(redefine);

use vars qw($opt_c $opt_w $opt_p);
use Getopt::Std;

getopt('');
my $filename = (shift @ARGV || 'stdin');
$0 = $filename; # Fake out $0 for error reporting

my $code;

if ($filename =~ /\.tsp$/) {
    if ($opt_p || $opt_c || $opt_w) {
        # Prevent real modules from being loaded by setting
        # a fake "location" in %INC

        foreach( qw( Apache Apache/Request Apache/Cookie ) ) {
            $INC{$_} = $INC{join '.', $_, 'pm'} = 'eval';
        }

        # have to run this in an eval to get the %INC modifications
        #  to be respected by the 'use Tellme::Apache::TSP'
        eval <<'        EndEval';
            use Tellme::Apache::TSP;

            # parse the file
            my $tsp = new Tellme::Apache::TSP({});
            my $parsed = $tsp->_parse($filename) or
              die "Could not parse file: $filename\n";
            my $output = $tsp->_sub_wrap($parsed, 'TSP::CommandLine') or
              die "Could not sub_wrap file: $filename\n";

            if ($opt_p) {
                print $$output;
                $code = '';
            } else {
                $code = $$output;
            }
        EndEval

        die $@ if $@;
    } else {
        # Do some special stuff for Teaspoon files
        $code = <<'        EndCode';

        my $r = Apache->request;
        $r->filename($0);


        use Tellme::Apache::TSP;

        Tellme::Apache::TSP->handler($r);

        EndCode

    }
} elsif ($filename ne 'stdin') {
    # slurp code from a file

    local $/ = undef;
    open IN, "$filename" or
      die "could not open $filename\n";

    $code .= <IN>;

    close IN;
    $code = "sub run_perl_script {" . $code . "}\n\&run_perl_script;";
} else {
    # else slurp up the code to run
    local $/ = undef;
    $code = <>;

    $code = "sub run_stdin_script {" . $code . "}\n\&run_stdin_script;";
}

if($code) {
    if ($opt_c or $opt_w) {
        my $perlflags = '-';
        $perlflags .= 'c' if $opt_c;
        $perlflags .= 'w' if $opt_w;

        open PERL, "|/usr/local/bin/perl $perlflags" or
          die "Could not execute perl\n";

        print PERL $code;
        close PERL;
    } else {

        # Prevent real modules from being loaded by setting
        # a fake "location" in %INC

        foreach( qw( Apache Apache/Request Apache/Cookie ) ) {
            $INC{$_} = $INC{join '.', $_, 'pm'} = 'eval';
        }

        eval "$code";
        die $@ if $@;
    }
}

exit 0;


# ========================================================================
__END__