home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / FakeApache.pm < prev    next >
Encoding:
Text File  |  2003-12-12  |  11.2 KB  |  472 lines
  1. use strict;
  2.  
  3. # We need to define an Apache package or we might get strange errors
  4. # like "Can't locate package Apache for
  5. # @HTML::Mason::FakeApache::ISA".  We do the BEGIN/eval thing so that
  6. # the CPAN indexer doesn't pick it up, which would be ugly.
  7. BEGIN { eval "package Apache" }
  8.  
  9. package HTML::Mason::FakeApache;
  10. @HTML::Mason::FakeApache::ISA = qw(Apache);
  11. # Analogous to Apache request object $r (but not an actual Apache subclass)
  12. # In the future we'll probably want to switch this to Apache::Fake or similar
  13.  
  14. use HTML::Mason::MethodMaker(read_write => [qw(query)]);
  15.  
  16. sub new {
  17.     my $class = shift;
  18.     my %p = @_;
  19.     return bless {
  20.           query           => $p{cgi} || CGI->new,
  21.           headers_out     => HTML::Mason::FakeTable->new,
  22.           err_headers_out => HTML::Mason::FakeTable->new,
  23.           pnotes          => {},
  24.          }, $class;
  25. }
  26.  
  27. # CGI request are _always_ main, and there is never a previous or a next
  28. # internal request.
  29. sub main {}
  30. sub prev {}
  31. sub next {}
  32. sub is_main {1}
  33. sub is_initial_req {1}
  34.  
  35. # What to do with this?
  36. # sub allowed {}
  37.  
  38. sub method {
  39.     $_[0]->query->request_method;
  40. }
  41.  
  42. # There mut be a mapping for this.
  43. # sub method_number {}
  44.  
  45. # Can CGI.pm tell us this?
  46. # sub bytes_sent {0}
  47.  
  48. # The request line sent by the client." Poached from Apache::Emulator.
  49. sub the_request {
  50.     my $self = shift;
  51.     $self->{the_request} ||= join ' ', $self->method,
  52.       ( $self->{query}->query_string
  53.         ? $self->uri . '?' . $self->{query}->query_string
  54.         : $self->uri ),
  55.       $self->{query}->server_protocol;
  56. }
  57.  
  58. # Is CGI ever a proxy request?
  59. # sub proxy_req {}
  60.  
  61. sub header_only { $_[0]->method eq 'HEAD' }
  62.  
  63. sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' }
  64.  
  65. sub hostname { $_[0]->{query}->server_name }
  66.  
  67. # Fake it by just giving the current time.
  68. sub request_time { time }
  69.  
  70. sub uri {
  71.     my $self = shift;
  72.  
  73.     $self->{uri} ||= $self->{query}->script_name . $self->path_info || '';
  74. }
  75.  
  76. # Is this available in CGI?
  77. # sub filename {}
  78.  
  79. # "The $r->location method will return the path of the
  80. # <Location> section from which the current "Perl*Handler"
  81. # is being called." This is irrelevant, I think.
  82. # sub location {}
  83.  
  84. sub path_info { $_[0]->{query}->path_info }
  85.  
  86. sub args {
  87.     my $self = shift;
  88.     if (@_) {
  89.         # Assign args here.
  90.     }
  91.     return $self->{query}->Vars unless wantarray;
  92.     # Do more here to return key => arg values.
  93. }
  94.  
  95. sub headers_in {
  96.     my $self = shift;
  97.  
  98.     # Create the headers table if necessary. Decided how to build it based on
  99.     # information here:
  100.     # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1
  101.     #
  102.     # Try to get as much info as possible from CGI.pm, which has
  103.     # workarounds for things like the IIS PATH_INFO bug.
  104.     #
  105.     $self->{headers_in} ||= HTML::Mason::FakeTable->new
  106.       ( 'Authorization'       => $self->{query}->auth_type, # No credentials though.
  107.         'Content-Length'      => $ENV{CONTENT_LENGTH},
  108.         'Content-Type'        =>
  109.         ( $self->{query}->can('content_type') ?
  110.           $self->{query}->content_type :
  111.           $ENV{CONTENT_TYPE}
  112.         ),
  113.         # Convert HTTP environment variables back into their header names.
  114.         map {
  115.             my $k = ucfirst lc;
  116.             $k =~ s/_(.)/-\u$1/g;
  117.             ( $k => $self->{query}->http($_) )
  118.         } grep { s/^HTTP_// } keys %ENV
  119.       );
  120.  
  121.  
  122.     # Give 'em the hash list of the hash table.
  123.     return wantarray ? %{$self->{headers_in}} : $self->{headers_in};
  124. }
  125.  
  126. sub header_in {
  127.     my ($self, $header) = (shift, shift);
  128.     my $h = $self->headers_in;
  129.     return @_ ? $h->set($header, shift) : $h->get($header);
  130. }
  131.  
  132.  
  133. #           The $r->content method will return the entity body
  134. #           read from the client, but only if the request content
  135. #           type is "application/x-www-form-urlencoded".  When
  136. #           called in a scalar context, the entire string is
  137. #           returned.  When called in a list context, a list of
  138. #           parsed key => value pairs are returned.  *NOTE*: you
  139. #           can only ask for this once, as the entire body is read
  140. #           from the client.
  141. # Not sure what to do with this one.
  142. # sub content {}
  143.  
  144. # I think this may be irrelevant under CGI.
  145. # sub read {}
  146.  
  147. # Use LWP?
  148. sub get_remote_host {}
  149. sub get_remote_logname {}
  150.  
  151. sub http_header {
  152.     my $self = shift;
  153.     my $h = $self->headers_out;
  154.     my $e = $self->err_headers_out;
  155.     my $method = exists $h->{Location} || exists $e->{Location} ?
  156.       'redirect' : 'header';
  157.     return $self->query->$method(tied(%$h)->cgi_headers,
  158.                                  tied(%$e)->cgi_headers);
  159. }
  160.  
  161. sub send_http_header {
  162.     my $self = shift;
  163.  
  164.     print STDOUT $self->http_header;
  165.  
  166.     $self->{http_header_sent} = 1;
  167. }
  168.  
  169. sub http_header_sent { shift->{http_header_sent} }
  170.  
  171. # How do we know this under CGI?
  172. # sub get_basic_auth_pw {}
  173. # sub note_basic_auth_failure {}
  174.  
  175. # I think that this just has to be empty.
  176. sub handler {}
  177.  
  178. sub notes {
  179.     my ($self, $key) = (shift, shift);
  180.     $self->{notes} ||= HTML::Mason::FakeTable->new;
  181.     return wantarray ? %{$self->{notes}} : $self->{notes}
  182.       unless defined $key;
  183.     return $self->{notes}{$key} = "$_[0]" if @_;
  184.     return $self->{notes}{$key};
  185. }
  186.  
  187. sub pnotes {
  188.     my ($self, $key) = (shift, shift);
  189.     return wantarray ? %{$self->{pnotes}} : $self->{pnotes}
  190.       unless defined $key;
  191.     return $self->{pnotes}{$key} = $_[0] if @_;
  192.     return $self->{pnotes}{$key};
  193. }
  194.  
  195. sub subprocess_env {
  196.     my ($self, $key) = (shift, shift);
  197.     unless (defined $key) {
  198.         $self->{subprocess_env} = HTML::Mason::FakeTable->new(%ENV);
  199.         return wantarray ? %{$self->{subprocess_env}} :
  200.           $self->{subprocess_env};
  201.  
  202.     }
  203.     $self->{subprocess_env} ||= HTML::Mason::FakeTable->new(%ENV);
  204.     return $self->{subprocess_env}{$key} = "$_[0]" if @_;
  205.     return $self->{subprocess_env}{$key};
  206. }
  207.  
  208. sub content_type {
  209.     shift->header_out('Content-Type', @_);
  210. }
  211.  
  212. sub content_encoding {
  213.     shift->header_out('Content-Encoding', @_);
  214. }
  215.  
  216. sub content_languages {
  217.     my ($self, $langs) = @_;
  218.     return unless $langs;
  219.     my $h = shift->headers_out;
  220.     for my $l (@$langs) {
  221.         $h->add('Content-Language', $l);
  222.     }
  223. }
  224.  
  225. sub status {
  226.     shift->header_out('Status', @_);
  227. }
  228.  
  229. sub status_line {
  230.     # What to do here? Should it be managed differently than status?
  231.     my $self = shift;
  232.     if (@_) {
  233.         my $status = shift =~ /^(\d+)/;
  234.         return $self->header_out('Status', $status);
  235.     }
  236.     return $self->header_out('Status');
  237. }
  238.  
  239. sub headers_out {
  240.     my $self = shift;
  241.     return wantarray ? %{$self->{headers_out}} : $self->{headers_out};
  242. }
  243.  
  244. sub header_out {
  245.     my ($self, $header) = (shift, shift);
  246.     my $h = $self->headers_out;
  247.     return @_ ? $h->set($header, shift) : $h->get($header);
  248. }
  249.  
  250. sub err_headers_out {
  251.     my $self = shift;
  252.     return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out};
  253. }
  254.  
  255. sub err_header_out {
  256.     my ($self, $err_header) = (shift, shift);
  257.     my $h = $self->err_headers_out;
  258.     return @_ ? $h->set($err_header, shift) : $h->get($err_header);
  259. }
  260.  
  261. sub no_cache {
  262.     my $self = shift;
  263.     $self->header_out(Pragma => 'no-cache');
  264.     $self->header_out('Cache-Control' => 'no-cache');
  265. }
  266.  
  267. sub print {
  268.     print @_;
  269. }
  270.  
  271. sub send_fd {
  272.     my ($self, $fd) = @_;
  273.     local $_;
  274.  
  275.     print STDOUT while defined ($_ = <$fd>);
  276. }
  277.  
  278. # Should this perhaps throw an exception?
  279. # sub internal_redirect {}
  280. # sub internal_redirect_handler {}
  281.  
  282. # Do something with ErrorDocument?
  283. # sub custom_response {}
  284.  
  285. # I think we'ev made this essentially the same thing.
  286. BEGIN {
  287.     local $^W;
  288.     *send_cgi_header = \&send_http_header;
  289. }
  290.  
  291. # Does CGI support logging?
  292. # sub log_reason {}
  293. # sub log_error {}
  294. sub warn {
  295.     shift;
  296.     print STDERR @_, "\n";
  297. }
  298.  
  299. sub params {
  300.     my $self = shift;
  301.     return HTML::Mason::Utils::cgi_request_args($self->query,
  302.                                                 $self->query->request_method);
  303. }
  304.  
  305. 1;
  306.  
  307. ###########################################################
  308. package HTML::Mason::FakeTable;
  309. # Analogous to Apache::Table.
  310. use strict;
  311.  
  312. sub new {
  313.     my $class = shift;
  314.     my $self = {};
  315.     tie %{$self}, 'HTML::Mason::FakeTableHash';
  316.     %$self = @_ if @_;
  317.     return bless $self, ref $class || $class;
  318. }
  319.  
  320. sub set {
  321.     my ($self, $header, $value) = @_;
  322.     defined $value ? $self->{$header} = $value : delete $self->{$header};
  323. }
  324.  
  325. sub unset {
  326.     my $self = shift;
  327.     delete $self->{shift()};
  328. }
  329.  
  330. sub add {
  331.     tied(%{shift()})->add(@_);
  332. }
  333.  
  334. sub clear {
  335.     %{shift()} = ();
  336. }
  337.  
  338. sub get {
  339.     tied(%{shift()})->get(@_);
  340. }
  341.  
  342. sub merge {
  343.     my ($self, $key, $value) = @_;
  344.     if (defined $self->{$key}) {
  345.         $self->{$key} .= ',' . $value;
  346.     } else {
  347.         $self->{$key} = "$value";
  348.     }
  349. }
  350.  
  351. sub do {
  352.     my ($self, $code) = @_;
  353.     while (my ($k, $val) = each %$self) {
  354.         for my $v (ref $val ? @$val : $val) {
  355.             return unless $code->($k => $v);
  356.         }
  357.     }
  358. }
  359.  
  360. ###########################################################
  361. package HTML::Mason::FakeTableHash;
  362. # Used by HTML::Mason::FakeTable.
  363. use strict;
  364.  
  365. sub TIEHASH {
  366.     my $class = shift;
  367.     return bless {}, ref $class || $class;
  368. }
  369.  
  370. sub _canonical_key {
  371.     my $key = lc shift;
  372.     # CGI really wants a - before each header
  373.     return substr( $key, 0, 1 ) eq '-' ? $key : "-$key";
  374. }
  375.  
  376. sub STORE {
  377.     my ($self, $key, $value) = @_;
  378.     $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ];
  379. }
  380.  
  381. sub add {
  382.     my ($self, $key) = (shift, shift);
  383.     return unless defined $_[0];
  384.     my $value = ref $_[0] ? "$_[0]" : $_[0];
  385.     my $ckey = _canonical_key $key;
  386.     if (exists $self->{$ckey}) {
  387.         if (ref $self->{$ckey}[1]) {
  388.             push @{$self->{$ckey}[1]}, $value;
  389.         } else {
  390.             $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ];
  391.         }
  392.     } else {
  393.         $self->{$ckey} = [ $key => $value ];
  394.     }
  395. }
  396.  
  397. sub DELETE {
  398.     my ($self, $key) = @_;
  399.     my $ret = delete $self->{_canonical_key $key};
  400.     return $ret->[1];
  401. }
  402.  
  403. sub FETCH {
  404.     my ($self, $key) = @_;
  405.     # Grab the values first so that we don't autovivicate the key.
  406.     my $val = $self->{_canonical_key $key} or return;
  407.     if (my $ref = ref $val->[1]) {
  408.         return unless $val->[1][0];
  409.         # Return the first value only.
  410.         return $val->[1][0];
  411.     }
  412.     return $val->[1];
  413. }
  414.  
  415. sub get {
  416.     my ($self, $key) = @_;
  417.     my $ckey = _canonical_key $key;
  418.     return unless exists $self->{$ckey};
  419.     return $self->{$ckey}[1] unless ref $self->{$ckey}[1];
  420.     return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0];
  421. }
  422.  
  423. sub CLEAR {
  424.     %{shift()} = ();
  425. }
  426.  
  427. sub EXISTS {
  428.     my ($self, $key)= @_;
  429.     return exists $self->{_canonical_key $key};
  430. }
  431.  
  432. sub FIRSTKEY {
  433.     my $self = shift;
  434.     # Reset perl's iterator.
  435.     keys %$self;
  436.     # Get the first key via perl's iterator.
  437.     my $first_key = each %$self;
  438.     return undef unless defined $first_key;
  439.     return $self->{$first_key}[0];
  440. }
  441.  
  442. sub NEXTKEY {
  443.     my ($self, $nextkey) = @_;
  444.     # Get the next key via perl's iterator.
  445.     my $next_key = each %$self;
  446.     return undef unless defined $next_key;
  447.     return $self->{$next_key}[0];
  448. }
  449.  
  450. sub cgi_headers {
  451.     my $self = shift;
  452.     map { $_ => $self->{$_}[1] } keys %$self;
  453. }
  454.  
  455. 1;
  456.  
  457. __END__
  458.  
  459. =head1 NAME
  460.  
  461. HTML::Mason::FakeApache - An Apache object emulator for use with Mason
  462.  
  463. =head1 SYNOPSIS
  464.  
  465. See L<HTML::Mason::CGIHandler|HTML::Mason::CGIHandler>.
  466.  
  467. =head1 DESCRIPTION
  468.  
  469. This class's API is documented in L<HTML::Mason::CGIHandler|HTML::Mason::CGIHandler>.
  470.  
  471. =cut
  472.