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 / Error.pm < prev    next >
Encoding:
Perl POD Document  |  2003-01-09  |  7.3 KB  |  266 lines
  1.  
  2. package Apache::ASP;
  3.  
  4. sub ProcessErrors {
  5.     my $self = shift;
  6.     my $r = $self->{r};
  7.     my $status;
  8.  
  9.     # just to make sure we have everything we need for the errors templates
  10.     $self->InitPackageGlobals;
  11.     
  12.     if($self->{dbg} >= 2) {
  13.     $self->PrettyError();
  14.     $status = 200;
  15.     } else {
  16.     if($self->Response->{header_done}) {
  17.         $self->{r}->print("<!-- Error -->");
  18.     }
  19.     
  20.     # debug of 2+ and mail_errors_to are mutually exclusive,
  21.     # since debugging 2+ is for development, and you don't need to 
  22.     # be emailed the error, if its right in your browser
  23.     $self->{mail_alert_to}  = &config($self,'MailAlertTo') || 0;
  24.     $self->{mail_errors_to} = &config($self,'MailErrorsTo') || 0;
  25.     $self->{mail_errors_to} && $self->MailErrors();
  26.     $self->{mail_alert_to} && $self->MailAlert();
  27.     
  28.     $status = 500;
  29.     }
  30. }
  31.  
  32. sub PrettyError {
  33.     my($self) = @_;
  34.     my $response = $self->{Response};
  35.  
  36.     my $out = $response->{out};
  37.     $response->{ContentType} = 'text/html';
  38.     $$out = $self->PrettyErrorHelper();
  39.     $response->Flush();
  40.  
  41.     1;
  42. }
  43.  
  44. sub PrettyErrorHelper {
  45.     my $self = shift;
  46.  
  47.     my $response_buffer = $self->{Response}{out};
  48.     $self->{Response}->Clear();
  49.     my $errors_out = '';
  50.     my @eval_error_lines = ();
  51.     if($self->{errors_output}[0]) {
  52.     my($url, $file);
  53.     $errors_out = join("\n<li> ", '', map { $self->Escape($_) } @{$self->{errors_output}});
  54.     # link in the line number to the compiled program
  55.     $self->Debug("errors out $errors_out");
  56.     if($errors_out =~
  57.        s|\s+at\s+(.*?)\s+line\s+(\d+)|
  58.        {
  59.         my($file, $line_no) = ($1, $2);
  60.             if($file =~ /\)/) {
  61.               " at $file line $line_no";
  62.             } else {
  63.           $url = $self->{Server}->URLEncode($file.' '.$line_no);
  64.           " at $file <a href=#$url>line $line_no</a>";
  65.             }
  66.        }
  67.        |exs
  68.       )
  69.       {
  70.           push(@eval_error_lines, $url);          
  71.       }
  72.     }
  73.  
  74.     my $out = <<OUT;
  75. <tt>
  76. <b><u>Errors Output</u></b>
  77. <ol>
  78. $errors_out
  79. </ol>
  80.  
  81. <b><u>Debug Output</u></b>
  82. <ol>
  83. @{[join("\n<li> ", '', map { $_ } @{$self->{debugs_output}}) ]}
  84. </ol>
  85. </tt>
  86. <pre>
  87. OUT
  88.     ;
  89.  
  90.     # could be looking at a compilation error, then set the script to what
  91.     # we were compiling (maybe global.asa), else its our real script
  92.     # with probably a runtime error
  93.     my $script;     
  94.     if($self->{compile_error}) {    
  95.     $script = ${$self->{compile_eval}};
  96.     }
  97.     
  98.     if($$response_buffer) {
  99.     my $length = &config($self, 'DebugBufferLength') || 100;
  100.     $out .= "<b><u>Last $length Bytes of Buffered Output</u></b>\n\n";
  101.     $out .= $self->Escape(substr($$response_buffer, -1 * $length));
  102.     $out .= "\n\n";
  103.     }
  104.  
  105.     my $error_desc;
  106.     if($script) {
  107.     $error_desc = "Compiled Data with Error";
  108.     } else {
  109.     $error_desc = "ASP to Perl Script";
  110.     my $run_perl_script = $self->{run_perl_script};
  111.     $script = $run_perl_script ? $$run_perl_script : '';
  112.     }
  113.     $out .= "<b><u>$error_desc</u></b><a name=1> </a>\n\n";
  114.  
  115.     my($file_context, $lineno) = ('', 0);
  116.     for(split(/\n/, $script)) {
  117.     my($lineprint, $lineurl,$frag);
  118.     if ($_ =~ /^#\s*line (\d+) (.+)$/){
  119.         $lineno = $1;
  120.         $file_context = $2;
  121.         $lineurl = '  -';
  122.     } elsif (($lineno == 0)) {
  123.         $lineurl = '  -';
  124.     } else {
  125.         $frag = $self->{Server}->URLEncode($file_context.' '.$lineno);
  126.         $lineurl = "<a name=$frag>".sprintf('%3d', $lineno)."</a>";
  127.         $lineno++;
  128.     }
  129.     $frag ||= '';
  130.     grep($frag eq $_, @eval_error_lines) && 
  131.       ($lineurl = "<b><font color=red>$lineurl</font></b>");
  132.     unless(&config($self, 'CommandLine')) {
  133.         $_ = $self->Escape($_);
  134.     }
  135.  
  136.     $out .= "$lineurl: $_\n";
  137.     }
  138.  
  139.     $out .= <<OUT;
  140.  
  141. </pre>
  142. <hr width=30% size=1>\n<font size=-1>
  143. <i> 
  144. An error has occured with the Apache::ASP script just run. 
  145. If you are the developer working on this script, and cannot work 
  146. through this problem, please try researching it at the 
  147. <a href=http://www.apache-asp.org/>Apache::ASP web site</a>,
  148. specifically the <a href=http://www.apache-asp.org/faq.html>FAQ section</a>.
  149. Failing that, check out your 
  150. <a href=http://www.apache-asp.org/support.html>support options</a>, and 
  151. if necessary include this debug output with any query. 
  152.  
  153. OUT
  154.   ;
  155.  
  156.     $out;
  157. }
  158.  
  159. sub MailErrors {
  160.     my $self = shift;
  161.     
  162.     # email during register cleanup so the user doesn't have 
  163.     # to wait, and possible cancel the mail by pressing "STOP"
  164.     $self->Log("registering error mail to $self->{mail_errors_to} for cleanup phase");
  165.     my $body_ref;
  166.     eval {
  167.     # there was a "use strict" + warn error while compiling this template
  168.     local $^W = 0;
  169.     $body_ref = $self->Response->TrapInclude('Share::CORE/MailErrors.inc', 
  170.                          COMPILE_ERROR => $self->PrettyErrorHelper
  171.                         );
  172.     };
  173.     if($@) {
  174.     $self->Error("error creating error mail in MailErrors(): $@");
  175.     return;
  176.     }
  177.  
  178.     my($subject,$body);
  179.     if($$body_ref =~ /^\s+Subject:\s*(.*?)\s*\n\s*(.*)$/is) {
  180.     ($subject,$body) = ($1,$2);
  181.     } else {
  182.     ($subject,$body) = ('Apache::ASP::Error', $$body_ref);
  183.     }
  184.  
  185.     $self->{Server}->RegisterCleanup
  186.       ( 
  187.        sub { 
  188.        for(1..3) {
  189.            my $success = 
  190.          $self->SendMail
  191.            ({
  192.              To => $self->{mail_errors_to},
  193.              From => &config($self, 'MailFrom') || $self->{mail_errors_to},
  194.              Subject => $subject,
  195.              Body => $body,
  196.              'Content-Type' => 'text/html',
  197.             });
  198.            if($success) {
  199.            last;
  200.            } else {
  201.            $self->Error("can't send errors mail to $self->{mail_errors_to}");
  202.            }
  203.        }
  204.        });
  205. }    
  206.  
  207. sub MailAlert {
  208.     my $self = shift;
  209.  
  210.     unless($self->{mail_alert_period}) {
  211.     $self->{mail_alert_period} = &config($self, 'MailAlertPeriod', undef, 20);
  212.     }
  213.     
  214.     # if we have the internal database defined, check last time the alert was
  215.     # sent, and if the alert period is up, send again
  216.     if(defined $self->{Internal}) {
  217.     my $time = time;
  218.     if(defined $self->{Internal}{mail_alert_time}) {
  219.         my $alert_in = $self->{Internal}{mail_alert_time} + $self->{mail_alert_period} * 60 - $time;
  220.         if($alert_in <= 0) {
  221.         $self->{Internal}{mail_alert_time} = $time;
  222.         } else {
  223.         # not time to send an alert again
  224.         $self->Debug("will alert again in $alert_in seconds");
  225.         return 1;
  226.         }
  227.     } else {
  228.         $self->{Internal}{mail_alert_time} = $time;
  229.     }
  230.     } else {
  231.     $self->Log("mail alerts will be sent every time.  turn NoState off so that ".
  232.            "alerts can be sent only every $self->{mail_alert_period} minutes");
  233.     }
  234.  
  235.     my $host = '';
  236.     if($self->LoadModules('MailAlert', 'Net::Domain')) {
  237.     $host = Net::Domain::hostname();    
  238.     }
  239.     
  240.     # email during register cleanup so the user doesn't have 
  241.     # to wait, and possible cancel the mail by pressing "STOP"
  242.     $self->Log("registering alert mail to $self->{mail_alert_to} for cleanup phase");
  243.  
  244.     $self->{Server}->RegisterCleanup
  245.       ( 
  246.        sub { 
  247.        for(1..3) {
  248.            my $success = 
  249.          $self->SendMail({
  250.                   To => $self->{mail_alert_to},
  251.                   From => &config($self, 'MailFrom', undef, $self->{mail_alert_to}),
  252.                   Subject => join('-', 'ASP-ALERT', $host), 
  253.                   Body => "$self->{global}-$ENV{SCRIPT_NAME}",                 
  254.                  });
  255.            
  256.            if($success) {
  257.            last;
  258.            } else {
  259.            $self->Error("can't send alert mail to $self->{mail_alert_to}");
  260.            }
  261.        }
  262.        });
  263. }
  264.  
  265. 1;
  266.