view release on metacpan or  search on metacpan

MxScreen.pm  view on Meta::CPAN

	my $log = $self->log;
	$log->debug(\&log_inc_times, $self, "outside CGI::MxScreen");

	#
	# Compute target screen, trap all errors.
	#
	# Since we might be using CGI::Carp, we must cancel any trap hook by
	# localizing the __DIE__ and __WARN__ special handlers.
	#

	my ($screen, $args);
	eval {
		local $SIG{__DIE__};
		local $SIG{__WARN__};

		($screen, $args) = $self->compute_screen;
	};
	$log->debug(\&log_inc_times, $self, "screen computation");
	$self->internal_error($@) if chomp $@;

	#
	# Emit CGI headers
	# From now on, output is safe and will not get us a server error.
	#

	untie *main::STDOUT;			# Restore original STDOUT stream

	#
	# If they configured us to buffer all STDOUT until context is ready
	# to be emitted, then create object, print headers and mark the
	# output of headers as done: further output to STDOUT will be buffered
	# and printed only after the context.
	#
	# The reason for this is to have the context emitted before any other
	# form widget.  That way, pressing a submit button before the whole form
	# is loaded in the browser won't matter as much, since we'll have at
	# least the context to propagate in the POST parameters.
	#

	my $stdout;
	if ($CGI::MxScreen::cf::mx_buffer_stdout) {
		require CGI::MxScreen::Tie::Buffered_Output;
		$stdout = tie *main::STDOUT, "CGI::MxScreen::Tie::Buffered_Output";
	}

	#
	# Display screen, with proper "bounce" exception support.
	# Returns screen that was finally displayed.
	#

	$screen = $self->display($screen, $args, $stdout);
	$log->debug(\&log_inc_times, $self, "\"%s\" display", $screen->name);

	#
	# Snapshot current time and last modification date of the
	# scriptright before saving context.  That fields can be used to
	# check for session validity.
	#

    $self->ctx->{'time'} = time;
    $self->ctx->{'script_date'} = (stat($0))[9]; 

	#
	# Cleanup context to avoid saving transient data
	#

    &{$coderef}() if defined $coderef; # TBR

    for my $f (@{$self->context_root->[SCREEN_FIELD]}) {
        DASSERT $f->isa('CGI::MxScreen::Form::Field');
        $f->cleanup();
    }
    for my $b (@{$self->context_root->[SCREEN_BUTTON]}) {
        DASSERT $b->isa('CGI::MxScreen::Form::Button');
        $b->cleanup();
    }

	#
	# If STDOUT was bufferd, the context must be emitted explicitely
	# between the header of the form and the remaining data.
	#

	if (defined $stdout) {
		my $context = $self->session->save;
		$stdout->print_all($context);
		untie_stdout();
	} else {
		print $self->session->save;
	}

	$log->debug(\&log_inc_times, $self, "context save");

	#
	# Emit CGI trailers.
	#

	print CGI::endform;

	my $layout = $self->layout;
	$layout->postamble;
	$layout->end_HTML;

    return DVOID;
}

#
# ->compute_screen
#
# Compute target screen, and run and enter/leave hooks if we change screens.
# This routine does not display anything, but runs all the action callbacks.
#
# Returns new screen object, and a ref to the argument list.
#
sub compute_screen {
	DFEATURE my $f_;
	my $self = shift;
    my ($current_state, $previous_state, $new_state);
    my ($origin_name, $target_name, @arg_list);
    my $screen;
	my $errors = 0;
    my $ctx = $self->ctx;

MxScreen.pm  view on Meta::CPAN

		#

		if (ref $@ || chomp $@) {
			my $msg = $@;
			$msg =~ s/^\(.*?\)\s+//;	# Remove already added session tag
			$self->log->critical("display error for screen \"%s\": %s",
					$screen->name, $msg);

			#
			# If they buffered STDOUT, it's nice, because the screen will not
			# mix regular output and the error message.  And since we discard
			# even the form header, the Content-Type printed by CGI::Carp will
			# not even show!
			#

			untie_stdout(1) if defined $stdout;
			logdie $msg;
		}

		return DVAL $screen;		# Successfully displayed the screen
	}

	$self->log->critical("too many screen bounces");
	logdie "possible infinite loop detected, aborting";
}

#
# ->check_validity
#
# Check context validity: proper version, no timeout.
#
sub check_validity {
    DFEATURE my $f_;
    my $self = shift;

	unless (defined $self->context_root) {
		logerr "mangled context from %s", CGI::remote_host();
		$self->internal_error("cannot retrieve application context");
	}

    my $ctx = $self->ctx;
	return DVOID unless exists $ctx->{'cgi_version'};	# Empty context

	#
	# Ensure binary version (which traces variations in the way session
	# context are represented) is compatible.
	#

	my $bin = $ctx->{'bin_version'};
    if ($bin > $BIN_VERSION) {
        $self->internal_error(<<EOS);
Script session used a format (v$bin) more recent than I am (v$BIN_VERSION).
Please restart a new session.
EOS
	}

    #
    # check that the script file has not been modified (compare the
    # last modification time on the file system)
    #
    if ($ctx->{'script_date'} != (stat($0))[9]) {
        $self->internal_error(<<EOS);
Script file has been modified since the last display, 
please restart a new session.
EOS
    }

    #
    # check whether the cgi version is still the same
    #
    if (defined $ctx->{'cgi_version'}) {
        my $version = $ctx->{'cgi_version'};

        if ($version ne $self->cgi_version) {
            $self->internal_error(<<EOS);
Script version has evolved since the last display, please restart a new session.
EOS
        }
    }

    #
    # check whether the timeout is not exhausted
    #
    if (defined $self->valid_time && defined $ctx->{'time'}) {
        my $last_time = $ctx->{'time'};

        if ((time - $last_time) > $self->valid_time) {
            $self->internal_error(<<EOS);
Session timeout since the last display, please restart a new session.
EOS
        }
    }

    return DVOID;
}

#
# ->internal_error
#
#
sub internal_error {
    DFEATURE my $f_;
    my $self = shift;
    my ($message) = @_;

	my $logmsg = $message;
	$logmsg =~ s/\s+/ /sg;
	logerr "internal error: $logmsg";

	untie_stdout(1);		# Restore original STDOUT stream, discard all

	my $layout = $self->layout;

	$layout->init(undef);
	$layout->start_HTML("Internal Script Error");
	$layout->preamble;

    print CGI::h1("Internal Script Error");
    print CGI::p(CGI::tt(ucfirst($message)));
    print CGI::p(CGI::a({-href => CGI::url()}, "Restart a new session"));