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 / RegistryCooker.pm < prev    next >
Encoding:
Perl POD Document  |  2004-01-24  |  23.7 KB  |  786 lines
  1. # VERY IMPORTANT: Be very careful modifying the defaults, since many
  2. # VERY IMPORTANT: packages rely on them. In fact you should never
  3. # VERY IMPORTANT: modify the defaults after the package gets released,
  4. # VERY IMPORTANT: since they are a hardcoded part of this suite's API.
  5.  
  6. package ModPerl::RegistryCooker;
  7.  
  8. require 5.006;
  9.  
  10. use strict;
  11. use warnings FATAL => 'all';
  12.  
  13. our $VERSION = '1.99';
  14.  
  15. use Apache::Response ();
  16. use Apache::RequestRec ();
  17. use Apache::RequestUtil ();
  18. use Apache::RequestIO ();
  19. use Apache::Log ();
  20. use Apache::Access ();
  21.  
  22. use APR::Table ();
  23.  
  24. use ModPerl::Util ();
  25. use ModPerl::Global ();
  26.  
  27. use File::Spec::Functions ();
  28. use File::Basename;
  29.  
  30. use Apache::Const -compile => qw(:common &OPT_EXECCGI);
  31.  
  32. unless (defined $ModPerl::Registry::MarkLine) {
  33.     $ModPerl::Registry::MarkLine = 1;
  34. }
  35.  
  36. #########################################################################
  37. # debug constants
  38. #
  39. #########################################################################
  40. use constant D_NONE    => 0;
  41. use constant D_ERROR   => 1;
  42. use constant D_WARN    => 2;
  43. use constant D_COMPILE => 4;
  44. use constant D_NOISE   => 8;
  45.  
  46. # the debug level can be overriden on the main server level of
  47. # httpd.conf with:
  48. #   PerlSetVar ModPerl::RegistryCooker::DEBUG 4
  49. use Apache::ServerUtil ();
  50. use constant DEBUG => 0;
  51. #XXX: below currently crashes the server on win32
  52. #    defined Apache->server->dir_config('ModPerl::RegistryCooker::DEBUG')
  53. #        ? Apache->server->dir_config('ModPerl::RegistryCooker::DEBUG')
  54. #        : D_NONE;
  55.  
  56. #########################################################################
  57. # OS specific constants
  58. #
  59. #########################################################################
  60. use constant IS_WIN32 => $^O eq "MSWin32";
  61.  
  62. #########################################################################
  63. # constant subs
  64. #
  65. #########################################################################
  66. use constant NOP   => '';
  67. use constant TRUE  => 1;
  68. use constant FALSE => 0;
  69.  
  70.  
  71. use constant NAMESPACE_ROOT => 'ModPerl::ROOT';
  72.  
  73.  
  74. #########################################################################
  75.  
  76. unless (defined $ModPerl::RegistryCooker::NameWithVirtualHost) {
  77.     $ModPerl::RegistryCooker::NameWithVirtualHost = 1;
  78. }
  79.  
  80. #########################################################################
  81. # func: new
  82. # dflt: new
  83. # args: $class - class to bless into
  84. #       $r     - Apache::Request object
  85. # desc: create the class's object and bless it
  86. # rtrn: the newly created object
  87. #########################################################################
  88.  
  89. sub new {
  90.     my($class, $r) = @_;
  91.     my $self = bless {}, $class;
  92.     $self->init($r);
  93.     return $self;
  94. }
  95.  
  96. #########################################################################
  97. # func: init
  98. # dflt: init
  99. # desc: initializes the data object's fields: REQ FILENAME URI
  100. # args: $r - Apache::Request object
  101. # rtrn: nothing
  102. #########################################################################
  103.  
  104. sub init {
  105.     $_[0]->{REQ}      = $_[1];
  106.     $_[0]->{URI}      = $_[1]->uri;
  107.     $_[0]->{FILENAME} = $_[1]->filename;
  108. }
  109.  
  110. #########################################################################
  111. # func: handler
  112. # dflt: handler
  113. # desc: the handler() sub that is expected by Apache
  114. # args: $class - handler's class
  115. #       $r     - Apache::Request object
  116. #       (o)can be called as handler($r) as well (without leading $class)
  117. # rtrn: handler's response status
  118. # note: must be implemented in a sub-class unless configured as
  119. #       Apache::Foo->handler in httpd.conf (because of the
  120. #       __PACKAGE__, which is tied to the file)
  121. #########################################################################
  122.  
  123. sub handler : method {
  124.     my $class = (@_ >= 2) ? shift : __PACKAGE__;
  125.     my $r = shift;
  126.     return $class->new($r)->default_handler();
  127. }
  128.  
  129. #########################################################################
  130. # func: default_handler
  131. # dflt: META: see above
  132. # desc: META: see above
  133. # args: $self - registry blessed object
  134. # rtrn: handler's response status
  135. # note: that's what most sub-class handlers will call
  136. #########################################################################
  137.  
  138. sub default_handler {
  139.     my $self = shift;
  140.  
  141.     $self->make_namespace;
  142.  
  143.     if ($self->should_compile) {
  144.         my $rc = $self->can_compile;
  145.         return $rc unless $rc == Apache::OK;
  146.         $rc = $self->convert_script_to_compiled_handler;
  147.         return $rc unless $rc == Apache::OK;
  148.     }
  149.  
  150.     # handlers shouldn't set $r->status but return it, so we reset the
  151.     # status after running it
  152.     my $old_status = $self->{REQ}->status;
  153.     my $rc = $self->run;
  154.     my $new_status = $self->{REQ}->status($old_status);
  155.     return ($rc == Apache::OK && $old_status != $new_status)
  156.         ? $new_status
  157.         : $rc;
  158. }
  159.  
  160. #########################################################################
  161. # func: run
  162. # dflt: run
  163. # desc: executes the compiled code
  164. # args: $self - registry blessed object
  165. # rtrn: execution status (Apache::?)
  166. #########################################################################
  167.  
  168. sub run {
  169.     my $self = shift;
  170.  
  171.     my $r       = $self->{REQ};
  172.     my $package = $self->{PACKAGE};
  173.  
  174.     $self->chdir_file;
  175.  
  176.     my $cv = \&{"$package\::handler"};
  177.  
  178.     my %orig_inc;
  179.     if ($self->should_reset_inc_hash) {
  180.         %orig_inc = %INC;
  181.     }
  182.  
  183.     { # run the code and preserve warnings setup when it's done
  184.         no warnings;
  185.         eval { $cv->($r, @_) };
  186.         ModPerl::Global::special_list_call(END => $package);
  187.     }
  188.  
  189.     if ($self->should_reset_inc_hash) {
  190.         # to avoid the bite of require'ing a file with no package delaration
  191.         # Apache::PerlRun in mod_perl 1.15_01 started to localize %INC
  192.         # later on it has been adjusted to preserve loaded .pm files,
  193.         # which presumably contained the package declaration
  194.         for (keys %INC) {
  195.             next if $orig_inc{$_};
  196.             next if /\.pm$/;
  197.             delete $INC{$_};
  198.         }
  199.     }
  200.  
  201.     $self->flush_namespace;
  202.  
  203.     #XXX: $self->chdir_file("$Apache::Server::CWD/");
  204.  
  205.     if ( (my $err_rc = $self->error_check) != Apache::OK) {
  206.         return $err_rc;
  207.     }
  208.  
  209.     return Apache::OK;
  210. }
  211.  
  212.  
  213.  
  214. #########################################################################
  215. # func: can_compile
  216. # dflt: can_compile
  217. # desc: checks whether the script is allowed and can be compiled
  218. # args: $self - registry blessed object
  219. # rtrn: $rc - return status to forward
  220. # efct: initializes the data object's fields: MTIME
  221. #########################################################################
  222.  
  223. sub can_compile {
  224.     my $self = shift;
  225.     my $r = $self->{REQ};
  226.  
  227.     unless (-r $r->my_finfo && -s _) {
  228.         $self->log_error("$self->{FILENAME} not found or unable to stat");
  229.         return Apache::NOT_FOUND;
  230.     }
  231.  
  232.     return Apache::DECLINED if -d _;
  233.  
  234.     $self->{MTIME} = -M _;
  235.  
  236.     unless (-x _ or IS_WIN32) {
  237.         $r->log_error("file permissions deny server execution",
  238.                        $self->{FILENAME});
  239.         return Apache::FORBIDDEN;
  240.     }
  241.  
  242.     if (!($r->allow_options & Apache::OPT_EXECCGI)) {
  243.         $r->log_error("Options ExecCGI is off in this directory",
  244.                        $self->{FILENAME});
  245.         return Apache::FORBIDDEN;
  246.     }
  247.  
  248.     $self->debug("can compile $self->{FILENAME}") if DEBUG & D_NOISE;
  249.  
  250.     return Apache::OK;
  251.  
  252. }
  253. #########################################################################
  254. # func: namespace_root
  255. # dflt: namespace_root
  256. # desc: define the namespace root for storing compiled scripts
  257. # args: $self - registry blessed object
  258. # rtrn: the namespace root
  259. #########################################################################
  260.  
  261. sub namespace_root {
  262.     my $self = shift;
  263.     join '::', NAMESPACE_ROOT, ref($self);
  264. }
  265.  
  266. #########################################################################
  267. # func: make_namespace
  268. # dflt: make_namespace
  269. # desc: prepares the namespace
  270. # args: $self - registry blessed object
  271. # rtrn: the namespace
  272. # efct: initializes the field: PACKAGE
  273. #########################################################################
  274.  
  275. sub make_namespace {
  276.     my $self = shift;
  277.  
  278.     my $package = $self->namespace_from;
  279.  
  280.     # Escape everything into valid perl identifiers
  281.     $package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
  282.  
  283.     # make sure that the sub-package doesn't start with a digit
  284.     $package =~ s/^(\d)/_$1/;
  285.  
  286.     # prepend root
  287.     $package = $self->namespace_root() . "::$package";
  288.  
  289.     $self->{PACKAGE} = $package;
  290.  
  291.     return $package;
  292. }
  293.  
  294. #########################################################################
  295. # func: namespace_from
  296. # dflt: namespace_from_filename
  297. # desc: returns a partial raw package name based on filename, uri, else
  298. # args: $self - registry blessed object
  299. # rtrn: a unique string
  300. #########################################################################
  301.  
  302. *namespace_from = \&namespace_from_filename;
  303.  
  304. # return a package name based on $r->filename only
  305. sub namespace_from_filename {
  306.     my $self = shift;
  307.  
  308.     my ($volume, $dirs, $file) = 
  309.         File::Spec::Functions::splitpath($self->{FILENAME});
  310.     my @dirs = File::Spec::Functions::splitdir($dirs);
  311.     return join '_', grep { defined && length } $volume, @dirs, $file;
  312. }
  313.  
  314. # return a package name based on $r->uri only
  315. sub namespace_from_uri {
  316.     my $self = shift;
  317.  
  318.     my $path_info = $self->{REQ}->path_info;
  319.     my $script_name = $path_info && $self->{URI} =~ /$path_info$/
  320.         ? substr($self->{URI}, 0, length($self->{URI}) - length($path_info))
  321.         : $self->{URI};
  322.  
  323.     if ($ModPerl::RegistryCooker::NameWithVirtualHost && 
  324.         $self->{REQ}->server->is_virtual) {
  325.         my $name = $self->{REQ}->get_server_name;
  326.         $script_name = join "", $name, $script_name if $name;
  327.     }
  328.  
  329.     $script_name =~ s:/+$:/__INDEX__:;
  330.  
  331.     return $script_name;
  332. }
  333.  
  334. #########################################################################
  335. # func: convert_script_to_compiled_handler
  336. # dflt: convert_script_to_compiled_handler
  337. # desc: reads the script, converts into a handler and compiles it
  338. # args: $self - registry blessed object
  339. # rtrn: success/failure status
  340. #########################################################################
  341.  
  342. sub convert_script_to_compiled_handler {
  343.     my $self = shift;
  344.  
  345.     $self->debug("Adding package $self->{PACKAGE}") if DEBUG & D_NOISE;
  346.  
  347.     # get the script's source
  348.     $self->read_script;
  349.  
  350.     # convert the shebang line opts into perl code
  351.     $self->rewrite_shebang;
  352.  
  353.     # mod_cgi compat, should compile the code while in its dir, so
  354.     # relative require/open will work.
  355.     $self->chdir_file;
  356.  
  357. #    undef &{"$self->{PACKAGE}\::handler"}; unless DEBUG & D_NOISE; #avoid warnings
  358. #    $self->{PACKAGE}->can('undef_functions') && $self->{PACKAGE}->undef_functions;
  359.  
  360.     my $line = $self->get_mark_line;
  361.  
  362.     $self->strip_end_data_segment;
  363.  
  364.     # handle the non-parsed handlers ala mod_cgi (though mod_cgi does
  365.     # some tricks removing the header_out and other filters, here we
  366.     # just call assbackwards which has the same effect).
  367.     my $base = File::Basename::basename($self->{FILENAME});
  368.     my $nph = substr($base, 0, 4) eq 'nph-' ? '$_[0]->assbackwards(1);' : "";
  369.     my $script_name = $self->get_script_name || $0;
  370.  
  371.     my $eval = join '',
  372.                     'package ',
  373.                     $self->{PACKAGE}, ";",
  374.                     "sub handler {",
  375.                     "local \$0 = '$script_name';",
  376.                     $nph,
  377.                     $line,
  378.                     ${ $self->{CODE} },
  379.                     "\n}"; # last line comment without newline?
  380.  
  381.     my $rc = $self->compile(\$eval);
  382.     return $rc unless $rc == Apache::OK;
  383.     $self->debug(qq{compiled package \"$self->{PACKAGE}\"}) if DEBUG & D_NOISE;
  384.  
  385.     #$self->chdir_file("$Apache::Server::CWD/");
  386.  
  387. #    if(my $opt = $r->dir_config("PerlRunOnce")) {
  388. #        $r->child_terminate if lc($opt) eq "on";
  389. #    }
  390.  
  391.     $self->cache_it;
  392.  
  393.     return $rc;
  394. }
  395.  
  396. #########################################################################
  397. # func: cache_table
  398. # dflt: cache_table_common
  399. # desc: return a symbol table for caching compiled scripts in
  400. # args: $self - registry blessed object (or the class name)
  401. # rtrn: symbol table
  402. #########################################################################
  403.  
  404. *cache_table = \&cache_table_common;
  405.  
  406. sub cache_table_common {
  407.     \%ModPerl::RegistryCache;
  408. }
  409.  
  410.  
  411. sub cache_table_local {
  412.     my $self = shift;
  413.     my $class = ref($self) || $self;
  414.     no strict 'refs';
  415.     \%$class;
  416. }
  417.  
  418. #########################################################################
  419. # func: cache_it
  420. # dflt: cache_it
  421. # desc: mark the package as cached by storing its modification time
  422. # args: $self - registry blessed object
  423. # rtrn: nothing
  424. #########################################################################
  425.  
  426. sub cache_it {
  427.     my $self = shift;
  428.     $self->cache_table->{ $self->{PACKAGE} }{mtime} = $self->{MTIME};
  429. }
  430.  
  431.  
  432. #########################################################################
  433. # func: is_cached
  434. # dflt: is_cached
  435. # desc: checks whether the package is already cached
  436. # args: $self - registry blessed object
  437. # rtrn: TRUE if cached,
  438. #       FALSE otherwise
  439. #########################################################################
  440.  
  441. sub is_cached {
  442.     my $self = shift;
  443.     exists $self->cache_table->{ $self->{PACKAGE} }{mtime};
  444. }
  445.  
  446.  
  447. #########################################################################
  448. # func: should_compile
  449. # dflt: should_compile_once
  450. # desc: decide whether code should be compiled or not
  451. # args: $self - registry blessed object
  452. # rtrn: TRUE if should compile
  453. #       FALSE otherwise
  454. # efct: sets MTIME if it's not set yet
  455. #########################################################################
  456.  
  457. *should_compile = \&should_compile_once;
  458.  
  459. # return false only if the package is cached and its source file
  460. # wasn't modified
  461. sub should_compile_if_modified {
  462.     my $self = shift;
  463.     $self->{MTIME} ||= -M $self->{REQ}->my_finfo;
  464.     !($self->is_cached && 
  465.       $self->cache_table->{ $self->{PACKAGE} }{mtime} <= $self->{MTIME});
  466. }
  467.  
  468. # return false if the package is cached already
  469. sub should_compile_once {
  470.     not shift->is_cached;
  471. }
  472.  
  473. #########################################################################
  474. # func: should_reset_inc_hash
  475. # dflt: FALSE
  476. # desc: decide whether to localize %INC for required .pl files from the script
  477. # args: $self - registry blessed object
  478. # rtrn: TRUE if should reset
  479. #       FALSE otherwise
  480. #########################################################################
  481.  
  482. *should_reset_inc_hash = \&FALSE;
  483.  
  484. #########################################################################
  485. # func: flush_namespace
  486. # dflt: NOP (don't flush)
  487. # desc: flush the compiled package's namespace
  488. # args: $self - registry blessed object
  489. # rtrn: nothing
  490. #########################################################################
  491.  
  492. *flush_namespace = \&NOP;
  493.  
  494. sub flush_namespace_normal {
  495.     my $self = shift;
  496.  
  497.     $self->debug("flushing namespace") if DEBUG & D_NOISE;
  498.  
  499.     no strict 'refs';
  500.     my $tab = \%{ $self->{PACKAGE} . '::' };
  501.  
  502.     for (keys %$tab) {
  503.         my $fullname = join '::', $self->{PACKAGE}, $_;
  504.         # code/hash/array/scalar might be imported make sure the gv
  505.         # does not point elsewhere before undefing each
  506.         if (%$fullname) {
  507.             *{$fullname} = {};
  508.             undef %$fullname;
  509.         }
  510.         if (@$fullname) {
  511.             *{$fullname} = [];
  512.             undef @$fullname;
  513.         }
  514.         if ($$fullname) {
  515.             my $tmp; # argh, no such thing as an anonymous scalar
  516.             *{$fullname} = \$tmp;
  517.             undef $$fullname;
  518.         }
  519.         if (defined &$fullname) {
  520.             no warnings;
  521.             local $^W = 0;
  522.             if (defined(my $p = prototype $fullname)) {
  523.                 *{$fullname} = eval "sub ($p) {}";
  524.             }
  525.             else {
  526.                 *{$fullname} = sub {};
  527.             }
  528.             undef &$fullname;
  529.         }
  530.         if (*{$fullname}{IO}) {
  531.             if (fileno $fullname) {
  532.                 close $fullname;
  533.             }
  534.         }
  535.     }
  536. }
  537.  
  538.  
  539. #########################################################################
  540. # func: read_script
  541. # dflt: read_script
  542. # desc: reads the script in
  543. # args: $self - registry blessed object
  544. # rtrn: nothing
  545. # efct: initializes the CODE field with the source script
  546. #########################################################################
  547.  
  548. # reads the contents of the file
  549. sub read_script {
  550.     my $self = shift;
  551.  
  552.     $self->debug("reading $self->{FILENAME}") if DEBUG & D_NOISE;
  553.     $self->{CODE} = $self->{REQ}->slurp_filename(0); # untainted
  554. }
  555.  
  556. #########################################################################
  557. # func: rewrite_shebang
  558. # dflt: rewrite_shebang
  559. # desc: parse the shebang line and convert command line switches
  560. #       (defined in %switches) into a perl code.
  561. # args: $self - registry blessed object
  562. # rtrn: nothing
  563. # efct: the CODE field gets adjusted
  564. #########################################################################
  565.  
  566. my %switches = (
  567.    'T' => sub {
  568.        Apache::warn("-T switch is ignored, " .
  569.                     "enable with 'PerlSwitches -T' in httpd.conf\n")
  570.              unless ${^TAINT};
  571.        "";
  572.    },
  573.    'w' => sub { "use warnings;\n" },
  574. );
  575.  
  576. sub rewrite_shebang {
  577.     my $self = shift;
  578.     my($line) = ${ $self->{CODE} } =~ /^(.*)$/m;
  579.     my @cmdline = split /\s+/, $line;
  580.     return unless @cmdline;
  581.     return unless shift(@cmdline) =~ /^\#!/;
  582.  
  583.     my $prepend = "";
  584.     for my $s (@cmdline) {
  585.         next unless $s =~ s/^-//;
  586.         last if substr($s,0,1) eq "-";
  587.         for (split //, $s) {
  588.             next unless exists $switches{$_};
  589.             $prepend .= $switches{$_}->();
  590.         }
  591.     }
  592.     ${ $self->{CODE} } =~ s/^/$prepend/ if $prepend;
  593. }
  594.  
  595. #########################################################################
  596. # func: get_script_name
  597. # dflt: get_script_name
  598. # desc: get the script's name to set into $0
  599. # args: $self - registry blessed object
  600. # rtrn: path to the script's filename
  601. #########################################################################
  602.  
  603. sub get_script_name {
  604.     shift->{FILENAME};
  605. }
  606.  
  607. #########################################################################
  608. # func: chdir_file
  609. # dflt: NOP
  610. # desc: chdirs into $dir
  611. # args: $self - registry blessed object
  612. #       $dir - a dir 
  613. # rtrn: nothing (?or success/failure?)
  614. #########################################################################
  615.  
  616. *chdir_file = \&NOP;
  617.  
  618. sub chdir_file_normal {
  619.     my($self, $dir) = @_;
  620.     # $self->{REQ}->chdir_file($dir ? $dir : $self->{FILENAME});
  621. }
  622.  
  623. #########################################################################
  624. # func: get_mark_line
  625. # dflt: get_mark_line
  626. # desc: generates the perl compiler #line directive
  627. # args: $self - registry blessed object
  628. # rtrn: returns the perl compiler #line directive
  629. #########################################################################
  630.  
  631. sub get_mark_line {
  632.     my $self = shift;
  633.     $ModPerl::Registry::MarkLine ? "\n#line 1 $self->{FILENAME}\n" : "";
  634. }
  635.  
  636. #########################################################################
  637. # func: strip_end_data_segment
  638. # dflt: strip_end_data_segment
  639. # desc: remove the trailing non-code from $self->{CODE}
  640. # args: $self - registry blessed object
  641. # rtrn: nothing
  642. #########################################################################
  643.  
  644. sub strip_end_data_segment {
  645.     ${ +shift->{CODE} } =~ s/__(END|DATA)__(.*)//s;
  646. }
  647.  
  648.  
  649.  
  650. #########################################################################
  651. # func: compile
  652. # dflt: compile
  653. # desc: compile the code in $eval
  654. # args: $self - registry blessed object
  655. #       $eval - a ref to a scalar with the code to compile
  656. # rtrn: success/failure
  657. # note: $r must not be in scope of compile(), scripts must do
  658. #       my $r = shift; to get it off the args stack
  659. #########################################################################
  660.  
  661. sub compile {
  662.     my($self, $eval) = @_;
  663.  
  664.     $self->debug("compiling $self->{FILENAME}") if DEBUG && D_COMPILE;
  665.  
  666.     ModPerl::Global::special_list_clear(END => $self->{PACKAGE});
  667.  
  668.     {
  669.         # let the code define its own warn and strict level 
  670.         no strict;
  671.         no warnings FATAL => 'all'; # because we use FATAL 
  672.         eval $$eval;
  673.     }
  674.  
  675.     return $self->error_check;
  676. }
  677.  
  678. #########################################################################
  679. # func: error_check
  680. # dflt: error_check
  681. # desc: checks $@ for errors
  682. # args: $self - registry blessed object
  683. # rtrn: Apache::SERVER_ERROR if $@ is set, Apache::OK otherwise
  684. #########################################################################
  685.  
  686. sub error_check {
  687.     my $self = shift;
  688.     if ($@ and substr($@,0,4) ne " at ") {
  689.         $self->log_error($@);
  690.         return Apache::SERVER_ERROR;
  691.     }
  692.     return Apache::OK;
  693. }
  694.  
  695.  
  696. #########################################################################
  697. # func: install_aliases
  698. # dflt: install_aliases
  699. # desc: install the method aliases into $class
  700. # args: $class - the class to install the methods into
  701. #       $rh_aliases - a ref to a hash with aliases mapping
  702. # rtrn: nothing
  703. #########################################################################
  704.  
  705. sub install_aliases {
  706.     my($class, $rh_aliases) = @_;
  707.  
  708.     no strict 'refs';
  709.     while (my($k,$v) = each %$rh_aliases) {
  710.         if (my $sub = *{$v}{CODE}){
  711.             *{ $class . "::$k" } = $sub;
  712.         }
  713.         else {
  714.             die "$class: $k aliasing failed; sub $v doesn't exist";
  715.         }
  716.     }
  717. }
  718.  
  719. ### helper methods
  720.  
  721. sub debug {
  722.     my $self = shift;
  723.     my $class = ref $self;
  724.     $self->{REQ}->log_error("$$: $class: " . join '', @_);
  725. }
  726.  
  727. sub log_error {
  728.     my($self, $msg) = @_;
  729.     my $class = ref $self;
  730.  
  731.     $self->{REQ}->log_error("$$: $class: $msg");
  732.     $self->{REQ}->notes->set('error-notes' => $msg);
  733.     $@{$self->{URI}} = $msg;
  734. }
  735.  
  736. #########################################################################
  737. # func: uncache_myself
  738. # dflt: uncache_myself
  739. # desc: unmark the package as cached by forgetting its modification time
  740. # args: none
  741. # rtrn: nothing
  742. # note: this is a function and not a method, it should be called from
  743. #       the registry script, and using the caller() method we figure
  744. #       out the package the script was compiled into
  745.  
  746. #########################################################################
  747.  
  748. # this is a function should be called from the registry script, and
  749. # using the caller() method we figure out the package the script was
  750. # compiled into and trying to uncache it.
  751. #
  752. # it's currently used only for testing purposes and not a part of the
  753. # public interface. it expects to find the compiled package in the
  754. # symbol table cache returned by cache_table_common(), if you override
  755. # cache_table() to point to another function, this function will fail.
  756. sub uncache_myself {
  757.     my $package = scalar caller;
  758.     my($class) = __PACKAGE__->cache_table_common();
  759.  
  760.     unless (defined $class) {
  761.         Apache->warn("$$: cannot figure out cache symbol table for $package");
  762.         return;
  763.     }
  764.  
  765.     if (exists $class->{$package} && exists $class->{$package}{mtime}) {
  766.         Apache->warn("$$: uncaching $package\n") if DEBUG & D_COMPILE;
  767.         delete $class->{$package}{mtime};
  768.     }
  769.     else {
  770.         Apache->warn("$$: cannot find $package in cache");
  771.     }
  772. }
  773.  
  774.  
  775. # XXX: should go away when finfo() is ported to 2.0 (don't want to
  776. # depend on compat.pm)
  777. sub Apache::RequestRec::my_finfo {
  778.     my $r = shift;
  779.     stat $r->filename;
  780.     \*_;
  781. }
  782.  
  783.  
  784. 1;
  785. __END__
  786.