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 / RegistryCooker.pm < prev    next >
Encoding:
Perl POD Document  |  2004-09-17  |  30.4 KB  |  1,087 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. # VERY IMPORTANT: Be very careful modifying the defaults, since many
  16. # VERY IMPORTANT: packages rely on them. In fact you should never
  17. # VERY IMPORTANT: modify the defaults after the package gets released,
  18. # VERY IMPORTANT: since they are a hardcoded part of this suite's API.
  19.  
  20. package ModPerl::RegistryCooker;
  21.  
  22. require 5.006;
  23.  
  24. use strict;
  25. use warnings FATAL => 'all';
  26.  
  27. our $VERSION = '1.99';
  28.  
  29. use Apache::Response ();
  30. use Apache::RequestRec ();
  31. use Apache::RequestUtil ();
  32. use Apache::RequestIO ();
  33. use Apache::Log ();
  34. use Apache::Access ();
  35.  
  36. use APR::Table ();
  37.  
  38. use ModPerl::Util ();
  39. use ModPerl::Global ();
  40.  
  41. use File::Spec::Functions ();
  42. use File::Basename;
  43.  
  44. use Apache::Const  -compile => qw(:common &OPT_EXECCGI);
  45. use ModPerl::Const -compile => 'EXIT';
  46.  
  47. unless (defined $ModPerl::Registry::MarkLine) {
  48.     $ModPerl::Registry::MarkLine = 1;
  49. }
  50.  
  51. #########################################################################
  52. # debug constants
  53. #
  54. #########################################################################
  55. use constant D_NONE    => 0;
  56. use constant D_ERROR   => 1;
  57. use constant D_WARN    => 2;
  58. use constant D_COMPILE => 4;
  59. use constant D_NOISE   => 8;
  60.  
  61. # the debug level can be overriden on the main server level of
  62. # httpd.conf with:
  63. #   PerlSetVar ModPerl::RegistryCooker::DEBUG 4
  64. use Apache::ServerUtil ();
  65. use constant DEBUG => 0;
  66. #XXX: below currently crashes the server on win32
  67. #    defined Apache->server->dir_config('ModPerl::RegistryCooker::DEBUG')
  68. #        ? Apache->server->dir_config('ModPerl::RegistryCooker::DEBUG')
  69. #        : D_NONE;
  70.  
  71. #########################################################################
  72. # OS specific constants
  73. #
  74. #########################################################################
  75. use constant IS_WIN32 => $^O eq "MSWin32";
  76.  
  77. #########################################################################
  78. # constant subs
  79. #
  80. #########################################################################
  81. use constant NOP   => '';
  82. use constant TRUE  => 1;
  83. use constant FALSE => 0;
  84.  
  85.  
  86. use constant NAMESPACE_ROOT => 'ModPerl::ROOT';
  87.  
  88.  
  89. #########################################################################
  90.  
  91. unless (defined $ModPerl::RegistryCooker::NameWithVirtualHost) {
  92.     $ModPerl::RegistryCooker::NameWithVirtualHost = 1;
  93. }
  94.  
  95. #########################################################################
  96. # func: new
  97. # dflt: new
  98. # args: $class - class to bless into
  99. #       $r     - Apache::Request object
  100. # desc: create the class's object and bless it
  101. # rtrn: the newly created object
  102. #########################################################################
  103.  
  104. sub new {
  105.     my($class, $r) = @_;
  106.     my $self = bless {}, $class;
  107.     $self->init($r);
  108.     return $self;
  109. }
  110.  
  111. #########################################################################
  112. # func: init
  113. # dflt: init
  114. # desc: initializes the data object's fields: REQ FILENAME URI
  115. # args: $r - Apache::Request object
  116. # rtrn: nothing
  117. #########################################################################
  118.  
  119. sub init {
  120.     $_[0]->{REQ}      = $_[1];
  121.     $_[0]->{URI}      = $_[1]->uri;
  122.     $_[0]->{FILENAME} = $_[1]->filename;
  123. }
  124.  
  125. #########################################################################
  126. # func: handler
  127. # dflt: handler
  128. # desc: the handler() sub that is expected by Apache
  129. # args: $class - handler's class
  130. #       $r     - Apache::Request object
  131. #       (o)can be called as handler($r) as well (without leading $class)
  132. # rtrn: handler's response status
  133. # note: must be implemented in a sub-class unless configured as
  134. #       Apache::Foo->handler in httpd.conf (because of the
  135. #       __PACKAGE__, which is tied to the file)
  136. #########################################################################
  137.  
  138. sub handler : method {
  139.     my $class = (@_ >= 2) ? shift : __PACKAGE__;
  140.     my $r = shift;
  141.     return $class->new($r)->default_handler();
  142. }
  143.  
  144. #########################################################################
  145. # func: default_handler
  146. # dflt: META: see above
  147. # desc: META: see above
  148. # args: $self - registry blessed object
  149. # rtrn: handler's response status
  150. # note: that's what most sub-class handlers will call
  151. #########################################################################
  152.  
  153. sub default_handler {
  154.     my $self = shift;
  155.  
  156.     $self->make_namespace;
  157.  
  158.     if ($self->should_compile) {
  159.         my $rc = $self->can_compile;
  160.         return $rc unless $rc == Apache::OK;
  161.         $rc = $self->convert_script_to_compiled_handler;
  162.         return $rc unless $rc == Apache::OK;
  163.     }
  164.  
  165.     # handlers shouldn't set $r->status but return it, so we reset the
  166.     # status after running it
  167.     my $old_status = $self->{REQ}->status;
  168.     my $rc = $self->run;
  169.     my $new_status = $self->{REQ}->status($old_status);
  170.     return ($rc == Apache::OK && $old_status != $new_status)
  171.         ? $new_status
  172.         : $rc;
  173. }
  174.  
  175. #########################################################################
  176. # func: run
  177. # dflt: run
  178. # desc: executes the compiled code
  179. # args: $self - registry blessed object
  180. # rtrn: execution status (Apache::?)
  181. #########################################################################
  182.  
  183. sub run {
  184.     my $self = shift;
  185.  
  186.     my $r       = $self->{REQ};
  187.     my $package = $self->{PACKAGE};
  188.  
  189.     $self->chdir_file;
  190.  
  191.     my $cv = \&{"$package\::handler"};
  192.  
  193.     my %orig_inc;
  194.     if ($self->should_reset_inc_hash) {
  195.         %orig_inc = %INC;
  196.     }
  197.  
  198.     my $rc = Apache::OK;
  199.     { # run the code and preserve warnings setup when it's done
  200.         no warnings FATAL => 'all';
  201.         #local $^W = 0;
  202.         eval { $cv->($r, @_) };
  203.  
  204.         # log script's execution errors
  205.         $rc = $self->error_check;
  206.  
  207.         {
  208.             # there might be no END blocks to call, so $@ will be not
  209.             # reset
  210.             local $@;
  211.             ModPerl::Global::special_list_call(END => $package);
  212.  
  213.             # log script's END blocks execution errors
  214.             my $new_rc = $self->error_check;
  215.  
  216.             # use the END blocks return status if the script's execution
  217.             # was successful
  218.             $rc = $new_rc if $rc == Apache::OK;
  219.         }
  220.  
  221.     }
  222.  
  223.     if ($self->should_reset_inc_hash) {
  224.         # to avoid the bite of require'ing a file with no package delaration
  225.         # Apache::PerlRun in mod_perl 1.15_01 started to localize %INC
  226.         # later on it has been adjusted to preserve loaded .pm files,
  227.         # which presumably contained the package declaration
  228.         for (keys %INC) {
  229.             next if $orig_inc{$_};
  230.             next if /\.pm$/;
  231.             delete $INC{$_};
  232.         }
  233.     }
  234.  
  235.     $self->flush_namespace;
  236.  
  237.     #XXX: $self->chdir_file("$Apache::Server::CWD/");
  238.  
  239.     return $rc;
  240. }
  241.  
  242.  
  243.  
  244. #########################################################################
  245. # func: can_compile
  246. # dflt: can_compile
  247. # desc: checks whether the script is allowed and can be compiled
  248. # args: $self - registry blessed object
  249. # rtrn: $rc - return status to forward
  250. # efct: initializes the data object's fields: MTIME
  251. #########################################################################
  252.  
  253. sub can_compile {
  254.     my $self = shift;
  255.     my $r = $self->{REQ};
  256.  
  257.     unless (-r $r->my_finfo && -s _) {
  258.         $self->log_error("$self->{FILENAME} not found or unable to stat");
  259.         return Apache::NOT_FOUND;
  260.     }
  261.  
  262.     return Apache::DECLINED if -d _;
  263.  
  264.     $self->{MTIME} = -M _;
  265.  
  266.     unless (-x _ or IS_WIN32) {
  267.         $r->log_error("file permissions deny server execution",
  268.                        $self->{FILENAME});
  269.         return Apache::FORBIDDEN;
  270.     }
  271.  
  272.     if (!($r->allow_options & Apache::OPT_EXECCGI)) {
  273.         $r->log_error("Options ExecCGI is off in this directory",
  274.                        $self->{FILENAME});
  275.         return Apache::FORBIDDEN;
  276.     }
  277.  
  278.     $self->debug("can compile $self->{FILENAME}") if DEBUG & D_NOISE;
  279.  
  280.     return Apache::OK;
  281.  
  282. }
  283. #########################################################################
  284. # func: namespace_root
  285. # dflt: namespace_root
  286. # desc: define the namespace root for storing compiled scripts
  287. # args: $self - registry blessed object
  288. # rtrn: the namespace root
  289. #########################################################################
  290.  
  291. sub namespace_root {
  292.     my $self = shift;
  293.     join '::', NAMESPACE_ROOT, ref($self);
  294. }
  295.  
  296. #########################################################################
  297. # func: make_namespace
  298. # dflt: make_namespace
  299. # desc: prepares the namespace
  300. # args: $self - registry blessed object
  301. # rtrn: the namespace
  302. # efct: initializes the field: PACKAGE
  303. #########################################################################
  304.  
  305. sub make_namespace {
  306.     my $self = shift;
  307.  
  308.     my $package = $self->namespace_from;
  309.  
  310.     # Escape everything into valid perl identifiers
  311.     $package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
  312.  
  313.     # make sure that the sub-package doesn't start with a digit
  314.     $package =~ s/^(\d)/_$1/;
  315.  
  316.     # prepend root
  317.     $package = $self->namespace_root() . "::$package";
  318.  
  319.     $self->{PACKAGE} = $package;
  320.  
  321.     return $package;
  322. }
  323.  
  324. #########################################################################
  325. # func: namespace_from
  326. # dflt: namespace_from_filename
  327. # desc: returns a partial raw package name based on filename, uri, else
  328. # args: $self - registry blessed object
  329. # rtrn: a unique string
  330. #########################################################################
  331.  
  332. *namespace_from = \&namespace_from_filename;
  333.  
  334. # return a package name based on $r->filename only
  335. sub namespace_from_filename {
  336.     my $self = shift;
  337.  
  338.     my ($volume, $dirs, $file) = 
  339.         File::Spec::Functions::splitpath($self->{FILENAME});
  340.     my @dirs = File::Spec::Functions::splitdir($dirs);
  341.     return join '_', grep { defined && length } $volume, @dirs, $file;
  342. }
  343.  
  344. # return a package name based on $r->uri only
  345. sub namespace_from_uri {
  346.     my $self = shift;
  347.  
  348.     my $path_info = $self->{REQ}->path_info;
  349.     my $script_name = $path_info && $self->{URI} =~ /$path_info$/
  350.         ? substr($self->{URI}, 0, length($self->{URI}) - length($path_info))
  351.         : $self->{URI};
  352.  
  353.     if ($ModPerl::RegistryCooker::NameWithVirtualHost && 
  354.         $self->{REQ}->server->is_virtual) {
  355.         my $name = $self->{REQ}->get_server_name;
  356.         $script_name = join "", $name, $script_name if $name;
  357.     }
  358.  
  359.     $script_name =~ s:/+$:/__INDEX__:;
  360.  
  361.     return $script_name;
  362. }
  363.  
  364. #########################################################################
  365. # func: convert_script_to_compiled_handler
  366. # dflt: convert_script_to_compiled_handler
  367. # desc: reads the script, converts into a handler and compiles it
  368. # args: $self - registry blessed object
  369. # rtrn: success/failure status
  370. #########################################################################
  371.  
  372. sub convert_script_to_compiled_handler {
  373.     my $self = shift;
  374.  
  375.     $self->debug("Adding package $self->{PACKAGE}") if DEBUG & D_NOISE;
  376.  
  377.     # get the script's source
  378.     $self->read_script;
  379.  
  380.     # convert the shebang line opts into perl code
  381.     $self->rewrite_shebang;
  382.  
  383.     # mod_cgi compat, should compile the code while in its dir, so
  384.     # relative require/open will work.
  385.     $self->chdir_file;
  386.  
  387. #    undef &{"$self->{PACKAGE}\::handler"}; unless DEBUG & D_NOISE; #avoid warnings
  388. #    $self->{PACKAGE}->can('undef_functions') && $self->{PACKAGE}->undef_functions;
  389.  
  390.     my $line = $self->get_mark_line;
  391.  
  392.     $self->strip_end_data_segment;
  393.  
  394.     # handle the non-parsed handlers ala mod_cgi (though mod_cgi does
  395.     # some tricks removing the header_out and other filters, here we
  396.     # just call assbackwards which has the same effect).
  397.     my $base = File::Basename::basename($self->{FILENAME});
  398.     my $nph = substr($base, 0, 4) eq 'nph-' ? '$_[0]->assbackwards(1);' : "";
  399.     my $script_name = $self->get_script_name || $0;
  400.  
  401.     my $eval = join '',
  402.                     'package ',
  403.                     $self->{PACKAGE}, ";",
  404.                     "sub handler {",
  405.                     "local \$0 = '$script_name';",
  406.                     $nph,
  407.                     $line,
  408.                     ${ $self->{CODE} },
  409.                     "\n}"; # last line comment without newline?
  410.  
  411.     my $rc = $self->compile(\$eval);
  412.     return $rc unless $rc == Apache::OK;
  413.     $self->debug(qq{compiled package \"$self->{PACKAGE}\"}) if DEBUG & D_NOISE;
  414.  
  415.     #$self->chdir_file("$Apache::Server::CWD/");
  416.  
  417. #    if(my $opt = $r->dir_config("PerlRunOnce")) {
  418. #        $r->child_terminate if lc($opt) eq "on";
  419. #    }
  420.  
  421.     $self->cache_it;
  422.  
  423.     return $rc;
  424. }
  425.  
  426. #########################################################################
  427. # func: cache_table
  428. # dflt: cache_table_common
  429. # desc: return a symbol table for caching compiled scripts in
  430. # args: $self - registry blessed object (or the class name)
  431. # rtrn: symbol table
  432. #########################################################################
  433.  
  434. *cache_table = \&cache_table_common;
  435.  
  436. sub cache_table_common {
  437.     \%ModPerl::RegistryCache;
  438. }
  439.  
  440.  
  441. sub cache_table_local {
  442.     my $self = shift;
  443.     my $class = ref($self) || $self;
  444.     no strict 'refs';
  445.     \%$class;
  446. }
  447.  
  448. #########################################################################
  449. # func: cache_it
  450. # dflt: cache_it
  451. # desc: mark the package as cached by storing its modification time
  452. # args: $self - registry blessed object
  453. # rtrn: nothing
  454. #########################################################################
  455.  
  456. sub cache_it {
  457.     my $self = shift;
  458.     $self->cache_table->{ $self->{PACKAGE} }{mtime} = $self->{MTIME};
  459. }
  460.  
  461.  
  462. #########################################################################
  463. # func: is_cached
  464. # dflt: is_cached
  465. # desc: checks whether the package is already cached
  466. # args: $self - registry blessed object
  467. # rtrn: TRUE if cached,
  468. #       FALSE otherwise
  469. #########################################################################
  470.  
  471. sub is_cached {
  472.     my $self = shift;
  473.     exists $self->cache_table->{ $self->{PACKAGE} }{mtime};
  474. }
  475.  
  476.  
  477. #########################################################################
  478. # func: should_compile
  479. # dflt: should_compile_once
  480. # desc: decide whether code should be compiled or not
  481. # args: $self - registry blessed object
  482. # rtrn: TRUE if should compile
  483. #       FALSE otherwise
  484. # efct: sets MTIME if it's not set yet
  485. #########################################################################
  486.  
  487. *should_compile = \&should_compile_once;
  488.  
  489. # return false only if the package is cached and its source file
  490. # wasn't modified
  491. sub should_compile_if_modified {
  492.     my $self = shift;
  493.     $self->{MTIME} ||= -M $self->{REQ}->my_finfo;
  494.     !($self->is_cached && 
  495.       $self->cache_table->{ $self->{PACKAGE} }{mtime} <= $self->{MTIME});
  496. }
  497.  
  498. # return false if the package is cached already
  499. sub should_compile_once {
  500.     not shift->is_cached;
  501. }
  502.  
  503. #########################################################################
  504. # func: should_reset_inc_hash
  505. # dflt: FALSE
  506. # desc: decide whether to localize %INC for required .pl files from the script
  507. # args: $self - registry blessed object
  508. # rtrn: TRUE if should reset
  509. #       FALSE otherwise
  510. #########################################################################
  511.  
  512. *should_reset_inc_hash = \&FALSE;
  513.  
  514. #########################################################################
  515. # func: flush_namespace
  516. # dflt: NOP (don't flush)
  517. # desc: flush the compiled package's namespace
  518. # args: $self - registry blessed object
  519. # rtrn: nothing
  520. #########################################################################
  521.  
  522. *flush_namespace = \&NOP;
  523.  
  524. sub flush_namespace_normal {
  525.     my $self = shift;
  526.  
  527.     $self->debug("flushing namespace") if DEBUG & D_NOISE;
  528.  
  529.     no strict 'refs';
  530.     my $tab = \%{ $self->{PACKAGE} . '::' };
  531.  
  532.     # below we assign to a symbol first before undef'ing it, to avoid
  533.     # nuking aliases. If we undef directly we may undef not only the
  534.     # alias but the original function as well
  535.  
  536.     for (keys %$tab) {
  537.         my $fullname = join '::', $self->{PACKAGE}, $_;
  538.         # code/hash/array/scalar might be imported make sure the gv
  539.         # does not point elsewhere before undefing each
  540.         if (%$fullname) {
  541.             *{$fullname} = {};
  542.             undef %$fullname;
  543.         }
  544.         if (@$fullname) {
  545.             *{$fullname} = [];
  546.             undef @$fullname;
  547.         }
  548.         if ($$fullname) {
  549.             my $tmp; # argh, no such thing as an anonymous scalar
  550.             *{$fullname} = \$tmp;
  551.             undef $$fullname;
  552.         }
  553.         if (defined &$fullname) {
  554.             no warnings;
  555.             local $^W = 0;
  556.             if (defined(my $p = prototype $fullname)) {
  557.                 *{$fullname} = eval "sub ($p) {}";
  558.             }
  559.             else {
  560.                 *{$fullname} = sub {};
  561.             }
  562.             undef &$fullname;
  563.         }
  564.         if (*{$fullname}{IO}) {
  565.             if (fileno $fullname) {
  566.                 close $fullname;
  567.             }
  568.         }
  569.     }
  570. }
  571.  
  572.  
  573. #########################################################################
  574. # func: read_script
  575. # dflt: read_script
  576. # desc: reads the script in
  577. # args: $self - registry blessed object
  578. # rtrn: nothing
  579. # efct: initializes the CODE field with the source script
  580. #########################################################################
  581.  
  582. # reads the contents of the file
  583. sub read_script {
  584.     my $self = shift;
  585.  
  586.     $self->debug("reading $self->{FILENAME}") if DEBUG & D_NOISE;
  587.     $self->{CODE} = $self->{REQ}->slurp_filename(0); # untainted
  588. }
  589.  
  590. #########################################################################
  591. # func: rewrite_shebang
  592. # dflt: rewrite_shebang
  593. # desc: parse the shebang line and convert command line switches
  594. #       (defined in %switches) into a perl code.
  595. # args: $self - registry blessed object
  596. # rtrn: nothing
  597. # efct: the CODE field gets adjusted
  598. #########################################################################
  599.  
  600. my %switches = (
  601.    'T' => sub {
  602.        Apache::warn("-T switch is ignored, " .
  603.                     "enable with 'PerlSwitches -T' in httpd.conf\n")
  604.              unless ${^TAINT};
  605.        "";
  606.    },
  607.    'w' => sub { "use warnings;\n" },
  608. );
  609.  
  610. sub rewrite_shebang {
  611.     my $self = shift;
  612.     my($line) = ${ $self->{CODE} } =~ /^(.*)$/m;
  613.     my @cmdline = split /\s+/, $line;
  614.     return unless @cmdline;
  615.     return unless shift(@cmdline) =~ /^\#!/;
  616.  
  617.     my $prepend = "";
  618.     for my $s (@cmdline) {
  619.         next unless $s =~ s/^-//;
  620.         last if substr($s,0,1) eq "-";
  621.         for (split //, $s) {
  622.             next unless exists $switches{$_};
  623.             $prepend .= $switches{$_}->();
  624.         }
  625.     }
  626.     ${ $self->{CODE} } =~ s/^/$prepend/ if $prepend;
  627. }
  628.  
  629. #########################################################################
  630. # func: get_script_name
  631. # dflt: get_script_name
  632. # desc: get the script's name to set into $0
  633. # args: $self - registry blessed object
  634. # rtrn: path to the script's filename
  635. #########################################################################
  636.  
  637. sub get_script_name {
  638.     shift->{FILENAME};
  639. }
  640.  
  641. #########################################################################
  642. # func: chdir_file
  643. # dflt: NOP
  644. # desc: chdirs into $dir
  645. # args: $self - registry blessed object
  646. #       $dir - a dir 
  647. # rtrn: nothing (?or success/failure?)
  648. #########################################################################
  649.  
  650. *chdir_file = \&NOP;
  651.  
  652. sub chdir_file_normal {
  653.     my($self, $dir) = @_;
  654.     # $self->{REQ}->chdir_file($dir ? $dir : $self->{FILENAME});
  655. }
  656.  
  657. #########################################################################
  658. # func: get_mark_line
  659. # dflt: get_mark_line
  660. # desc: generates the perl compiler #line directive
  661. # args: $self - registry blessed object
  662. # rtrn: returns the perl compiler #line directive
  663. #########################################################################
  664.  
  665. sub get_mark_line {
  666.     my $self = shift;
  667.     $ModPerl::Registry::MarkLine ? "\n#line 1 $self->{FILENAME}\n" : "";
  668. }
  669.  
  670. #########################################################################
  671. # func: strip_end_data_segment
  672. # dflt: strip_end_data_segment
  673. # desc: remove the trailing non-code from $self->{CODE}
  674. # args: $self - registry blessed object
  675. # rtrn: nothing
  676. #########################################################################
  677.  
  678. sub strip_end_data_segment {
  679.     ${ +shift->{CODE} } =~ s/__(END|DATA)__(.*)//s;
  680. }
  681.  
  682.  
  683.  
  684. #########################################################################
  685. # func: compile
  686. # dflt: compile
  687. # desc: compile the code in $eval
  688. # args: $self - registry blessed object
  689. #       $eval - a ref to a scalar with the code to compile
  690. # rtrn: success/failure
  691. # note: $r must not be in scope of compile(), scripts must do
  692. #       my $r = shift; to get it off the args stack
  693. #########################################################################
  694.  
  695. sub compile {
  696.     my($self, $eval) = @_;
  697.  
  698.     $self->debug("compiling $self->{FILENAME}") if DEBUG && D_COMPILE;
  699.  
  700.     ModPerl::Global::special_list_register(END => $self->{PACKAGE});
  701.     ModPerl::Global::special_list_clear(   END => $self->{PACKAGE});
  702.  
  703.     {
  704.         # let the code define its own warn and strict level 
  705.         no strict;
  706.         no warnings FATAL => 'all'; # because we use FATAL 
  707.         eval $$eval;
  708.     }
  709.  
  710.     return $self->error_check;
  711. }
  712.  
  713. #########################################################################
  714. # func: error_check
  715. # dflt: error_check
  716. # desc: checks $@ for errors
  717. # args: $self - registry blessed object
  718. # rtrn: Apache::SERVER_ERROR if $@ is set, Apache::OK otherwise
  719. #########################################################################
  720.  
  721. sub error_check {
  722.     my $self = shift;
  723.  
  724.     # ModPerl::Util::exit() throws an exception object whose rc is
  725.     # ModPerl::EXIT
  726.     # (see modperl_perl_exit() and modperl_errsv() C functions)
  727.     if ($@ && !(ref $@ eq 'APR::Error' && $@ == ModPerl::EXIT)) {
  728.         $self->log_error($@);
  729.         return Apache::SERVER_ERROR;
  730.     }
  731.     return Apache::OK;
  732. }
  733.  
  734.  
  735. #########################################################################
  736. # func: install_aliases
  737. # dflt: install_aliases
  738. # desc: install the method aliases into $class
  739. # args: $class - the class to install the methods into
  740. #       $rh_aliases - a ref to a hash with aliases mapping
  741. # rtrn: nothing
  742. #########################################################################
  743.  
  744. sub install_aliases {
  745.     my($class, $rh_aliases) = @_;
  746.  
  747.     no strict 'refs';
  748.     while (my($k,$v) = each %$rh_aliases) {
  749.         if (my $sub = *{$v}{CODE}){
  750.             *{ $class . "::$k" } = $sub;
  751.         }
  752.         else {
  753.             die "$class: $k aliasing failed; sub $v doesn't exist";
  754.         }
  755.     }
  756. }
  757.  
  758. ### helper methods
  759.  
  760. sub debug {
  761.     my $self = shift;
  762.     my $class = ref $self;
  763.     $self->{REQ}->log_error("$$: $class: " . join '', @_);
  764. }
  765.  
  766. sub log_error {
  767.     my($self, $msg) = @_;
  768.     my $class = ref $self;
  769.  
  770.     $self->{REQ}->log_error($msg);
  771.     $self->{REQ}->notes->set('error-notes' => $msg);
  772.     $@{$self->{URI}} = $msg;
  773. }
  774.  
  775. #########################################################################
  776. # func: uncache_myself
  777. # dflt: uncache_myself
  778. # desc: unmark the package as cached by forgetting its modification time
  779. # args: none
  780. # rtrn: nothing
  781. # note: this is a function and not a method, it should be called from
  782. #       the registry script, and using the caller() method we figure
  783. #       out the package the script was compiled into
  784.  
  785. #########################################################################
  786.  
  787. # this is a function should be called from the registry script, and
  788. # using the caller() method we figure out the package the script was
  789. # compiled into and trying to uncache it.
  790. #
  791. # it's currently used only for testing purposes and not a part of the
  792. # public interface. it expects to find the compiled package in the
  793. # symbol table cache returned by cache_table_common(), if you override
  794. # cache_table() to point to another function, this function will fail.
  795. sub uncache_myself {
  796.     my $package = scalar caller;
  797.     my($class) = __PACKAGE__->cache_table_common();
  798.  
  799.     unless (defined $class) {
  800.         Apache->warn("$$: cannot figure out cache symbol table for $package");
  801.         return;
  802.     }
  803.  
  804.     if (exists $class->{$package} && exists $class->{$package}{mtime}) {
  805.         Apache->warn("$$: uncaching $package\n") if DEBUG & D_COMPILE;
  806.         delete $class->{$package}{mtime};
  807.     }
  808.     else {
  809.         Apache->warn("$$: cannot find $package in cache");
  810.     }
  811. }
  812.  
  813.  
  814. # XXX: should go away when finfo() is ported to 2.0 (don't want to
  815. # depend on compat.pm)
  816. sub Apache::RequestRec::my_finfo {
  817.     my $r = shift;
  818.     stat $r->filename;
  819.     \*_;
  820. }
  821.  
  822.  
  823. 1;
  824. __END__
  825.  
  826. =head1 NAME
  827.  
  828. ModPerl::RegistryCooker - Cook mod_perl 2.0 Registry Modules
  829.  
  830. =head1 Synopsis
  831.  
  832.   # shouldn't be used as-is but sub-classed first
  833.   # see ModPerl::Registry for an example
  834.  
  835. =head1 Description
  836.  
  837. C<ModPerl::RegistryCooker> is used to create flexible and overridable
  838. registry modules which emulate mod_cgi for Perl scripts. The concepts
  839. are discussed in the manpage of the following modules:
  840. C<L<ModPerl::Registry>>, C<L<ModPerl::Registry>> and
  841. C<L<ModPerl::RegistryBB>>.
  842.  
  843. C<ModPerl::RegistryCooker> has two purposes:
  844.  
  845. =over
  846.  
  847. =item *
  848.  
  849. Provide ingredients that can be used by registry sub-classes
  850.  
  851. =item *
  852.  
  853. Provide a default behavior, which can be overriden in sub-classed
  854.  
  855. META: in the future this functionality may move into a separate class.
  856.  
  857. =back
  858.  
  859. Here are the current overridable methods:
  860.  
  861. META: these are all documented in RegistryCooker.pm, though not using
  862. pod. please help to port these to pod and move the descriptions here.
  863.  
  864. =over
  865.  
  866. =item * new()
  867.  
  868. create the class's object, bless it and return it
  869.  
  870.   my $obj = $class->new($r);
  871.  
  872. C<$class> -- the registry class, usually C<__PACKAGE__> can be used.
  873.  
  874. C<$r> -- C<L<Apache::Request>> object.
  875.  
  876. default: new()
  877.  
  878. =item * init()
  879.  
  880. initializes the data object's fields: C<REQ>, C<FILENAME>,
  881. C<URI>. Called from the new().
  882.  
  883. default: init()
  884.  
  885. =item * default_handler()
  886.  
  887. default:  default_handler()
  888.  
  889. =item * run()
  890.  
  891. default: run()
  892.  
  893. =item * can_compile()
  894.  
  895. default: can_compile()
  896.  
  897. =item * make_namespace()
  898.  
  899. default: make_namespace()
  900.  
  901. =item * namespace_root()
  902.  
  903. default: namespace_root()
  904.  
  905.  
  906. =item * namespace_from()
  907.  
  908. If C<namespace_from_uri> is used and the script is called from the
  909. virtual host, by default the virtual host name is prepended to the uri
  910. when package name for the compiled script is created. Sometimes this
  911. behavior is undesirable, e.g., when the same (physical) script is
  912. accessed using the same path_info but different virtual hosts. In that
  913. case you can make the script compiled only once for all vhosts, by
  914. specifying:
  915.  
  916.   $ModPerl::RegistryCooker::NameWithVirtualHost = 0;
  917.  
  918. The drawback is that it affects the global environment and all other
  919. scripts will be compiled ignoring virtual hosts.
  920.  
  921. default: namespace_from()
  922.  
  923. =item * is_cached()
  924.  
  925. default: is_cached()
  926.  
  927. =item * should_compile()
  928.  
  929. default: should_compile()
  930.  
  931. =item * flush_namespace()
  932.  
  933. default: flush_namespace()
  934.  
  935.  
  936. =item * cache_table()
  937.  
  938. default: cache_table()
  939.  
  940. =item * cache_it()
  941.  
  942. default: cache_it()
  943.  
  944. =item * read_script()
  945.  
  946. default: read_script()
  947.  
  948. =item * rewrite_shebang()
  949.  
  950. default: rewrite_shebang()
  951.  
  952. =item * get_script_name()
  953.  
  954. default: get_script_name()
  955.  
  956. =item * chdir_file()
  957.  
  958. default: chdir_file()
  959.  
  960. =item * get_mark_line()
  961.  
  962. default: get_mark_line()
  963.  
  964. =item * compile()
  965.  
  966. default: compile()
  967.  
  968.  
  969. =item * error_check()
  970.  
  971. default: error_check()
  972.  
  973. =item * strip_end_data_segment()
  974.  
  975. default: strip_end_data_segment()
  976.  
  977. =item * convert_script_to_compiled_handler()
  978.  
  979. default: convert_script_to_compiled_handler()
  980.  
  981. =back
  982.  
  983.  
  984.  
  985.  
  986. =head2 Special Predefined Functions
  987.  
  988. The following functions are implemented as constants.
  989.  
  990. =over
  991.  
  992. =item * NOP()
  993.  
  994. Use when the function shouldn't do anything.
  995.  
  996. =item * TRUE()
  997.  
  998. Use when a function should always return a true value.
  999.  
  1000. =item * FALSE()
  1001.  
  1002. Use when a function should always return a false value.
  1003.  
  1004. =back
  1005.  
  1006.  
  1007.  
  1008.  
  1009. =head1 Sub-classing Techniques
  1010.  
  1011. To override the default C<ModPerl::RegistryCooker> methods, first,
  1012. sub-class C<ModPerl::RegistryCooker> or one of its existing
  1013. sub-classes, using C<use base>. Second, override the methods.
  1014.  
  1015. Those methods that weren't overridden will be resolved at run time
  1016. when used for the first time and cached for the future requests. One
  1017. way to to shortcut this first run resolution is to use the symbol
  1018. aliasing feature. For example to alias C<ModPerl::MyRegistry::flush_namespace>
  1019. as C<ModPerl::RegistryCooker::flush_namespace>, you can do:
  1020.  
  1021.   package ModPerl::MyRegistry;
  1022.   use base qw(ModPerl::RegistryCooker);
  1023.   *ModPerl::MyRegistry::flush_namespace =
  1024.       \&ModPerl::RegistryCooker::flush_namespace;
  1025.   1;
  1026.  
  1027. In fact, it's a good idea to explicitly alias all the methods so you
  1028. know exactly what functions are used, rather then relying on the
  1029. defaults. For that purpose C<ModPerl::RegistryCooker> class method
  1030. install_aliases() can be used. Simply prepare a hash with method names
  1031. in the current package as keys and corresponding fully qualified
  1032. methods to be aliased for as values and pass it to
  1033. install_aliases(). Continuing our example we could do:
  1034.  
  1035.   package ModPerl::MyRegistry;
  1036.   use base qw(ModPerl::RegistryCooker);
  1037.   my %aliases = (
  1038.       flush_namespace => 'ModPerl::RegistryCooker::flush_namespace',
  1039.   );
  1040.   __PACKAGE__->install_aliases(\%aliases);
  1041.   1;
  1042.  
  1043. The values use fully qualified packages so you can mix methods from
  1044. different classes.
  1045.  
  1046. =head1 Examples
  1047.  
  1048. The best examples are existing core registry modules:
  1049. C<L<ModPerl::Registry>>, C<L<ModPerl::Registry>> and
  1050. C<L<ModPerl::RegistryBB>>. Look at the source code and their manpages
  1051. to see how they subclass C<ModPerl::RegistryCooker>.
  1052.  
  1053. For example by default C<L<ModPerl::Registry>> uses the script's path
  1054. when creating a package's namespace. If for example you want to use a
  1055. uri instead you can override it with:
  1056.  
  1057.   *ModPerl::MyRegistry::namespace_from =
  1058.       \&ModPerl::RegistryCooker::namespace_from_uri;
  1059.   1;
  1060.  
  1061. Since the C<namespace_from_uri> component already exists in
  1062. C<ModPerl::RegistryCooker>. If you want to write your own method,
  1063. e.g., that creates a namespace based on the inode, you can do:
  1064.  
  1065.   sub namespace_from_inode {
  1066.       my $self = shift;
  1067.       return (stat $self->[FILENAME])[1];
  1068.   }
  1069.  
  1070. META: when $r-E<gt>finfo will be ported it'll be more effecient. 
  1071. (stat $r-E<gt>finfo)[1]
  1072.  
  1073.  
  1074. =head1 Authors
  1075.  
  1076. Doug MacEachern
  1077.  
  1078. Stas Bekman
  1079.  
  1080. =head1 See Also
  1081.  
  1082. C<L<ModPerl::Registry|docs::2.0::api::ModPerl::Registry>>,
  1083. C<L<ModPerl::RegistryBB|docs::2.0::api::ModPerl::RegistryBB>> and
  1084. C<L<ModPerl::PerlRun|docs::2.0::api::ModPerl::PerlRun>>.
  1085.  
  1086. =cut
  1087.