view release on metacpan or  search on metacpan

lib/CGI/Framework.pm  view on Meta::CPAN

	my %para = ref($_[0]) eq "HASH" ? %{ $_[0] } : @_;
	my $self = {};
	my $cookie_value;
	my $temp;
	my $expire;
	my $sessions_driver;
	my $sessions_serializer;
	local (*FH);

	$self = bless($self, ref($class) || $class);

	#
	# Paranoia: It should be clear anyways... but
	#
	if ($LASTINSTANCE) {
		$LASTINSTANCE->finalize();
	}

	#
	# Backwards compatability support
	#
	foreach (qw(callbacks_namespace cookie_name import_form initial_template sessions_dir templates_dir valid_languages)) {
		$temp = $_;
		$temp =~ s/_//g;
		if (!exists $para{$_} && exists $para{$temp}) {
			$para{$_} = $para{$temp};
			delete $para{$temp};
		}
	}

	#
	# Custom fatal error handling
	#
	$para{fatal_error_email} && !$para{smtp_host} && !$para{sendmail} && croak "You must supply smtp_host and/or sendmail when supplying fatal_error_email";
	if ($para{"fatal_error_template"} || $para{"fatal_error_email"}) {
		set_message(
			sub {
				my $error     = shift;
				my $emailsent = 0;
				my $errorsent = 0;
				my $index;
				my @callerparts;
				my @stack;
				local (*SMH);

				#
				# Hold your horses - some errors should just be ignored
				#
				if (exists $ENV{"HTTPS"} && $ENV{"HTTPS"} && $error =~ /^((103:)?Software caused connection abort)|((104:)?Connection reset by peer)/i) {

					#
					# This is generated by some braindead web browsers that do not properly terminate an SSL session
					#
					$self->finalize();
					return ();
				}

				#
				# Append stack to error message:
				#
				for ($index = 0 ; @callerparts = caller($index) ; $index++) {
					push(@stack, "$callerparts[1]:$callerparts[2] ($callerparts[3])");
				}
				@stack = reverse @stack;
				$error .= "\n\nStack trace appended by CGI::Framework fatal error handler:\n";
				foreach (0 .. $#stack) {
					$error .= "    " x ($_ + 1);
					$error .= $stack[$_];
					$error .= "\n";
				}

				#
				# Show something back to the web user regarding the error
				# We do this first BEFORE sending off emails because under mod_perl, an open() to a pipe (sendmail) sends some
				# crap to the browser - FIXME - NEEDS INVESTIGATING
				#
				if ($para{"fatal_error_template"}) {
					eval {
						$self->{_html}->{_fatal_error} = $error;
						$self->show_template($para{"fatal_error_template"}, 1);
					};
					if (!$@) {
						$errorsent = 1;
					}
					elsif ($@ =~ /mod_?perl/i && $@ =~ /exit/i) {

						#
						# Under mod_perl, an exit() (deep in finalize()) called inside an eval (above) gets thrown and therefore caught above
						# so we treat it as success
						#
						$errorsent = 1;
					}
				}
				if (!$errorsent) {
					print "Content-type: text/html\n\n<h1>The following fatal error occurred:</h1><p><pre>$error</pre>\n";
				}

				#
				# Now try to send the fatal error email
				#
				if (!$emailsent && $para{"fatal_error_email"} && $para{"sendmail"}) {
					eval {
						open(SMH, "| $para{sendmail} -t -i") || die "Failed to open pipe to sendmail: $!\n";
						print SMH "From: " . ($para{"smtp_from"} || 'cgiframework@localhost') . "\n";
						print SMH "To: ", (ref($para{"fatal_error_email"}) eq "ARRAY" ? join(",", @{ $para{"fatal_error_email"} }) : $para{"fatal_error_email"}), "\n";
						print SMH "Subject: Fatal Error\n";
						print SMH "X-CGI-Framework-Method: sendmail $para{sendmail}\n";
						print SMH "X-CGI-Framework-REMOTE-ADDR: $ENV{REMOTE_ADDR}\n";
						print SMH "X-CGI-Framework-PID: $$\n";
						print SMH "\n";
						print SMH "The following fatal error occurred:\n\n$error\n";
						close(SMH);
					};
					$emailsent = 1 if !$@;
				}
				if (!$emailsent && $para{"fatal_error_email"} && $para{"smtp_host"}) {
					eval {
						require Net::SMTP;
						my $smtp = Net::SMTP->new($para{"smtp_host"}) || die "Could not create Net::SMTP object: $@\n";
						$smtp->mail($para{"smtp_from"} || 'cgiframework@localhost') || die "Could not send MAIL command: $@\n";
						$smtp->recipient(ref($para{"fatal_error_email"}) eq "ARRAY" ? @{ $para{"fatal_error_email"} } : $para{"fatal_error_email"}) || die "Could not send RECIPIENT command: $@\n";