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 / compat.pm < prev    next >
Encoding:
Perl POD Document  |  2004-02-13  |  17.1 KB  |  733 lines
  1. package Apache::compat;
  2.  
  3. use strict;
  4. use warnings FATAL => 'all';
  5. no warnings 'redefine';
  6.  
  7. #1.xx compat layer
  8. #some of this will stay as-is
  9. #some will be implemented proper later on
  10.  
  11. #there's enough here to get simple registry scripts working
  12. #add to startup.pl:
  13. #use Apache::compat ();
  14. #use lib ...; #or something to find 1.xx Apache::Registry
  15.  
  16. #Alias /perl /path/to/perl/scripts
  17. #<Location /perl>
  18. #   Options +ExecCGI
  19. #   SetHandler modperl
  20. #   PerlResponseHandler Apache::Registry
  21. #</Location>
  22.  
  23. use Apache::RequestRec ();
  24. use Apache::SubRequest ();
  25. use Apache::Connection ();
  26. use Apache::Server ();
  27. use Apache::ServerUtil ();
  28. use Apache::Access ();
  29. use Apache::RequestIO ();
  30. use Apache::RequestUtil ();
  31. use Apache::Response ();
  32. use Apache::Util ();
  33. use Apache::Log ();
  34. use Apache::URI ();
  35. use APR::Date ();
  36. use APR::Table ();
  37. use APR::Pool ();
  38. use APR::URI ();
  39. use APR::Util ();
  40. use mod_perl ();
  41. use Symbol ();
  42.  
  43. BEGIN {
  44.     $INC{'Apache.pm'} = __FILE__;
  45.  
  46.     $INC{'Apache/Constants.pm'} = __FILE__;
  47.  
  48.     $INC{'Apache/File.pm'} = __FILE__;
  49.  
  50.     $INC{'Apache/Table.pm'} = __FILE__;
  51. }
  52.  
  53. # api => "overriding code"
  54. # the overriding code, needs to "return" the original CODE reference
  55. # when eval'ed , so that it can be restored later
  56. my %overridable_mp2_api = (
  57.     'Apache::RequestRec::notes' => <<'EOI',
  58. {
  59.     require Apache::RequestRec;
  60.     my $orig_sub = *Apache::RequestRec::notes{CODE};
  61.     *Apache::RequestRec::notes = sub {
  62.         my $r = shift;
  63.         return wantarray()
  64.             ?       ($r->table_get_set(scalar($r->$orig_sub), @_))
  65.             : scalar($r->table_get_set(scalar($r->$orig_sub), @_));
  66.     };
  67.     $orig_sub;
  68. }
  69. EOI
  70.  
  71.     'Apache::RequestRec::finfo' => <<'EOI',
  72. {
  73.     require APR::Finfo;
  74.     my $orig_sub = *APR::Finfo::finfo{CODE};
  75.     sub Apache::RequestRec::finfo {
  76.         my $r = shift;
  77.         stat $r->filename;
  78.         \*_;
  79.     }
  80.     $orig_sub;
  81. }
  82. EOI
  83.  
  84.     'Apache::Connection::local_addr' => <<'EOI',
  85. {
  86.     require Apache::Connection;
  87.     require Socket;
  88.     require APR::SockAddr;
  89.     my $orig_sub = *Apache::Connection::local_addr{CODE};
  90.     *Apache::Connection::local_addr = sub {
  91.         my $c = shift;
  92.         Socket::pack_sockaddr_in($c->$orig_sub->port,
  93.                                  Socket::inet_aton($c->$orig_sub->ip_get));
  94.     };
  95.     $orig_sub;
  96. }
  97. EOI
  98.  
  99.     'Apache::Connection::remote_addr' => <<'EOI',
  100. {
  101.     require Apache::Connection;
  102.     require APR::SockAddr;
  103.     require Socket;
  104.     my $orig_sub = *Apache::Connection::remote_addr{CODE};
  105.     *Apache::Connection::remote_addr = sub {
  106.         my $c = shift;
  107.         if (@_) {
  108.             my $addr_in = shift;
  109.             my($port, $addr) = Socket::unpack_sockaddr_in($addr_in);
  110.             $c->$orig_sub->ip_set($addr);
  111.             $c->$orig_sub->port_set($port);
  112.         }
  113.         else {
  114.             Socket::pack_sockaddr_in($c->$orig_sub->port,
  115.                                      Socket::inet_aton($c->$orig_sub->ip_get));
  116.         }
  117.     };
  118.     $orig_sub;
  119. }
  120. EOI
  121.  
  122.     'APR::URI::unparse' => <<'EOI',
  123. {
  124.     require APR::URI;
  125.     my $orig_sub = *APR::URI::unparse{CODE};
  126.     *APR::URI::unparse = sub {
  127.         my($uri, $flags) = @_;
  128.  
  129.         if (defined $uri->hostname && !defined $uri->scheme) {
  130.             # we do this only for back compat, the new APR::URI is
  131.             # protocol-agnostic and doesn't fallback to 'http' when the
  132.             # scheme is not provided
  133.             $uri->scheme('http');
  134.         }
  135.  
  136.         $orig_sub->(@_);
  137.     };
  138.     $orig_sub;
  139. }
  140. EOI
  141.  
  142.     'Apache::server_root_relative' => <<'EOI',
  143. {
  144.     require Apache::Server;
  145.     require Apache::ServerUtil;
  146.  
  147.     my $orig_sub = *Apache::Server::server_root_relative{CODE};
  148.     *Apache::server_root_relative = sub {
  149.         my $class = shift;
  150.         return Apache->server->server_root_relative(@_);
  151.     };
  152.     $orig_sub;
  153. }
  154.  
  155. EOI
  156.  
  157.     'Apache::Util::ht_time' => <<'EOI',
  158. {
  159.     require Apache::Util;
  160.     my $orig_sub = *Apache::Util::ht_time{CODE};
  161.     *Apache::Util::ht_time = sub {
  162.         my $r = Apache::compat::request('Apache::Util::ht_time');
  163.         return $orig_sub->($r->pool, @_);
  164.     };
  165.     $orig_sub;
  166. }
  167.  
  168. EOI
  169.  
  170. );
  171.  
  172. my %overridden_mp2_api = ();
  173.  
  174. # this function enables back-compatible APIs which can't coexist with
  175. # mod_perl 2.0 APIs with the same name and therefore it should be
  176. # avoided if possible.
  177. #
  178. # it expects a list of fully qualified functions, like
  179. # "Apache::RequestRec::finfo"
  180. sub override_mp2_api {
  181.     my (@subs) = @_;
  182.  
  183.     for my $sub (@subs) {
  184.         unless (exists $overridable_mp2_api{$sub}) {
  185.             die __PACKAGE__ . ": $sub is not overridable";
  186.         }
  187.         if (exists $overridden_mp2_api{$sub}) {
  188.             warn __PACKAGE__ . ": $sub has been already overridden";
  189.             next;
  190.         }
  191.         $overridden_mp2_api{$sub} = eval $overridable_mp2_api{$sub};
  192.         unless (exists $overridden_mp2_api{$sub} &&
  193.                 ref($overridden_mp2_api{$sub}) eq 'CODE') {
  194.             die "overriding $sub didn't return a CODE ref";
  195.         }
  196.     }
  197. }
  198.  
  199. # restore_mp2_api does the opposite of override_mp2_api(), it removes
  200. # the overriden API and restores the original mod_perl 2.0 API
  201. sub restore_mp2_api {
  202.     my (@subs) = @_;
  203.  
  204.     for my $sub (@subs) {
  205.         unless (exists $overridable_mp2_api{$sub}) {
  206.             die __PACKAGE__ . ": $sub is not overridable";
  207.         }
  208.         unless (exists $overridden_mp2_api{$sub}) {
  209.             warn __PACKAGE__ . ": can't restore $sub, " .
  210.                 "as it has not been overridden";
  211.             next;
  212.         }
  213.         # XXX: 5.8.2+ can't delete and assign at once - gives:
  214.         #    Attempt to free unreferenced scalar
  215.         # after perl_clone. the 2 step works ok. to reproduce:
  216.         # t/TEST -maxclients 1 perl/ithreads2.t compat/request.t
  217.         my $original_sub = $overridden_mp2_api{$sub};
  218.         delete $overridden_mp2_api{$sub};
  219.         no warnings 'redefine';
  220.         no strict 'refs';
  221.         *$sub = $original_sub;
  222.     }
  223. }
  224.  
  225. sub request {
  226.     my $what = shift;
  227.  
  228.     my $r = Apache->request;
  229.  
  230.     unless ($r) {
  231.         die "cannot use $what ",
  232.             "without 'SetHandler perl-script' ",
  233.             "or 'PerlOptions +GlobalRequest'";
  234.     }
  235.  
  236.     $r;
  237. }
  238.  
  239. package Apache::Server;
  240. # XXX: is that good enough? see modperl/src/modules/perl/mod_perl.c:367
  241. our $CWD = Apache::Server::server_root;
  242.  
  243. our $AddPerlVersion = 1;
  244.  
  245. package Apache;
  246.  
  247. sub exit {
  248.     require ModPerl::Util;
  249.  
  250.     my $status = 0;
  251.     my $nargs = @_;
  252.  
  253.     if ($nargs == 2) {
  254.         $status = $_[1];
  255.     }
  256.     elsif ($nargs == 1 and $_[0] =~ /^\d+$/) {
  257.         $status = $_[0];
  258.     }
  259.  
  260.     ModPerl::Util::exit($status);
  261. }
  262.  
  263. #XXX: warn
  264. sub import {
  265. }
  266.  
  267. sub untaint {
  268.     shift;
  269.     require ModPerl::Util;
  270.     ModPerl::Util::untaint(@_);
  271. }
  272.  
  273. sub module {
  274.     require Apache::Module;
  275.     die 'Usage: Apache->module($name)' if @_ != 2;
  276.     return Apache::Module::loaded($_[1]);
  277. }
  278.  
  279. sub gensym {
  280.     return Symbol::gensym();
  281. }
  282.  
  283. sub define {
  284.     shift if @_ == 2;
  285.     Apache::Server::exists_config_define(@_);
  286. }
  287.  
  288. sub log_error {
  289.     Apache->server->log_error(@_);
  290. }
  291.  
  292. sub httpd_conf {
  293.     shift;
  294.     my $obj;
  295.     eval { $obj = Apache->request };
  296.     $obj = Apache->server if $@;
  297.     my $err = $obj->add_config([split /\n/, join '', @_]);
  298.     die $err if $err;
  299. }
  300.  
  301. # mp2 always can stack handlers
  302. sub can_stack_handlers { 1; }
  303.  
  304. sub push_handlers {
  305.     shift;
  306.     Apache->server->push_handlers(@_);
  307. }
  308.  
  309. sub set_handlers {
  310.     shift;
  311.     Apache->server->set_handlers(@_);
  312. }
  313.  
  314. sub get_handlers {
  315.     shift;
  316.     Apache->server->get_handlers(@_);
  317. }
  318.  
  319. package Apache::Constants;
  320.  
  321. use Apache::Const ();
  322.  
  323. sub import {
  324.     my $class = shift;
  325.     my $package = scalar caller;
  326.  
  327.     my @args = @_;
  328.  
  329.     # treat :response as :common - it's not perfect
  330.     # but simple and close enough for the majority
  331.     my %args = map { s/^:response$/:common/; $_ => 1 } @args;
  332.  
  333.     Apache::Const->compile($package => keys %args);
  334. }
  335.  
  336. #no need to support in 2.0
  337. sub export {}
  338.  
  339. sub SERVER_VERSION { Apache::Server::get_server_version() }
  340.  
  341. package Apache::RequestRec;
  342.  
  343. use Apache::Const -compile => qw(REMOTE_NAME);
  344.  
  345. #no longer exist in 2.0
  346. sub soft_timeout {}
  347. sub hard_timeout {}
  348. sub kill_timeout {}
  349. sub reset_timeout {}
  350.  
  351. # this function is from mp1's Apache::SubProcess 3rd party module
  352. # which is now a part of mp2 API. this function doesn't exist in 2.0.
  353. sub cleanup_for_exec {}
  354.  
  355. sub current_callback {
  356.     return Apache::current_callback();
  357. }
  358.  
  359. sub send_http_header {
  360.     my ($r, $type) = @_;
  361.  
  362.     # since send_http_header() in mp1 was telling mod_perl not to
  363.     # parse headers and in mp2 one must call $r->content_type($type) to
  364.     # perform the same, we make sure that this happens
  365.     $type = $r->content_type || 'text/html' unless defined $type;
  366.  
  367.     $r->content_type($type);
  368. }
  369.  
  370. #we support Apache->request; this is needed to support $r->request
  371. #XXX: seems sorta backwards
  372. *request = \&Apache::request;
  373.  
  374. sub table_get_set {
  375.     my($r, $table) = (shift, shift);
  376.     my($key, $value) = @_;
  377.  
  378.     if (1 == @_) {
  379.         return wantarray() 
  380.             ?       ($table->get($key))
  381.             : scalar($table->get($key));
  382.     }
  383.     elsif (2 == @_) {
  384.         if (defined $value) {
  385.             return wantarray() 
  386.                 ?        ($table->set($key, $value))
  387.                 :  scalar($table->set($key, $value));
  388.         }
  389.         else {
  390.             return wantarray() 
  391.                 ?       ($table->unset($key))
  392.                 : scalar($table->unset($key));
  393.         }
  394.     }
  395.     elsif (0 == @_) {
  396.         return $table;
  397.     }
  398.     else {
  399.         my $name = (caller(1))[3];
  400.         warn "Usage: \$r->$name([key [,val]])";
  401.     }
  402. }
  403.  
  404. sub header_out {
  405.     my $r = shift;
  406.     return wantarray() 
  407.         ?       ($r->table_get_set(scalar($r->headers_out), @_))
  408.         : scalar($r->table_get_set(scalar($r->headers_out), @_));
  409. }
  410.  
  411. sub header_in {
  412.     my $r = shift;
  413.     return wantarray() 
  414.         ?       ($r->table_get_set(scalar($r->headers_in), @_))
  415.         : scalar($r->table_get_set(scalar($r->headers_in), @_));
  416. }
  417.  
  418. sub err_header_out {
  419.     my $r = shift;
  420.     return wantarray() 
  421.         ?       ($r->table_get_set(scalar($r->err_headers_out), @_))
  422.         : scalar($r->table_get_set(scalar($r->err_headers_out), @_));
  423. }
  424.  
  425.  
  426. sub register_cleanup {
  427.     shift->pool->cleanup_register(@_);
  428. }
  429.  
  430. *post_connection = \®ister_cleanup;
  431.  
  432. sub get_remote_host {
  433.     my($r, $type) = @_;
  434.     $type = Apache::REMOTE_NAME unless defined $type;
  435.     $r->connection->get_remote_host($type, $r->per_dir_config);
  436. }
  437.  
  438. #XXX: should port 1.x's Apache::URI::unescape_url_info
  439. sub parse_args {
  440.     my($r, $string) = @_;
  441.     return () unless defined $string and $string;
  442.  
  443.     return map {
  444.         tr/+/ /;
  445.         s/%([0-9a-fA-F]{2})/pack("C",hex($1))/ge;
  446.         $_;
  447.     } split /[=&;]/, $string, -1;
  448. }
  449.  
  450. #sorry, have to use $r->Apache::args at the moment
  451. #for list context splitting
  452.  
  453. sub Apache::args {
  454.     my $r = shift;
  455.     my $args = $r->args;
  456.     return $args unless wantarray;
  457.     return $r->parse_args($args);
  458. }
  459.  
  460. use constant IOBUFSIZE => 8192;
  461.  
  462. sub content {
  463.     my $r = shift;
  464.  
  465.     $r->setup_client_block;
  466.  
  467.     return undef unless $r->should_client_block;
  468.  
  469.     my $data = '';
  470.     my $buf;
  471.     while (my $read_len = $r->get_client_block($buf, IOBUFSIZE)) {
  472.         if ($read_len == -1) {
  473.             die "some error while reading with get_client_block";
  474.         }
  475.         $data .= $buf;
  476.     }
  477.  
  478.     return $data unless wantarray;
  479.     return $r->parse_args($data);
  480. }
  481.  
  482. sub clear_rgy_endav {
  483.     my($r, $script_name) = @_;
  484.     require ModPerl::Global;
  485.     my $package = 'Apache::ROOT' . $script_name;
  486.     ModPerl::Global::special_list_clear(END => $package);
  487. }
  488.  
  489. sub stash_rgy_endav {
  490.     #see run_rgy_endav
  491. }
  492.  
  493. #if somebody really wants to have END subroutine support
  494. #with the 1.x Apache::Registry they will need to configure:
  495. # PerlHandler Apache::Registry Apache::compat::run_rgy_endav
  496. sub Apache::compat::run_rgy_endav {
  497.     my $r = shift;
  498.  
  499.     require ModPerl::Global;
  500.     require Apache::PerlRun; #1.x's
  501.     my $package = Apache::PerlRun->new($r)->namespace;
  502.  
  503.     ModPerl::Global::special_list_call(END => $package);
  504. }
  505.  
  506. sub seqno {
  507.     1;
  508. }
  509.  
  510. sub chdir_file {
  511.     #XXX resolve '.' in @INC to basename $r->filename
  512. }
  513.  
  514. *log_reason = \&log_error;
  515.  
  516. #XXX: would like to have a proper implementation
  517. #that reads line-by-line as defined by $/
  518. #the best way will probably be to use perlio in 5.8.0
  519. #anything else would be more effort than it is worth
  520. sub READLINE {
  521.     my $r = shift;
  522.     my $line;
  523.     $r->read($line, $r->headers_in->get('Content-length'));
  524.     $line ? $line : undef;
  525. }
  526.  
  527. #XXX: howto convert PerlIO to apr_file_t
  528. #so we can use the real ap_send_fd function
  529. #2.0 ap_send_fd() also has an additional offset parameter
  530.  
  531. sub send_fd_length {
  532.     my($r, $fh, $length) = @_;
  533.  
  534.     my $buff;
  535.     my $total_bytes_sent = 0;
  536.     my $len;
  537.  
  538.     return 0 if $length == 0;
  539.  
  540.     if (($length > 0) && ($total_bytes_sent + IOBUFSIZE) > $length) {
  541.         $len = $length - $total_bytes_sent;
  542.     }
  543.     else {
  544.         $len = IOBUFSIZE;
  545.     }
  546.  
  547.     binmode $fh;
  548.  
  549.     while (CORE::read($fh, $buff, $len)) {
  550.         $total_bytes_sent += $r->puts($buff);
  551.     }
  552.  
  553.     $total_bytes_sent;
  554. }
  555.  
  556. sub send_fd {
  557.     my($r, $fh) = @_;
  558.     $r->send_fd_length($fh, -1);
  559. }
  560.  
  561. sub is_main { !shift->main }
  562.  
  563. # really old back-compat methods, they shouldn't be used in mp1
  564. *cgi_var = *cgi_env = \&Apache::RequestRec::subprocess_env;
  565.  
  566. package Apache::File;
  567.  
  568. use Fcntl ();
  569. use Symbol ();
  570. use Carp ();
  571.  
  572. sub new {
  573.     my($class) = shift;
  574.     my $fh = Symbol::gensym;
  575.     my $self = bless $fh, ref($class)||$class;
  576.     if (@_) {
  577.         return $self->open(@_) ? $self : undef;
  578.     }
  579.     else {
  580.         return $self;
  581.     }
  582. }
  583.  
  584. sub open {
  585.     my($self) = shift;
  586.  
  587.     Carp::croak("no Apache::File object passed")
  588.           unless $self && ref($self);
  589.  
  590.     # cannot forward @_ to open() because of its prototype
  591.     if (@_ > 1) {
  592.         my ($mode, $file) = @_;
  593.         CORE::open $self, $mode, $file;
  594.     }
  595.     else {
  596.         my $file = shift;
  597.         CORE::open $self, $file;
  598.     }
  599. }
  600.  
  601. sub close {
  602.     my($self) = shift;
  603.     CORE::close $self;
  604. }
  605.  
  606. my $TMPNAM = 'aaaaaa';
  607. my $TMPDIR = $ENV{'TMPDIR'} || $ENV{'TEMP'} || '/tmp';
  608. ($TMPDIR) = $TMPDIR =~ /^([^<>|;*]+)$/; #untaint
  609. my $Mode = Fcntl::O_RDWR()|Fcntl::O_EXCL()|Fcntl::O_CREAT();
  610. my $Perms = 0600;
  611.  
  612. sub tmpfile {
  613.     my $class = shift;
  614.     my $limit = 100;
  615.     my $r = Apache::compat::request('Apache::File->tmpfile');
  616.  
  617.     while ($limit--) {
  618.         my $tmpfile = "$TMPDIR/${$}" . $TMPNAM++;
  619.         my $fh = $class->new;
  620.  
  621.         sysopen $fh, $tmpfile, $Mode, $Perms
  622.             or die "failed to open $tmpfile: $!";
  623.         $r->pool->cleanup_register(sub { unlink $tmpfile });
  624.  
  625.         if ($fh) {
  626.             return wantarray ? ($tmpfile, $fh) : $fh;
  627.         }
  628.     }
  629. }
  630.  
  631. # the following functions now live in Apache::Response
  632. # * discard_request_body
  633. # * meets_conditions
  634. # * set_content_length
  635. # * set_etag
  636. # * set_last_modified
  637. # * update_mtime
  638.  
  639. # the following functions now live in Apache::RequestRec
  640. # * mtime
  641.  
  642. package Apache::Util;
  643.  
  644. sub size_string {
  645.     my($size) = @_;
  646.  
  647.     if (!$size) {
  648.         $size = "   0k";
  649.     }
  650.     elsif ($size == -1) {
  651.         $size = "    -";
  652.     }
  653.     elsif ($size < 1024) {
  654.         $size = "   1k";
  655.     }
  656.     elsif ($size < 1048576) {
  657.         $size = sprintf "%4dk", ($size + 512) / 1024;
  658.     }
  659.     elsif ($size < 103809024) {
  660.         $size = sprintf "%4.1fM", $size / 1048576.0;
  661.     }
  662.     else {
  663.         $size = sprintf "%4dM", ($size + 524288) / 1048576;
  664.     }
  665.  
  666.     return $size;
  667. }
  668.  
  669. *unescape_uri = \&Apache::URI::unescape_url;
  670.  
  671. sub escape_uri {
  672.     my $path = shift;
  673.     my $r = Apache::compat::request('Apache::Util::escape_uri');
  674.     Apache::Util::escape_path($path, $r->pool);
  675. }
  676.  
  677. #tmp compat until ap_escape_html is reworked to not require a pool
  678. my %html_escapes = (
  679.     '<' => 'lt',
  680.     '>' => 'gt',
  681.     '&' => 'amp',
  682.     '"' => 'quot',
  683. );
  684.  
  685. %html_escapes = map { $_, "&$html_escapes{$_};" } keys %html_escapes;
  686.  
  687. my $html_escape = join '|', keys %html_escapes;
  688.  
  689. sub escape_html {
  690.     my $html = shift;
  691.     $html =~ s/($html_escape)/$html_escapes{$1}/go;
  692.     $html;
  693. }
  694.  
  695. *parsedate = \&APR::Date::parse_http;
  696.  
  697. *validate_password = \&APR::password_validate;
  698.  
  699. sub Apache::URI::parse {
  700.     my($class, $r, $uri) = @_;
  701.  
  702.     $uri ||= $r->construct_url;
  703.  
  704.     APR::URI->parse($r->pool, $uri);
  705. }
  706.  
  707. package Apache::Table;
  708.  
  709. sub new {
  710.     my($class, $r, $nelts) = @_;
  711.     $nelts ||= 10;
  712.     APR::Table::make($r->pool, $nelts);
  713. }
  714.  
  715. package Apache::SIG;
  716.  
  717. use Apache::Const -compile => 'DECLINED';
  718.  
  719. sub handler {
  720.     # don't set the SIGPIPE
  721.     return Apache::DECLINED;
  722. }
  723.  
  724. package Apache::Connection;
  725.  
  726. # auth_type and user records don't exist in 2.0 conn_rec struct
  727. # 'PerlOptions +GlobalRequest' is required
  728. sub auth_type { shift; Apache->request->ap_auth_type(@_) }
  729. sub user      { shift; Apache->request->user(@_)      }
  730.  
  731. 1;
  732. __END__
  733.