use Framework; use CGI; my $coll = new Framework::Collection; $coll->templater(new TemplatingEngine); my $p1 = new Framework::Page("login", -description => 'Login page'); $p1->validator(sub { my $page = shift; my $pobj = $page->paramobj; return 1 if ($pobj->param('name') eq 'bmcatt'); $page->add_error('name', 'invalid name given'); return 0; } ); $p1->traverse(sub { my $page = shift; return 'login' if ($page->errors(':any')); return 'main'; } $p1->template('login.tmpl'); my $p2 = new Framework::Page("main", -description => 'Main Page' -hparams => [ 'name' ]); $p2->output( sub { my ($page, $paramref, $output) = @_; my $s = "Content-type: text/html\n\n"; $s .= "You have logged in as " . $paramref->{'name'} . ""; return $s; } $coll->page($p1); $coll->page($p2); $coll->defpage($p1); $coll->run(new CGI); print $coll->output; ##
##

#! perl -w
package Framework;

# XXX Add small working example to POD

=pod

=head1 NAME

Framework - Perl module to provide command and control functionality
over templatized web pages

=head1 SYNOPSIS

  use CGI;
  use Framework;

  $p = new Framework::Page("name", -description => "Initial page",
                           -template => "name.tmpl");
  $p->traverse(\&traverse_name);

  $c = new Framework::Collection;
  $c->page($p);

  $c->templater($templating_engine_instance);
  $c->run(new CGI);
  print $c->output;

=head1 DESCRIPTION

Framework provides a way to maintain, display and arbitrate the
selection of templatized web pages. It does this through the paradigm
of individual Is which are bundled together into a
I.

The Collection controls selection of which Page is to be executed
(based on parameter analysis). The selected Page controls parameter
validation and selection of the next Page to be processed. Once a
target page has been determiend, that Page is processed for its
template and is run through the templating engine.

=cut

use strict;
use vars qw($VERSION);

use constant DEBUG => 1;

$VERSION = '0.02';

my $DEFAULT_ERROR_SEP = '|';

package Framework::Collection;

=pod

=head2 Framework::Collection

=over 4

=cut

sub debugprint {
    my $level = shift;
    print @_ if (Framework::DEBUG >= $level);
}

my $output;

=pod

=item new()

Create a new Collection. Usually called as:

  my $coll = new Framework::Collection();

=cut

sub new {
    my $this = shift; my $class = ref($this) || $this;

    my $self = {
	_PAGES => {},
	_DEFAULT_PAGE => undef,
    };
    bless $self, $class;
}

=pod

=item page($page)

=item page($name)

When called with a Framework::Page, adds C<$page> to the list of pages
to be considered for processing.

When called with a string C<$name>, returns the Framework::Page with
the name C<$name> or C.

The first C<$page> added to a Collection is the default page unless
overriden through a call to C.

=cut

sub page {
    my $self = shift;
    my ($page) = @_;
    if ($page->isa("Framework::Page")) {
	# Add to _PAGES{}
	$self->{_PAGES}->{$page->{_NAME}} = $page;
	$self->defpage($page) unless ($self->defpage());
	return $page;		# Just to have something useful returned
    } else {
	# $page is a page *NAME*, not an actual page...
	# Return _PAGES{$page};
	if (exists $self->{_PAGES}->{$page}) {
	    return $self->{_PAGES}->{$page};
	}
	return undef;
    }
}

=pod


=item defpage($page)

=item defpage($name)

Sets the default page to be processed, either by name or by
Framework::Page object. The default page is the page of I
and is used if the Collection cannot determine the calling page. This
is typically used during the first invocation of the application.

=cut

sub defpage {
    my $self = shift;
    my ($page) = @_;

    if (!$page) { return $self->{_DEFAULT_PAGE}; }
    $self->{_DEFAULT_PAGE} = ( $page->isa('Framework::Page')
			       ? $page->{_NAME}
			       : $page );
}

=pod

=item templater(I<$templating_instance>)

Assigns / returns the instance of the templating object which is to be
used for processing the template of the destination page. If called
without arguments, the current value is returned. The
C<$templating_instance> will eventually be called as:

  &$templating_instance($template, \%params);

=cut

sub templater {
    my $self = shift;
    if (@_) { $self->{_TEMPLATER} = shift; }
    return $self->{_TEMPLATER};
}

# We need this here because both run and output() need to have access
# to it...
my ($targpage_id, $targpage);

=pod

=item run($paramobj)

Uses C<$paramobj> (usually an instance of a CGI object) to process the
Collection and determine the correct target Page. At a minimum,
C<$paramobj> must support a scalar and list context param() for
retrieval and assignment and a hidden() method. The processing flow
during a run is:

=over 4

=item 1

Determine the current Page name

=item 2

Invoke current page's validator subref (if defined)

=item 3

If no validator or the validator returned C, invoke current
page's postsubmit subref (if defined)

=item 4

Invoke current page's traverse subref (if defined). The traverse
subref is expected to return the name of the target page. If there is
no traverse subref or it returns C, the current page is used as
the target page.

=item 5

Invoke target page's preprocess subref (if defined).

=back

The return value from the target page's preprocess subref will be used
as the return value from C.

=cut

sub run {
    my $self = shift;
    my ($pobj) = @_;

    # Determine originating page
    my $curpage_id = $pobj->param("_PAGE_CURRENT")
	|| $self->{_DEFAULT_PAGE};
    debugprint 1, "Starting at page $curpage_id\n";
    # Get Framework::Page for current page
    my $curpage = $self->page($curpage_id);

    # Clear out any old cruft
    $curpage->_phase(':runconfig');
    $curpage->paramobj($pobj);

    # Run $curpage->validator->()
    $curpage->_phase(':valid');
    my $val_return = 1;
    if ($curpage->validator) {
	$val_return = &{$curpage->validator()}($curpage);
    }

    # Run $curpage->postsub->() if validator->() returned TRUE
    $curpage->_phase(':postsub');
    if ($val_return && $curpage->postsubmit) {
	&{$curpage->postsubmit()}($curpage);
    }

    # Run $curpage->traverse->()
    $curpage->_phase(':traverse');
    $targpage_id = $curpage_id;
    if ($curpage->traverse) {
	$targpage_id = &{$curpage->traverse()}($curpage);
	if (!$targpage_id) { $targpage_id = $curpage_id; }
    }

    # Save error list and retract parameter object from old page
    my $errlist = $curpage->errors(':all');
    $curpage->_phase(':undef');

    # Get Framework::Page for target page
    debugprint 1, "Transitioning to $targpage_id\n";

    $targpage = $self->page($targpage_id);
    $targpage->paramobj($pobj);

    # Transfer error set from original to target
    $targpage->_phase(':seterrors', $errlist);

    # Clear out the output
    $output = '';

    # Run $targpage->preprocess->()
    $targpage->_phase(':preproc');
    if ($targpage->preprocess) {
	$output = &{$targpage->preprocess()}($targpage);
    }

    # Return output from preprocess->()
    return $output;
}

sub _get_params {
    my $p = shift;
    my $pobj = $p->paramobj;

    my %paramhash;

    if ($p->aparams) {
	foreach ($p->aparams) {
	    my @param = $pobj->param($_);
	    my $pval = ( @param == 1 ? $param[0] : \@param );
	    $paramhash{$_} = $pval;
	}
    }

    my $hidden;
    if ($p->hparams) {
	foreach ($p->hparams) {
	    my @param = $pobj->param($_);
	    $hidden .= $pobj->hidden($_, @param);
	}
    }
    $hidden .= $pobj->hidden('_PAGE_CURRENT', $p->{_NAME});
    $paramhash{_PAGE_HIDDEN} = $hidden;

    $paramhash{_PAGE_DESC} = $p->{_DESC};

    my $errs = $p->errors;
    foreach (keys %$errs) {
	$paramhash{'_ERROR_' . $_} = $errs->{$_};
    }

    # XXX Add other parameters (errors, etc).

    return \%paramhash;
}

=pod

=item output()

Invokes the templating engine on the template for the target page.
Also invokes the target page's output subref (if defined). The
templating engine is only invoked if both it and the target page's
template are defined.

The return value is the output of the templating engine, possibly
after it has been subsequently passed through the target page's output
subref.

=cut

sub output {
    my $self = shift;

    my $params = _get_params($targpage);

    if ($targpage->template && $self->{_TEMPLATER}) {
	$output = $self->templater->($targpage->template, $params);
    }

    if ($targpage->output) {
        $output = $targpage->output->($targpage, $params, $output);
    }

    # Retract parameter object from targpage
    $targpage->_phase(':undef');

    return $output;
}

=pod

=back

=cut

package Framework::Page;

=pod

=head2 Framework::Page

=over 4

=cut

sub debugprint {
    my $level = shift;
    print @_ if (Framework::DEBUG >= $level);
}

# Externally visible methods that are intended to be called by those wanting
# to create/modify a page.

my %PAGE_KEY_NAMES = (
		      -description => '_DESC',
		      -validator => '_VALID',
		      -postsubmit => '_POST',
		      -traverse => '_TRAV',
		      -preprocess => '_PREPROC',
		      -template => '_TMPL',
		      -output => '_OUTPUT',
		      -hparams => '_HPARAMS',
		      -aparams => '_APARAMS',
		      -error_sep => '_ERROR_SEP',
		      );

my @ERROR_CLASSES = qw(:valid :postsub :traverse :preproc);

my %PAGE_CTOR_DEFAULTS = (
			  _DESC => "",
			  _VALID => undef,
			  _POST => undef,
			  _TRAV => undef,
			  _PREPROC => undef,
			  _TMPL => undef,
			  _OUTPUT => undef,
			  _HPARAMS => [],
			  _APARAMS => [],
			  _ERROR_SEP => $DEFAULT_ERROR_SEP,
			  _PHASE => ':valid',
			  );


sub _check_params {
    my %params = @_;

    my %outparams;
    foreach my $pname (keys %params) {
	# XXX Better error handling - bad parameter specified.
	die "A horrible death" if (!exists($PAGE_KEY_NAMES{$pname}));
	$outparams{$PAGE_KEY_NAMES{$pname}} = $params{$pname};
    }
    return %outparams;
}

=pod

=item new($name, ...)

=item $page->new($newname, ...)

Creates a new Page instance using C<$name> as the page's name. When
called as a method on an existing Page, the new Page will be
configured exactly the same as the existing page, except for having a
new name.

Optional parameters may be included to "short-circuit" the process of
creating a new Page. An example of creating a Page with all
short-circuit parameters used is:

  $p = new Framework::Page('TestPage',
                           -description => "This is a test page",
                           -validator => \&valid_sub,
                           -postsubmit => \&postsubmit_sub,
                           -traverse => \&traverse_sub,
                           -preprocess => \&preprocess_sub,
                           -template => "TestPage.tmpl",
                           -output => \&output_sub,
                           -hparams => [ 'hidden1', 'hidden2' ],
                           -aparams => [ 'avail1', 'avail2' ],
                           -error_sep => '
'
                           );

=cut

sub new {
    my $this = shift; my $class = ref($this) || $this;

    my $name = shift;

    # XXX Better error handling - force a name to be given.
    die "You silly rabbit" if (!defined($name));

    my %params = _check_params(@_);

    if (ref($this) && $this->isa('Framework::Page')) {
	# called as a copy constructor...
	my $self = {
	    %$this,
	    %params,
	};

	bless $self, $class;
	$self->_phase(':runconfig');
	return $self;
    }

    my $self = {
	_NAME => $name,
	%PAGE_CTOR_DEFAULTS,
	%params,
    };
    bless $self, $class;
    $self->_phase(':runconfig');
    return $self
}

=pod

=item description($desc)

Assigns / retrieves a textual description for this Page. This is not
used internally, but is passed to the templating engine as the
parameter C<_PAGE_DESC>.

=cut

sub description ($$) {
    my $self = shift;
    if (@_) { $self->{_DESC} = shift; }
    return $self->{_DESC};
}

=pod

=item validator(\&validator)

Assigns / retrieves the subref for the validation routine to be used
to determine whether the parameters for this page were valid. Called
as:

  &validator($curpage);

If C<&validator> returns C, it indicates that the subsequent
postsubmit subref is to be called. Otherwise, the postsubmit is
skipped and the traverse subref is called.

B: It was the authors' intention that &validator not mutate any
of the back-end data or system state. Any changes to the system state
were intended to be done in the postsubmit routine following
successful validation.

=cut

sub validator ($\&) {
    my $self = shift;
    if (@_) { $self->{_VALID} = shift; }
    return $self->{_VALID};
}

=pod

=item postsubmit(\&postsubmit)

Assigns / retrieves the subref for the postsubmit routine to be used
to perform post-validation processing. Called as:

  &postsubmit($curpage);

The return value from C<&postsubmit> is ignored by the Collection.

=cut

sub postsubmit ($\&) {
    my $self = shift;
    if (@_) { $self->{_POST} = shift; }
    return $self->{_POST};
}

=pod

=item traverse(\&traverse)

Assigns / retrieves the subref for the traversal routine to be used to
determine what the appropriate target page is. Called as:

  &traverse($curpage);

The return value from C<&traverse> should be the name of the target
page to be processed or C if the current page should be used as
the target page.

=cut

sub traverse ($\&) {
    my $self = shift;
    if (@_) { $self->{_TRAV} = shift; }
    return $self->{_TRAV};
}

=pod

=item preprocess(\&preprocess)

Assigns / retrieves the subref for the preprocessing routine to be
used as the last stage of a Collection's C. Called as:

  &preprocess($targetpage);

The return value from C<&preprocess> is used as the return value from
Collection's C.

=cut

sub preprocess ($\&) {
    my $self = shift;
    if (@_) { $self->{_PREPROC} = shift; }
    return $self->{_PREPROC};
}

=pod

=item template($template_filename)

Assigns / retrieves the name of the file to be passed to the
templating engine when the Collection's C is called.

=cut

sub template ($$) {
    my $self = shift;
    if (@_) { $self->{_TMPL} = shift; }
    return $self->{_TMPL};
}

=pod

=item output(\&output)

Assigns / retrieves the subref for the output generation or
postprocessing. Called as:

  &output($targetpage, \%params, $output);

C<$output> is either the output of the templating engine (if it is
defined and a template exists for this page) or the output of the
preprocessing step.

If this subref is provided, the return value will be used as the
return value from the Collection's C, otherwise the return
value from the templating engine will be used.

=cut

sub output ($\&) {
    my $self = shift;
    if (@_) { $self->{_OUTPUT} = shift; }
    return $self->{_OUTPUT};
}

=pod

=item hparams(I<\@hidden_params>)

Assigns / retrieves an arrayref containing the list of parameters
which are to be turned into "hidden" fields for the templating or
output processing. All of the hidden fields will be provided as a
single parameter named C<_PAGE_HIDDEN>.

In addition to the user-specified hidden parameters, the Collection
will also be providing at least one other hidden parameter. At a
minimum, the Collection will be providing C<_PAGE_CURRENT> which is
used for page determination at the beginning of the C.

If called in scalar context, C returns the arrayref. If
called in list context, C will dereference the array ref
and return the values as a list.

=cut

sub hparams {
    my $self = shift;
    if (@_) { $self->{_HPARAMS} = \@_; }
    my $paramref = $self->{_HPARAMS};
    return ( wantarray ? @$paramref : $paramref );
}

=pod

=item aparams(I<\@available_params>)

Assigns / retrieves an arrayref containing a list of parameters to be
"made available" to the templating engine and output processing. Any
parameters to be mmade available are copied verbatim into the
parameter hashref which is passed to the templating engine and the
page's output subref.

If called in scalar context, C returns the arrayref. If
called in list context, C will dereference the array ref
and return the values as a list.

=cut

sub aparams {
    my $self = shift;
    if (@_) { $self->{_APARAMS} = \@_; }
    my $paramref = $self->{_APARAMS};
    return ( wantarray ? @$paramref : $paramref );
}

# Externally visible methods that are intended to be called by the
# subrefs which are called through the Collection we belong to.

=pod

=item add_error($name, $message)

B - intended to be called only from the subrefs when
Collection invokes them.

Add an error message to the phase-specific set of error messages,
against the parameter C<$name>. Note that C<$name> does not have to
actually refer to a real parameter name. However C<$name> will be used
when the error messages are transfered to the templating engine or
output subref in the parameter hash. Error messages for C<$name> will
be passed in as the parameter C<_ERROR_$name>.

Each processing step (:valid, :postsub, :traverse, :preproc) has its
own set of error messages which are individually filled. Multiple
errors for an individual C<$name> during the same processing step will
be separated by the I.

=cut

sub add_error {
    my $self = shift;
    my ($param, $message) = @_;

    my $errlist = $self->{_ERROR_LIST}->{$self->{_PHASE}};

    if (exists $errlist->{$param}) {
	$errlist->{$param} .= $self->{_ERROR_SEP};
    }
    $errlist->{$param} .= $message;
}

=pod

=item error_sep($separator)

Assigns / retrieves the string to be used between multiple error
messages for the same parameter name.

Note that C may be set separately for the current and
target pages and this may cause strange behaviour.

=cut

sub error_sep {
    my $self = shift;
    if (@_) { $self->{_ERROR_SEP} = shift; }
    return $self->{_ERROR_SEP};
}
	
=pod

=item errors(':any')

=item errors(':any:valid') [or :any:postsub, :any:traverse, :any:preproc] 

=item errors(':all')

=item errors(':valid') [or :postsub, :traverse, :preproc]

=item errors()

B - intended to be called only from the subrefs when
Collection invokes them.

Retrieves the list of errors (or presence of errors) for different
phases and in different forms.

C (and the similar :any:I form) return a boolean
TRUE / FALSE indicating whether there are any errors present for all
processing phases or for the particular (specified) type.

C returns a hashref where the keys are the types
(':valid', etc) and the values are hashrefs. The contained hashrefs
are set up as C<$name =E $message(s)>.

C (and the similar forms) return a hashref of
hashref where the single key in the containing hashref is the key that
was passed in.

C returns a flattened single-level hash version of
C where the top level of keys is removed. All entries
are set up as C<$name =E $message(s)>. Multiple messages for the
same C<$name> will be combined as for C.

=cut

sub errors {
    my $self = shift;
    my ($type) = @_;

    # Handle undef :type
    if (!$type) {
	my %errors;
	foreach (@ERROR_CLASSES) {
	    my $sublist = $self->{_ERROR_LIST}->{$_};
	    foreach (keys %$sublist) {
		if (exists($errors{$_})) {
		    $errors{$_} .= $self->{_ERROR_SEP};
		}
		$errors{$_} .= $sublist->{$_};
	    }
	}
	return \%errors;
    }

    # $type eq ':any' or in (:any:valid, :any:postsub, etc.)
    if ($type =~ /^:any/) {
	$type =~ s/^:any//;
	if (!$type) {
	    # Simple :any check
	    foreach (@ERROR_CLASSES) {
		return 1 if %{$self->{_ERROR_LIST}->{$_}}
	    };
	    return 0;
	}
	if (grep {/^$type$/} @ERROR_CLASSES) {
	    return (%{$self->{_ERROR_LIST}->{$type}} && 1);
	}
	die "Foolish mortal... :any with invalid type $type";
    }
    # :type eq ':all'
    if ($type eq ':all') {
	return $self->{_ERROR_LIST};
    }
    # :type in (:valid, :postsub, :traverse, :preproc)
    if (grep {/^$type$/} @ERROR_CLASSES) {
	my %out = ( $type => \%{$self->{_ERROR_LIST}->{$type}} );
	return \%out;
    }
    # XXX Better error handling...
    die "A pox on your errors call ($type)" if ($type);
}

#sub param ($$) {
#    my $self = shift;
#    my ($paramname) = @_;
#
#    # XXX Implement the internal parameter passing.
#}

=pod

=item paramobj()

B - intended to be called only from the subrefs when
Collection invokes them.

Retrieves the parameter object which was originally passed in to the
Collection's C. This is intended to allow a subref access to
the parameters from the parameter object.

=cut

sub paramobj {
    my $self = shift;
    if (@_) { $self->{_PARAMOBJ} = shift; }
    return $self->{_PARAMOBJ};
}

# Internally called routines. Don't look down here unless you really want to
# see some of the innards of Framework... Really... I warned you...

sub _phase {
    my $self = shift;
    my $phase = shift;

    debugprint 2, "Page ", $self->{_NAME}, "->_phase change to $phase\n";

    if ($phase eq ':undef') {
	$self->{_PARAMOBJ} = undef;
	$phase = ':runconfig';		# Force clear errors
    }
    if ($phase eq ':runconfig') {
	$self->{_ERROR_LIST} = { map { $_ => {} } @ERROR_CLASSES };
    }
    if ($phase eq ':seterrors') {
	$self->{_ERROR_LIST} = $_[0];
    }
    $self->{_PHASE} = $phase;
}

=pod

=back

=cut

1;
__END__
# Below is the stub of documentation for your module. You better edit it!

=pod

=cut