view release on metacpan or  search on metacpan

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

#
# Takes a scalar key and a scalar value
# Adds them to the html que
#
sub html {
	my $self  = _getself(\@_);
	my $key   = shift || croak "key not supplied";
	my $value = shift;
	$self->{_html}->{$key} = $value;
	return 1;
}

#
# Takes a scalar key and a scalar value
# Pushes the value into the html element as an array
#
sub html_push {
	my $self           = _getself(\@_);
	my $key            = shift || croak "key not supplied";
	my $value          = shift;
	my $existing_value = $self->{_html}->{$key} || [];
	if (ref($existing_value) ne "ARRAY") {
		croak "Key $key already exists as non-array. Cannot push into it.";
	}
	push(@{$existing_value}, $value);
	$self->{_html}->{$key} = $existing_value;
	return 1;
}

#
# Takes a scalar key and a scalar value
# Unshifts the value into the html element as an array
#
sub html_unshift {
	my $self           = _getself(\@_);
	my $key            = shift || croak "key not supplied";
	my $value          = shift;
	my $existing_value = $self->{_html}->{$key} || [];
	if (ref($existing_value) ne "ARRAY") {
		croak "Key $key already exists as non-array. Cannot unshift into it.";
	}
	unshift(@{$existing_value}, $value);
	$self->{_html}->{$key} = $existing_value;
	return 1;
}

#
# Re-sets initial_template
#
sub initial_template {
	my $self = _getself(\@_);
	my $initial_template = shift || croak "initial template not supplied";
	$self->{initial_template} = $initial_template;
}

#
# An alias to new(), to be used in nooop mode
#
sub initialize_cgi_framework {
	my %para = ref($_[0]) eq "HASH" ? %{ $_[0] } : @_;
	$para{callbacks_namespace} ||= (caller)[0] || "main";
	return new("CGI::Framework", \%para);
}

#
# The constructor.  Initializes pretty much everything, returns a new bless()ed instance
#
sub new {
	my $class = shift || "CGI::Framework";
	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

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

					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";
						$smtp->data("X-CGI-Framework-Method: Net::SMTP $para{smtp_host}\nX-CGI-Framework-REMOTE-ADDR: $ENV{REMOTE_ADDR}\nX-CGI-Framework-PID: $$\n\nThe following fatal error occurred:\n\n$error") || die "Could not send DATA command: $@\n";
						$smtp->quit();
					};
					$emailsent = 1 if !$@;
				}

				#
				# Finally cleanup cruft:
				#
				$self->finalize();
			}
		);
	}

	#
	# Some initial setup
	#
	$para{_html} = {};

	#
	# We set some defaults if unsupplied
	#
	$para{valid_languages} ||= [];
	$para{callbacks_namespace} ||= (caller)[0] || "main";
	if (!$para{cookie_name}) {
		$para{cookie_name} = "sessionid_$ENV{SCRIPT_NAME}";
		$para{cookie_name} =~ s/[^0-9a-z]//gi;
	}
	if (!$para{sessions_mysql_dbh} && !$para{sessions_dir}) {

		#
		# They didn't supply any sessions stuff, so let's take a guess at some directories for file-based storage:
		#
		foreach (qw(/tmp /var/tmp c:/tmp c:/temp c:/windows/temp)) {
			if (-d $_) {
				$para{sessions_dir} = $_;
				last;
			}
		}
	}
	if (!$para{templates_dir}) {
		foreach (qw(./templates ../templates)) {
			if (-d $_) {
				$para{templates_dir} = $_;
				last;
			}
		}
	}
	if (!$para{sessions_serializer_default} && !$para{sessions_serializer_storable} && !$para{sessions_serializer_freezethaw}) {
		$para{sessions_serializer_default} = 1;
	}

	#
	# Now we do sanity checking
	#
	ref $para{valid_languages} eq "ARRAY" || croak "valid_languages must be an array ref";
	if ($para{"maketext_class_name"}) {
		@{ $para{valid_languages} } || croak "valid_languages must be set to at least one language to specify the maketext_class_name key";
	}
	$para{sessions_dir} && $para{sessions_mysql_dbh} && croak "Only one of sessions_dir and sessions_mysql_dbh may be supplied";
	if ($para{sessions_dir}) {

		#
		# Supplied (or determined) file-based sessions storage
		#
		-e $para{sessions_dir} && !-d $para{sessions_dir} && croak "$para{sessions_dir} exists but is not a directory";
		-d $para{sessions_dir} || mkdir($para{sessions_dir}, 0700) || croak "Failed to create $para{sessions_dir}: $!";
		-w $para{sessions_dir} || croak "$para{sessions_dir} is not writable by me";
	}
	elsif ($para{sessions_mysql_dbh}) {

		#
		# Supplied mysql-based sessions storage
		# Should be a reference to mysql object - but I'll just make sure it's *a* reference to something
		#
		ref($para{sessions_mysql_dbh}) || croak "Invalid sessions_mysql_dbh supplied";
	}
	else {
		croak "Neither sessions_dir or sessions_mysql_dbh were supplied, and could not automatically determine a suitable sessions_dir";
	}
	if ((grep { $para{$_} } qw(sessions_serializer_default sessions_serializer_storable sessions_serializer_freezethaw)) > 1) {
		croak "Only one of sessions_serializer_default, sessions_serializer_storable and sessions_serializer_freezethaw may be supplied";
	}
	$para{templates_dir}                  || croak "templates_dir must be supplied";