CIPP
view release on metacpan or search on metacpan
lib/CIPP/Runtime/Request.pm view on Meta::CPAN
$backtrace_html .=
qq[<td>${font}Include filename</font></td>].
qq[<td>${font}Called by</font></td>].
qq[<td>${font}At line</font></td></tr>];
my $i = @{$caller_stack}-1;
foreach my $call ( reverse @{$caller_stack} ) {
my $caller = $call->[1];
if ( $caller =~ /CIPP::Runtime/ ) {
# Include
$caller = $caller_stack->[$i-1]->[0];
} elsif ( $caller =~ /\(eval\)/ ) {
# Main CGI
$caller = $self->get_script_name;
$caller =~ s!^(.*?)/prod/cgi-bin!cgi-bin!;
} else {
$caller =~ s/^main:://;
}
$backtrace .= sprintf($backtrace_fmt,$call->[0],$caller,$call->[2]);
$backtrace_html .=
qq[<tr><td>$font$call->[0]</font></td>].
qq[<td>$font$caller</font></td>].
qq[<td>$font$call->[2]</font></td></tr>];
--$i;
}
}
# print table with exception information
my $html;
my $tmpl = <<__HTML;
<p>
<table border="1" cellpadding="4" bgcolor="white">
<tr><td colspan="4" bgcolor="#eeeeee"><b><tt>$error_text</tt></b></td></tr>
<tr><td valign="top">$font<b>Message</b></font></td><td colspan="3">$font%s</font></td></tr>
<tr><td valign="top">$font<b>Exception</b></font></td><td colspan="3">$font%s</font></td></tr>
<tr><td valign="top">$font<b>Error-File</b></font></td><td colspan="3">$font%s</font></td></tr>
<tr><td valign="top">$font<b>Object-Type</b></font></td><td colspan="3">$font%s</font></td></tr>
<tr><td valign="top">$font<b>Perl line</b></font></td><td colspan="3">$font%s</font></td></tr>
<tr><td valign="top">$font<b>CIPP line</b></font></td><td colspan="3">$font%s</font></td></tr>
<tr><td valign="top">$font<b>UEI</b></font></td><td colspan="3">$font%s</font></td></tr>
<tr><td valign="top">$font<b>Script-File</b></font></td><td colspan="3">$font%s</font></td></tr>
__HTML
$html = sprintf (
$tmpl, $message, $throw, $perl_filename,
$object_type, $perl_line_nr, $cipp_line_nr, $uei,
$self->get_script_name
);
if ( $backtrace ) {
$html .= qq[<tr><td valign="top" rowspan="].(@{$caller_stack}+1).
qq[">$font<b>Include Backtrace</b></font></td>].
$backtrace_html;
}
$html .= "</table>\n";
# Print error message to browser, if we allowed to do so
if ( $self->get_show_error and exists $ENV{QUERY_STRING} ) {
# print a HTTP header, if not yet printed
if ( not $self->get_http_header_printed ) {
print "content-type: text/html\n\n";
}
# open scripts or tables may confuse some browser,
# but we *want* our message to appear!
print "</textarea></script></table></table></table></table>".
"</table></table></table></table>\n";
# print HTML error message
print $html;
} elsif ( exists $ENV{QUERY_STRING} ) {
# print error notification to browser
print "<p><b>$error_text [UEI=$uei]</b></p>\n";
}
# generate the same information in plain text, which is later
# printed inside a HTML comment, in case of a layout disruption
# "view source" shows the exception information in a more readable form.
$tmpl = <<__HTML;
Message: %s
Exception: %s
Error-File: %s
Object-Type: %s
Perl line: %s
CIPP line: %s
UEI: %s
Server: %s
Request-URI: %s
Script-File: %s
__HTML
$cipp_line_nr =~ s/>= //;
$message =~ s/\s+$//;
my $msg = sprintf (
$tmpl, $message, $throw, $perl_filename,
$object_type, $perl_line_nr, $cipp_line_nr, $uei,
$ENV{SERVER_NAME},$ENV{REQUEST_URI},
$self->get_script_name
);
if ( $backtrace ) {
$msg .= "\nBacktrace of Include calls:\n$backtrace";
}
print "\n<!--\n\n$msg-->\n";
$msg =~ s/\s+$//;
# print message to CIPP logfile
$self->log (
type => $throw,
pre => "\n#== CIPP-EXCEPTION-LOG-START ".("=" x 51)."\n",
message => "\n".$msg,
post => "#== CIPP-EXCEPTION-LOG-END ".("=" x 53)."\n",
);
die "$throw\t$message" if $self->get_throw_runtime_error;
lib/CIPP/Runtime/Request.pm view on Meta::CPAN
++$i;
last if $perl_line_nr == $i;
}
close $fh;
}
return $cipp_line_nr;
}
sub log {
my $self = shift;
my %par = @_;
my ($type, $message, $filename, $throw, $pre, $post) =
@par{'type','message','filename','throw','pre','post'};
$throw ||= "log";
my $time = scalar (localtime);
my $program = $self->get_program_name;
my $msg = "$$\t$main::ENV{REMOTE_ADDR}\t$program\t$type\t$message";
my $log_error;
if ( $filename ne '' ) {
# a relative path is interpreted relative to project log dir
if ( $filename !~ m!^/! ) {
$filename = $self->get_project_handle->get_log_dir."/$filename";
}
} else {
$filename = $self->get_project_handle->get_log_file;
}
my $dir = dirname($filename);
mkdir ($dir, 0775) if not -d $dir;
my $fh = FileHandle->new;
if ( open ($fh, ">> $filename") ) {
if ( ! print $fh "$pre$time\t$msg\n$post" ) {
$log_error = "Can't write data to '$filename'";
}
close $fh;
chmod 0664, $filename;
} else {
$log_error = "Can't open file '$filename' for writing.";
}
croak "$throw\t$log_error" if $log_error;
1;
}
sub init_error {
my $self = shift;
my %par = @_;
my ($message) = @par{'message'};
if ( not $self->get_http_header_printed ) {
print "content-type: text/html\n\n";
}
print "Initialization Error\n";
$self->exit;
1;
}
sub exit {
my $self = shift;
die "_cipp_exit_command";
}
sub html_quote {
shift;
my ($text) = @_;
$text =~ s/&/&/g;
$text =~ s/</</g;
$text =~ s/>/>/g;
$text =~ s/\"/"/g;
return $text;
}
sub html_field_quote {
shift;
my ($text) = @_;
$text =~ s/&/&/g;
$text =~ s/\"/"/g;
return $text;
}
sub url_encode {
shift;
my ($text) = @_;
$text =~ s/(\W)/(ord($1)>15)?(sprintf("%%%x",ord($1))):("%0".sprintf("%lx",ord($1)))/eg;
return $text;
}
sub fetch_upload {
my $self = shift;
my %par = @_;
my ($filename, $fh, $throw) =
@par{'filename','fh','throw'};
$throw ||= "fetchupload";
my $source_fh = $fh;
croak "$throw\tForm file upload variable is missing."
if not defined $source_fh;
my $target_fh = FileHandle->new;
open ($target_fh, "> $filename")
or croak "$throw\tCan't open '$filename' for writing: $!";
lib/CIPP/Runtime/Request.pm view on Meta::CPAN
return 1 if not $force and $time < $data->{filter};
my $levels = "+" x (@{$self->get_caller_stack}+1);
$detail =~ s/\s+/ /g;
$detail = "$levels $detail";
$detail = substr($detail.(" "x 60),0,60);
$detail =~ s/(\s+)$/" ".("." x (length($1)-1))/e if $time;
$time = $self->get_profile_time ( time => $time, profile => $data );
my $fh = $data->{fh};
printf $fh "PROFILE %5d %-10s %-10s %-60s %s\n",
$$, $data->{name}, $command, $detail, $time;
1;
}
sub get_profile_time {
my $self = shift;
my %par = @_;
my ($time, $profile) = @par{'time','profile'};
return "" if $time == 0;
my $formatted = sprintf ("%2.4f ", $time);
$formatted .= "o" x int($time / $profile->{scale_unit});
return $formatted;
}
sub eval_perl_code {
# do the eval in this mini subroutine, so NO lexicals
# are in the scope of it.
# checking of $@ has to be done by the caller
eval ${$_[0]};
}
sub print_http_header {
my $self = shift;
my %par = @_;
my ($custom_http_header_file) = @par{'custom_http_header_file'};
# evtl. execute custom http header subroutine
$self->call_include_subroutine (
file => $custom_http_header_file,
input => {},
output => {},
) if $custom_http_header_file;
# print HTTP Header
my ($k, $v);
my $content_type;
while ( ($k, $v) = each %{$self->get_http_header} ) {
# $k =~ s/\b([a-z])/uc($1)/eg;
print "$k: $v\n";
$content_type = $v if $k =~ /^content-type$/i;
}
print "\n";
$self->set_http_header_printed (1);
if ( $content_type =~ m!text/html! && !$self->get_xhtml ) {
my $runtime = $self->get_project_handle->get_cipp_runtime_version;
my $compiler = $self->get_project_handle->get_cipp_compiler_version;
print "<!-- CIPP $compiler / $CIPP::Runtime::Request::VERSION | $runtime - Copyright (c) dimedis GmbH, All Rights Reserved -->\n\n";
}
1;
}
sub load_module {
my $self = shift;
my %par = @_;
my ($name) = @par{'name'};
$name =~ s!::!/!og;
$name .= ".pm";
require $name;
1;
}
sub set_locale_messages_lang {
my $self = shift;
my ($lang) = @_;
POSIX::setlocale(POSIX::LC_MESSAGES(), $lang);
POSIX::setlocale(POSIX::LC_TIME(), $lang);
1;
}
sub gettext {
my $self = shift;
my ($message, $data_href) = @_;
return $message if not $data_href;
my $re = join '|', map { quotemeta $_ } keys %{$data_href};
$message =~
s/\{($re)\}/defined $data_href->{$1} ?
$data_href->{$1} : "{$1}"/ge;
return $message;
}
sub dgettext {
my $self = shift;
my ($domain, $message, $data_href) = @_;
my $trans = Locale::Messages::dgettext($domain, $message);
return $trans if not $data_href;
my $re = join '|', map { quotemeta $_ } keys %{$data_href};
( run in 0.619 second using v1.01-cache-2.11-cpan-524268b4103 )