home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / compat.pm < prev    next >
Encoding:
Perl POD Document  |  2004-09-17  |  23.5 KB  |  982 lines
  1. # Copyright 2001-2004 The Apache Software Foundation
  2. #
  3. # Licensed under the Apache License, Version 2.0 (the "License");
  4. # you may not use this file except in compliance with the License.
  5. # You may obtain a copy of the License at
  6. #
  7. #     http://www.apache.org/licenses/LICENSE-2.0
  8. #
  9. # Unless required by applicable law or agreed to in writing, software
  10. # distributed under the License is distributed on an "AS IS" BASIS,
  11. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  12. # See the License for the specific language governing permissions and
  13. # limitations under the License.
  14. #
  15. package Apache::compat;
  16.  
  17. use strict;
  18. use warnings FATAL => 'all';
  19. no warnings 'redefine';
  20.  
  21. #1.xx compat layer
  22. #some of this will stay as-is
  23. #some will be implemented proper later on
  24.  
  25. #there's enough here to get simple registry scripts working
  26. #add to startup.pl:
  27. #use Apache::compat ();
  28. #use lib ...; #or something to find 1.xx Apache::Registry
  29.  
  30. #Alias /perl /path/to/perl/scripts
  31. #<Location /perl>
  32. #   Options +ExecCGI
  33. #   SetHandler modperl
  34. #   PerlResponseHandler Apache::Registry
  35. #</Location>
  36.  
  37. use Apache::Connection ();
  38. use Apache::ServerRec ();
  39. use Apache::ServerUtil ();
  40. use Apache::Access ();
  41. use Apache::RequestRec ();
  42. use Apache::RequestIO ();
  43. use Apache::RequestUtil ();
  44. use Apache::Response ();
  45. use Apache::SubRequest ();
  46. use Apache::Filter ();
  47. use Apache::Util ();
  48. use Apache::Log ();
  49. use Apache::URI ();
  50. use APR::Date ();
  51. use APR::Table ();
  52. use APR::Pool ();
  53. use APR::URI ();
  54. use APR::Util ();
  55. use APR::Brigade ();
  56. use APR::Bucket ();
  57. use mod_perl ();
  58.  
  59. use Symbol ();
  60. use File::Spec ();
  61.  
  62. BEGIN {
  63.     $INC{'Apache.pm'} = __FILE__;
  64.  
  65.     $INC{'Apache/Constants.pm'} = __FILE__;
  66.  
  67.     $INC{'Apache/File.pm'} = __FILE__;
  68.  
  69.     $INC{'Apache/Table.pm'} = __FILE__;
  70. }
  71.  
  72. # api => "overriding code"
  73. # the overriding code, needs to "return" the original CODE reference
  74. # when eval'ed , so that it can be restored later
  75. my %overridable_mp2_api = (
  76.     'Apache::RequestRec::notes' => <<'EOI',
  77. {
  78.     require Apache::RequestRec;
  79.     my $orig_sub = *Apache::RequestRec::notes{CODE};
  80.     *Apache::RequestRec::notes = sub {
  81.         my $r = shift;
  82.         return wantarray()
  83.             ?       ($r->table_get_set(scalar($r->$orig_sub), @_))
  84.             : scalar($r->table_get_set(scalar($r->$orig_sub), @_));
  85.     };
  86.     $orig_sub;
  87. }
  88. EOI
  89.  
  90.     'Apache::RequestRec::finfo' => <<'EOI',
  91. {
  92.     require APR::Finfo;
  93.     my $orig_sub = *APR::Finfo::finfo{CODE};
  94.     sub Apache::RequestRec::finfo {
  95.         my $r = shift;
  96.         stat $r->filename;
  97.         \*_;
  98.     }
  99.     $orig_sub;
  100. }
  101. EOI
  102.  
  103.     'Apache::Connection::local_addr' => <<'EOI',
  104. {
  105.     require Apache::Connection;
  106.     require Socket;
  107.     require APR::SockAddr;
  108.     my $orig_sub = *Apache::Connection::local_addr{CODE};
  109.     *Apache::Connection::local_addr = sub {
  110.         my $c = shift;
  111.         Socket::pack_sockaddr_in($c->$orig_sub->port,
  112.                                  Socket::inet_aton($c->$orig_sub->ip_get));
  113.     };
  114.     $orig_sub;
  115. }
  116. EOI
  117.  
  118.     'Apache::Connection::remote_addr' => <<'EOI',
  119. {
  120.     require Apache::Connection;
  121.     require APR::SockAddr;
  122.     require Socket;
  123.     my $orig_sub = *Apache::Connection::remote_addr{CODE};
  124.     *Apache::Connection::remote_addr = sub {
  125.         my $c = shift;
  126.         if (@_) {
  127.             my $addr_in = shift;
  128.             my($port, $addr) = Socket::unpack_sockaddr_in($addr_in);
  129.             $c->$orig_sub->ip_set($addr);
  130.             $c->$orig_sub->port_set($port);
  131.         }
  132.         else {
  133.             Socket::pack_sockaddr_in($c->$orig_sub->port,
  134.                                      Socket::inet_aton($c->$orig_sub->ip_get));
  135.         }
  136.     };
  137.     $orig_sub;
  138. }
  139. EOI
  140.  
  141.     'APR::URI::unparse' => <<'EOI',
  142. {
  143.     require APR::URI;
  144.     my $orig_sub = *APR::URI::unparse{CODE};
  145.     *APR::URI::unparse = sub {
  146.         my($uri, $flags) = @_;
  147.  
  148.         if (defined $uri->hostname && !defined $uri->scheme) {
  149.             # we do this only for back compat, the new APR::URI is
  150.             # protocol-agnostic and doesn't fallback to 'http' when the
  151.             # scheme is not provided
  152.             $uri->scheme('http');
  153.         }
  154.  
  155.         $orig_sub->(@_);
  156.     };
  157.     $orig_sub;
  158. }
  159. EOI
  160.  
  161.     'Apache::Util::ht_time' => <<'EOI',
  162. {
  163.     require Apache::Util;
  164.     my $orig_sub = *Apache::Util::ht_time{CODE};
  165.     *Apache::Util::ht_time = sub {
  166.         my $r = Apache::compat::request('Apache::Util::ht_time');
  167.         return $orig_sub->($r->pool, @_);
  168.     };
  169.     $orig_sub;
  170. }
  171.  
  172. EOI
  173.  
  174. );
  175.  
  176. my %overridden_mp2_api = ();
  177.  
  178. # this function enables back-compatible APIs which can't coexist with
  179. # mod_perl 2.0 APIs with the same name and therefore it should be
  180. # avoided if possible.
  181. #
  182. # it expects a list of fully qualified functions, like
  183. # "Apache::RequestRec::finfo"
  184. sub override_mp2_api {
  185.     my (@subs) = @_;
  186.  
  187.     for my $sub (@subs) {
  188.         unless (exists $overridable_mp2_api{$sub}) {
  189.             die __PACKAGE__ . ": $sub is not overridable";
  190.         }
  191.         if (exists $overridden_mp2_api{$sub}) {
  192.             warn __PACKAGE__ . ": $sub has been already overridden";
  193.             next;
  194.         }
  195.         $overridden_mp2_api{$sub} = eval $overridable_mp2_api{$sub};
  196.         unless (exists $overridden_mp2_api{$sub} &&
  197.                 ref($overridden_mp2_api{$sub}) eq 'CODE') {
  198.             die "overriding $sub didn't return a CODE ref";
  199.         }
  200.     }
  201. }
  202.  
  203. # restore_mp2_api does the opposite of override_mp2_api(), it removes
  204. # the overriden API and restores the original mod_perl 2.0 API
  205. sub restore_mp2_api {
  206.     my (@subs) = @_;
  207.  
  208.     for my $sub (@subs) {
  209.         unless (exists $overridable_mp2_api{$sub}) {
  210.             die __PACKAGE__ . ": $sub is not overridable";
  211.         }
  212.         unless (exists $overridden_mp2_api{$sub}) {
  213.             warn __PACKAGE__ . ": can't restore $sub, " .
  214.                 "as it has not been overridden";
  215.             next;
  216.         }
  217.         # XXX: 5.8.2+ can't delete and assign at once - gives:
  218.         #    Attempt to free unreferenced scalar
  219.         # after perl_clone. the 2 step works ok. to reproduce:
  220.         # t/TEST -maxclients 1 perl/ithreads2.t compat/request.t
  221.         my $original_sub = $overridden_mp2_api{$sub};
  222.         delete $overridden_mp2_api{$sub};
  223.         no warnings 'redefine';
  224.         no strict 'refs';
  225.         *$sub = $original_sub;
  226.     }
  227. }
  228.  
  229. sub request {
  230.     my $what = shift;
  231.  
  232.     my $r = Apache->request;
  233.  
  234.     unless ($r) {
  235.         die "cannot use $what ",
  236.             "without 'SetHandler perl-script' ",
  237.             "or 'PerlOptions +GlobalRequest'";
  238.     }
  239.  
  240.     $r;
  241. }
  242.  
  243. package Apache::Server;
  244. # XXX: is that good enough? see modperl/src/modules/perl/mod_perl.c:367
  245. our $CWD = Apache::ServerUtil::server_root;
  246.  
  247. our $AddPerlVersion = 1;
  248.  
  249. package Apache;
  250.  
  251. sub server_root_relative {
  252.     my $class = shift;
  253.     if (@_ && defined($_[0]) && File::Spec->file_name_is_absolute($_[0])) {
  254.          return File::Spec->catfile(@_);
  255.     }
  256.     else {
  257.         File::Spec->catfile(Apache::ServerUtil::server_root, @_);
  258.     }
  259. }
  260.  
  261. sub exit {
  262.     require ModPerl::Util;
  263.  
  264.     my $status = 0;
  265.     my $nargs = @_;
  266.  
  267.     if ($nargs == 2) {
  268.         $status = $_[1];
  269.     }
  270.     elsif ($nargs == 1 and $_[0] =~ /^\d+$/) {
  271.         $status = $_[0];
  272.     }
  273.  
  274.     ModPerl::Util::exit($status);
  275. }
  276.  
  277. #XXX: warn
  278. sub import {
  279. }
  280.  
  281. sub untaint {
  282.     shift;
  283.     require ModPerl::Util;
  284.     ModPerl::Util::untaint(@_);
  285. }
  286.  
  287. sub module {
  288.     require Apache::Module;
  289.     die 'Usage: Apache->module($name)' if @_ != 2;
  290.     return Apache::Module::loaded($_[1]);
  291. }
  292.  
  293. sub gensym {
  294.     return Symbol::gensym();
  295. }
  296.  
  297. sub define {
  298.     shift if @_ == 2;
  299.     Apache::ServerUtil::exists_config_define(@_);
  300. }
  301.  
  302. sub log_error {
  303.     Apache->server->log_error(@_);
  304. }
  305.  
  306. sub httpd_conf {
  307.     shift;
  308.     my $obj;
  309.     eval { $obj = Apache->request };
  310.     $obj = Apache->server if $@;
  311.     my $err = $obj->add_config([split /\n/, join '', @_]);
  312.     die $err if $err;
  313. }
  314.  
  315. # mp2 always can stack handlers
  316. sub can_stack_handlers { 1; }
  317.  
  318. sub push_handlers {
  319.     shift;
  320.     Apache->server->push_handlers(@_);
  321. }
  322.  
  323. sub set_handlers {
  324.     shift;
  325.     Apache->server->set_handlers(@_);
  326. }
  327.  
  328. sub get_handlers {
  329.     shift;
  330.     Apache->server->get_handlers(@_);
  331. }
  332.  
  333. package Apache::Constants;
  334.  
  335. use Apache::Const ();
  336.  
  337. sub import {
  338.     my $class = shift;
  339.     my $package = scalar caller;
  340.  
  341.     my @args = @_;
  342.  
  343.     # treat :response as :common - it's not perfect
  344.     # but simple and close enough for the majority
  345.     my %args = map { s/^:response$/:common/; $_ => 1 } @args;
  346.  
  347.     Apache::Const->compile($package => keys %args);
  348. }
  349.  
  350. #no need to support in 2.0
  351. sub export {}
  352.  
  353. sub SERVER_VERSION { Apache::ServerUtil::get_server_version() }
  354.  
  355. package Apache::RequestRec;
  356.  
  357. use Apache::Const -compile => qw(REMOTE_NAME);
  358.  
  359. #no longer exist in 2.0
  360. sub soft_timeout {}
  361. sub hard_timeout {}
  362. sub kill_timeout {}
  363. sub reset_timeout {}
  364.  
  365. # this function is from mp1's Apache::SubProcess 3rd party module
  366. # which is now a part of mp2 API. this function doesn't exist in 2.0.
  367. sub cleanup_for_exec {}
  368.  
  369. sub current_callback {
  370.     return Apache::current_callback();
  371. }
  372.  
  373. sub send_http_header {
  374.     my ($r, $type) = @_;
  375.  
  376.     # since send_http_header() in mp1 was telling mod_perl not to
  377.     # parse headers and in mp2 one must call $r->content_type($type) to
  378.     # perform the same, we make sure that this happens
  379.     $type = $r->content_type || 'text/html' unless defined $type;
  380.  
  381.     $r->content_type($type);
  382. }
  383.  
  384. #we support Apache->request; this is needed to support $r->request
  385. #XXX: seems sorta backwards
  386. *request = \&Apache::request;
  387.  
  388. sub table_get_set {
  389.     my($r, $table) = (shift, shift);
  390.     my($key, $value) = @_;
  391.  
  392.     if (1 == @_) {
  393.         return wantarray() 
  394.             ?       ($table->get($key))
  395.             : scalar($table->get($key));
  396.     }
  397.     elsif (2 == @_) {
  398.         if (defined $value) {
  399.             return wantarray() 
  400.                 ?        ($table->set($key, $value))
  401.                 :  scalar($table->set($key, $value));
  402.         }
  403.         else {
  404.             return wantarray() 
  405.                 ?       ($table->unset($key))
  406.                 : scalar($table->unset($key));
  407.         }
  408.     }
  409.     elsif (0 == @_) {
  410.         return $table;
  411.     }
  412.     else {
  413.         my $name = (caller(1))[3];
  414.         warn "Usage: \$r->$name([key [,val]])";
  415.     }
  416. }
  417.  
  418. sub header_out {
  419.     my $r = shift;
  420.     return wantarray() 
  421.         ?       ($r->table_get_set(scalar($r->headers_out), @_))
  422.         : scalar($r->table_get_set(scalar($r->headers_out), @_));
  423. }
  424.  
  425. sub header_in {
  426.     my $r = shift;
  427.     return wantarray() 
  428.         ?       ($r->table_get_set(scalar($r->headers_in), @_))
  429.         : scalar($r->table_get_set(scalar($r->headers_in), @_));
  430. }
  431.  
  432. sub err_header_out {
  433.     my $r = shift;
  434.     return wantarray() 
  435.         ?       ($r->table_get_set(scalar($r->err_headers_out), @_))
  436.         : scalar($r->table_get_set(scalar($r->err_headers_out), @_));
  437. }
  438.  
  439.  
  440. sub register_cleanup {
  441.     shift->pool->cleanup_register(@_);
  442. }
  443.  
  444. *post_connection = \®ister_cleanup;
  445.  
  446. sub get_remote_host {
  447.     my($r, $type) = @_;
  448.     $type = Apache::REMOTE_NAME unless defined $type;
  449.     $r->connection->get_remote_host($type, $r->per_dir_config);
  450. }
  451.  
  452. #XXX: should port 1.x's Apache::URI::unescape_url_info
  453. sub parse_args {
  454.     my($r, $string) = @_;
  455.     return () unless defined $string and $string;
  456.  
  457.     return map {
  458.         tr/+/ /;
  459.         s/%([0-9a-fA-F]{2})/pack("C",hex($1))/ge;
  460.         $_;
  461.     } split /[=&;]/, $string, -1;
  462. }
  463.  
  464. #sorry, have to use $r->Apache::args at the moment
  465. #for list context splitting
  466.  
  467. sub Apache::args {
  468.     my $r = shift;
  469.     my $args = $r->args;
  470.     return $args unless wantarray;
  471.     return $r->parse_args($args);
  472. }
  473.  
  474. use Apache::Const -compile => qw(MODE_READBYTES);
  475. use APR::Const    -compile => qw(SUCCESS BLOCK_READ);
  476.  
  477. use constant IOBUFSIZE => 8192;
  478.  
  479. sub content {
  480.     my $r = shift;
  481.  
  482.     my $bb = APR::Brigade->new($r->pool,
  483.                                $r->connection->bucket_alloc);
  484.  
  485.     my $data = '';
  486.     my $seen_eos = 0;
  487.     do {
  488.         $r->input_filters->get_brigade($bb, Apache::MODE_READBYTES,
  489.                                        APR::BLOCK_READ, IOBUFSIZE);
  490.         while (!$bb->is_empty) {
  491.             my $b = $bb->first;
  492.  
  493.             if ($b->is_eos) {
  494.                 $seen_eos++;
  495.                 last;
  496.             }
  497.  
  498.             if ($b->read(my $buf)) {
  499.                 $data .= $buf;
  500.             }
  501.  
  502.             $b->delete;
  503.         }
  504.     } while (!$seen_eos);
  505.  
  506.     $bb->destroy;
  507.  
  508.     return $data unless wantarray;
  509.     return $r->parse_args($data);
  510. }
  511.  
  512. sub server_root_relative {
  513.     my $r = shift;
  514.     File::Spec->catfile(Apache::ServerUtil::server_root, @_);
  515. }
  516.  
  517. sub clear_rgy_endav {
  518.     my($r, $script_name) = @_;
  519.     require ModPerl::Global;
  520.     my $package = 'Apache::ROOT' . $script_name;
  521.     ModPerl::Global::special_list_clear(END => $package);
  522. }
  523.  
  524. sub stash_rgy_endav {
  525.     #see run_rgy_endav
  526. }
  527.  
  528. #if somebody really wants to have END subroutine support
  529. #with the 1.x Apache::Registry they will need to configure:
  530. # PerlHandler Apache::Registry Apache::compat::run_rgy_endav
  531. sub Apache::compat::run_rgy_endav {
  532.     my $r = shift;
  533.  
  534.     require ModPerl::Global;
  535.     require Apache::PerlRun; #1.x's
  536.     my $package = Apache::PerlRun->new($r)->namespace;
  537.  
  538.     ModPerl::Global::special_list_call(END => $package);
  539. }
  540.  
  541. sub seqno {
  542.     1;
  543. }
  544.  
  545. sub chdir_file {
  546.     #XXX resolve '.' in @INC to basename $r->filename
  547. }
  548.  
  549. *log_reason = \&log_error;
  550.  
  551. #XXX: would like to have a proper implementation
  552. #that reads line-by-line as defined by $/
  553. #the best way will probably be to use perlio in 5.8.0
  554. #anything else would be more effort than it is worth
  555. sub READLINE {
  556.     my $r = shift;
  557.     my $line;
  558.     $r->read($line, $r->headers_in->get('Content-length'));
  559.     $line ? $line : undef;
  560. }
  561.  
  562. #XXX: howto convert PerlIO to apr_file_t
  563. #so we can use the real ap_send_fd function
  564. #2.0 ap_send_fd() also has an additional offset parameter
  565.  
  566. sub send_fd_length {
  567.     my($r, $fh, $length) = @_;
  568.  
  569.     my $buff;
  570.     my $total_bytes_sent = 0;
  571.     my $len;
  572.  
  573.     return 0 if $length == 0;
  574.  
  575.     if (($length > 0) && ($total_bytes_sent + IOBUFSIZE) > $length) {
  576.         $len = $length - $total_bytes_sent;
  577.     }
  578.     else {
  579.         $len = IOBUFSIZE;
  580.     }
  581.  
  582.     binmode $fh;
  583.  
  584.     while (CORE::read($fh, $buff, $len)) {
  585.         $total_bytes_sent += $r->puts($buff);
  586.     }
  587.  
  588.     $total_bytes_sent;
  589. }
  590.  
  591. sub send_fd {
  592.     my($r, $fh) = @_;
  593.     $r->send_fd_length($fh, -1);
  594. }
  595.  
  596. sub is_main { !shift->main }
  597.  
  598. # really old back-compat methods, they shouldn't be used in mp1
  599. *cgi_var = *cgi_env = \&Apache::RequestRec::subprocess_env;
  600.  
  601. package Apache::File;
  602.  
  603. use Fcntl ();
  604. use Symbol ();
  605. use Carp ();
  606.  
  607. sub new {
  608.     my($class) = shift;
  609.     my $fh = Symbol::gensym;
  610.     my $self = bless $fh, ref($class)||$class;
  611.     if (@_) {
  612.         return $self->open(@_) ? $self : undef;
  613.     }
  614.     else {
  615.         return $self;
  616.     }
  617. }
  618.  
  619. sub open {
  620.     my($self) = shift;
  621.  
  622.     Carp::croak("no Apache::File object passed")
  623.           unless $self && ref($self);
  624.  
  625.     # cannot forward @_ to open() because of its prototype
  626.     if (@_ > 1) {
  627.         my ($mode, $file) = @_;
  628.         CORE::open $self, $mode, $file;
  629.     }
  630.     else {
  631.         my $file = shift;
  632.         CORE::open $self, $file;
  633.     }
  634. }
  635.  
  636. sub close {
  637.     my($self) = shift;
  638.     CORE::close $self;
  639. }
  640.  
  641. my $TMPNAM = 'aaaaaa';
  642. my $TMPDIR = $ENV{'TMPDIR'} || $ENV{'TEMP'} || '/tmp';
  643. ($TMPDIR) = $TMPDIR =~ /^([^<>|;*]+)$/; #untaint
  644. my $Mode = Fcntl::O_RDWR()|Fcntl::O_EXCL()|Fcntl::O_CREAT();
  645. my $Perms = 0600;
  646.  
  647. sub tmpfile {
  648.     my $class = shift;
  649.     my $limit = 100;
  650.     my $r = Apache::compat::request('Apache::File->tmpfile');
  651.  
  652.     while ($limit--) {
  653.         my $tmpfile = "$TMPDIR/${$}" . $TMPNAM++;
  654.         my $fh = $class->new;
  655.  
  656.         sysopen $fh, $tmpfile, $Mode, $Perms
  657.             or die "failed to open $tmpfile: $!";
  658.         $r->pool->cleanup_register(sub { unlink $tmpfile });
  659.  
  660.         if ($fh) {
  661.             return wantarray ? ($tmpfile, $fh) : $fh;
  662.         }
  663.     }
  664. }
  665.  
  666. # the following functions now live in Apache::RequestIO
  667. # * discard_request_body
  668.  
  669. # the following functions now live in Apache::Response
  670. # * meets_conditions
  671. # * set_content_length
  672. # * set_etag
  673. # * set_last_modified
  674. # * update_mtime
  675.  
  676. # the following functions now live in Apache::RequestRec
  677. # * mtime
  678.  
  679. package Apache::Util;
  680.  
  681. sub size_string {
  682.     my($size) = @_;
  683.  
  684.     if (!$size) {
  685.         $size = "   0k";
  686.     }
  687.     elsif ($size == -1) {
  688.         $size = "    -";
  689.     }
  690.     elsif ($size < 1024) {
  691.         $size = "   1k";
  692.     }
  693.     elsif ($size < 1048576) {
  694.         $size = sprintf "%4dk", ($size + 512) / 1024;
  695.     }
  696.     elsif ($size < 103809024) {
  697.         $size = sprintf "%4.1fM", $size / 1048576.0;
  698.     }
  699.     else {
  700.         $size = sprintf "%4dM", ($size + 524288) / 1048576;
  701.     }
  702.  
  703.     return $size;
  704. }
  705.  
  706. *unescape_uri = \&Apache::URI::unescape_url;
  707.  
  708. sub escape_uri {
  709.     my $path = shift;
  710.     my $r = Apache::compat::request('Apache::Util::escape_uri');
  711.     Apache::Util::escape_path($path, $r->pool);
  712. }
  713.  
  714. #tmp compat until ap_escape_html is reworked to not require a pool
  715. my %html_escapes = (
  716.     '<' => 'lt',
  717.     '>' => 'gt',
  718.     '&' => 'amp',
  719.     '"' => 'quot',
  720. );
  721.  
  722. %html_escapes = map { $_, "&$html_escapes{$_};" } keys %html_escapes;
  723.  
  724. my $html_escape = join '|', keys %html_escapes;
  725.  
  726. sub escape_html {
  727.     my $html = shift;
  728.     $html =~ s/($html_escape)/$html_escapes{$1}/go;
  729.     $html;
  730. }
  731.  
  732. *parsedate = \&APR::Date::parse_http;
  733.  
  734. *validate_password = \&APR::Util::password_validate;
  735.  
  736. sub Apache::URI::parse {
  737.     my($class, $r, $uri) = @_;
  738.  
  739.     $uri ||= $r->construct_url;
  740.  
  741.     APR::URI->parse($r->pool, $uri);
  742. }
  743.  
  744. package Apache::Table;
  745.  
  746. sub new {
  747.     my($class, $r, $nelts) = @_;
  748.     $nelts ||= 10;
  749.     APR::Table::make($r->pool, $nelts);
  750. }
  751.  
  752. package Apache::SIG;
  753.  
  754. use Apache::Const -compile => 'DECLINED';
  755.  
  756. sub handler {
  757.     # don't set the SIGPIPE
  758.     return Apache::DECLINED;
  759. }
  760.  
  761. package Apache::Connection;
  762.  
  763. # auth_type and user records don't exist in 2.0 conn_rec struct
  764. # 'PerlOptions +GlobalRequest' is required
  765. sub auth_type { shift; Apache->request->ap_auth_type(@_) }
  766. sub user      { shift; Apache->request->user(@_)      }
  767.  
  768. 1;
  769. __END__
  770.  
  771. =head1 NAME
  772.  
  773. Apache::compat -- 1.0 backward compatibility functions deprecated in 2.0
  774.  
  775.  
  776.  
  777.  
  778.  
  779. =head1 Synopsis
  780.  
  781.   # either add at the very beginning of startup.pl
  782.   use Apache2
  783.   use Apache::compat;
  784.   # or httpd.conf
  785.   PerlModule Apache2
  786.   PerlModule Apache::compat
  787.  
  788.   # override and restore compat functions colliding with mp2 API
  789.   Apache::compat::override_mp2_api('Apache::Connection::local_addr');
  790.   my ($local_port, $local_addr) = sockaddr_in($c->local_addr);
  791.   Apache::compat::restore_mp2_api('Apache::Connection::local_addr');
  792.  
  793.  
  794.  
  795.  
  796.  
  797.  
  798. =head1 Description
  799.  
  800. C<Apache::compat> provides mod_perl 1.0 compatibility layer and can be
  801. used to smooth the transition process to mod_perl 2.0.
  802.  
  803. It includes functions that have changed their API or were removed in
  804. mod_perl 2.0. If your code uses any of those functions, you should
  805. load this module at the server startup, and everything should work as
  806. it did in 1.0. If it doesn't please L<report the
  807. bug|docs::2.0::user::help::help/Reporting_Problems>, but before you
  808. do that please make sure that your code does work properly under
  809. mod_perl 1.0.
  810.  
  811. However, remember, that it's implemented in pure Perl and not C,
  812. therefore its functionality is not optimized and it's the best to try
  813. to L<port your
  814. code|docs::2.0::user::porting::porting> not to use deprecated
  815. functions and stop using the compatibility layer.
  816.  
  817.  
  818.  
  819.  
  820.  
  821.  
  822. =head1 Compatibility Functions Colliding with mod_perl 2.0 API
  823.  
  824. Most of the functions provided by Apache::compat don't interfere with
  825. mod_perl 2.0 API. However there are several functions which have the
  826. same name in the mod_perl 1.0 and mod_perl 2.0 API, accept the same
  827. number of arguments, but either the arguments themselves aren't the
  828. same or the return values are different. For example the mod_perl 1.0
  829. code:
  830.  
  831.   require Socket;
  832.   my $sockaddr_in = $c->local_addr;
  833.   my ($local_port, $local_addr) = Socket::sockaddr_in($sockaddr_in);
  834.  
  835. should be adjusted to be:
  836.  
  837.   require Apache::Connection;
  838.   require APR::SocketAddr;
  839.   my $sockaddr = $c->local_addr;
  840.   my ($local_port, $local_addr) = ($sockaddr->port, $sockaddr->ip_get);
  841.  
  842. to work under mod_perl 2.0.
  843.  
  844. As you can see in mod_perl 1.0 API local_addr() was returning a
  845. SOCKADDR_IN object (see the Socket perl manpage), in mod_perl 2.0 API
  846. it returns an C<L<APR::SocketAddr|docs::2.0::api::APR::SocketAddr>>
  847. object, which is a totally different beast. If Apache::compat
  848. overrides the function C<local_addr()> to be back-compatible with
  849. mod_perl 1.0 API. Any code that relies on this function to work as it
  850. should under mod_perl 2.0 will be broken. Therefore the solution is
  851. not to override C<local_addr()> by default. Instead a special API is
  852. provided which overrides colliding functions only when needed and
  853. which can be restored when no longer needed. So for example if you
  854. have code from mod_perl 1.0:
  855.  
  856.   my ($local_port, $local_addr) = Socket::sockaddr_in($c->local_addr);
  857.  
  858. and you aren't ready to port it to to use the mp2 API:
  859.  
  860.   my ($local_port, $local_addr) = ($c->local_addr->port,
  861.                                    $c->local_addr->ip_get);
  862.  
  863. you could do the following:
  864.  
  865.   Apache::compat::override_mp2_api('Apache::Connection::local_addr');
  866.   my ($local_port, $local_addr) = Socket::sockaddr_in($c->local_addr);
  867.   Apache::compat::restore_mp2_api('Apache::Connection::local_addr');
  868.  
  869. Notice that you need to restore the API as soon as possible.
  870.  
  871. Both C<override_mp2_api()> and C<restore_mp2_api()> accept a list of
  872. functions to operate on.
  873.  
  874.  
  875.  
  876.  
  877.  
  878.  
  879. =head2 Available Overridable Functions
  880.  
  881. At the moment the following colliding functions are available for
  882. overriding:
  883.  
  884. =over
  885.  
  886. =item * C<Apache::RequestRec::notes>
  887.  
  888. =item * C<Apache::RequestRec::finfo>
  889.  
  890. =item * C<Apache::Connection::local_addr>
  891.  
  892. =item * C<Apache::Connection::remote_addr>
  893.  
  894. =item * C<Apache::server_root_relative>
  895.  
  896. =back
  897.  
  898.  
  899.  
  900.  
  901.  
  902.  
  903.  
  904.  
  905.  
  906.  
  907. =head1 Use in CPAN Modules
  908.  
  909. The short answer: B<Do not use> C<Apache::compat> in CPAN modules.
  910.  
  911. The long answer:
  912.  
  913. C<Apache::compat> is useful during the mod_perl 1.0 code
  914. porting. Though remember that it's implemented in pure Perl. In
  915. certain cases it overrides mod_perl 2.0 methods, because their API is
  916. very different and doesn't map 1:1 to mod_perl 1.0. So if anything,
  917. not under user's control, loads C<Apache::compat> user's code is
  918. forced to use the potentially slower method. Which is quite bad.
  919.  
  920. Some users may choose to keep using C<Apache::compat> in production
  921. and it may perform just fine. Other users will choose not to use that
  922. module, by porting their code to use mod_perl 2.0 API. However it
  923. should be users' choice whether to load this module or not and not to
  924. be enforced by CPAN modules.
  925.  
  926. If you port your CPAN modules to work with mod_perl 2.0, you should
  927. follow the porting L<Perl|docs::2.0::user::porting::porting> and
  928. L<XS|docs::2.0::devel::porting::porting> module guidelines.
  929.  
  930. Users that are stuck with CPAN modules preloading C<Apache::compat>,
  931. can prevent this from happening by adding
  932.  
  933.   $INC{'Apache/compat.pm'} = __FILE__;
  934.  
  935. at the very beginning of their I<startup.pl>. But this will most
  936. certainly break the module that needed this module.
  937.  
  938.  
  939.  
  940.  
  941.  
  942.  
  943. =head1 API
  944.  
  945. You should be reading the mod_perl 1.0 L<API
  946. docs|docs::1.0::api::index> for usage of the methods and functions
  947. in this package, since what this module is doing is providing a
  948. backwards compatibility and it makes no sense to duplicate
  949. documentation.
  950.  
  951. Another important document to read is: L<Migrating from mod_perl 1.0
  952. to mod_perl 2.0|docs::2.0::user::porting::compat> which covers all
  953. mod_perl 1.0 constants, functions and methods that have changed in
  954. mod_perl 2.0.
  955.  
  956.  
  957.  
  958.  
  959.  
  960.  
  961. =head1 See Also
  962.  
  963. L<mod_perl 2.0 documentation|docs::2.0::index>.
  964.  
  965.  
  966.  
  967.  
  968. =head1 Copyright
  969.  
  970. mod_perl 2.0 and its core modules are copyrighted under
  971. The Apache Software License, Version 2.0.
  972.  
  973.  
  974.  
  975.  
  976. =head1 Authors
  977.  
  978. L<The mod_perl development team and numerous
  979. contributors|about::contributors::people>.
  980.  
  981. =cut
  982.