-
- $hist->{'response'} = 1;
- return 1;
-}
-
-sub unmorph {
- my $self = shift;
- my $step = shift || '_no_step';
- my $lin = $self->{'_morph_lineage'} || return;
- my $cur = ref $self;
-
- my $prev = pop(@$lin) || croak "unmorph called more times than morph - current ($cur)";
- delete $self->{'_morph_lineage'} if ! @$lin;
-
- ### if we are not already that package - bless us there
- my $hist = {
- step => $step,
- meth => 'unmorph',
- found => 'unmorph',
- time => time,
- elapsed => 0,
- response => 0,
- };
- push @{ $self->history }, $hist;
-
- if ($cur ne $prev) {
- $self->fixup_before_unmorph($step);
- bless $self, $prev;
- $hist->{'found'} .= " (changed from $cur to $prev)";
- } else {
- $hist->{'found'} .= " (already isa $cur)";
- }
-
- $hist->{'response'} = 1;
- return $self;
-}
-
-sub fixup_after_morph {}
-
-sub fixup_before_unmorph {}
-
-###----------------------------------------------------------------###
-### allow for authentication
-
-sub navigate_authenticated {
- my ($self, $args) = @_;
- $self = $self->new($args) if ! ref $self;
-
- if ($self->can('require_auth') != \&CGI::Ex::App::require_auth) {
- require Carp;
- Carp::croak("The default navigate_authenticated method was called but the default require_auth method has been overwritten - aborting");
- }
- $self->require_auth(1);
-
- return $self->navigate;
-}
-
-sub require_auth {
- my $self = shift;
- $self->{'require_auth'} = shift if @_ == 1 && (! defined($_[0]) || ref($_[0]) || $_[0] =~ /^[01]$/);
- return $self->{'require_auth'} || 0;
-}
-
-sub is_authed { shift->auth_data }
-
-sub auth_data {
- my $self = shift;
- $self->{'auth_data'} = shift if @_ == 1;
- return $self->{'auth_data'};
-}
-
-sub get_valid_auth {
- my $self = shift;
- return 1 if $self->is_authed;
-
- my $args = $self->auth_args;
-
- ### allow passed in args
- if (my $extra = shift) {
- $args = {%$args, %$extra};
- }
-
- ### augment the args with sensible defaults
- $args->{'script_name'} ||= $self->script_name;
- $args->{'path_info'} ||= $self->path_info;
- $args->{'cgix'} ||= $self->cgix;
- $args->{'form'} ||= $self->form;
- $args->{'cookies'} ||= $self->cookies;
- $args->{'js_uri_path'} ||= $self->js_uri_path;
- $args->{'get_pass_by_user'} ||= sub { my ($auth, $user) = @_; $self->get_pass_by_user($user, $auth) };
- $args->{'verify_user'} ||= sub { my ($auth, $user) = @_; $self->verify_user( $user, $auth) };
- $args->{'cleanup_user'} ||= sub { my ($auth, $user) = @_; $self->cleanup_user( $user, $auth) };
- $args->{'login_print'} ||= sub {
- my ($auth, $template, $hash) = @_;
- my $step = $self->login_step;
- my $hash_base = $self->run_hook('hash_base', $step) || {};
- my $hash_comm = $self->run_hook('hash_common', $step) || {};
- my $hash_swap = $self->run_hook('hash_swap', $step) || {};
- my $swap = {%$hash_base, %$hash_comm, %$hash_swap, %$hash};
-
- my $out = $self->run_hook('swap_template', $step, $template, $swap);
- $self->run_hook('fill_template', $step, \$out, $hash);
- $self->run_hook('print_out', $step, \$out);
- };
-
- require CGI::Ex::Auth;
- my $obj = CGI::Ex::Auth->new($args);
- my $resp = $obj->get_valid_auth;
-
- my $data = $obj->last_auth_data;
- delete $data->{'real_pass'} if defined $data; # data may be defined but false
- $self->auth_data($data); # failed authentication may still have auth_data
-
- return ($resp && $data) ? 1 : 0;
-}
-
-sub auth_args { {} }
-
-sub get_pass_by_user { die "get_pass_by_user is a virtual method and needs to be overridden for authentication to work" }
-sub cleanup_user { my ($self, $user) = @_; $user }
-sub verify_user { 1 }
-
-###----------------------------------------------------------------###
-### a few standard base accessors
-
-sub script_name { shift->{'script_name'} || $ENV{'SCRIPT_NAME'} || $0 }
-
-sub path_info { shift->{'path_info'} || $ENV{'PATH_INFO'} || '' }
-
-sub cgix {
- my $self = shift;
- $self->{'cgix'} = shift if @_ == 1;
- return $self->{'cgix'} ||= do {
- require CGI::Ex;
- CGI::Ex->new; # return of the do
- };
-}
-
-sub form {
- my $self = shift;
- $self->{'form'} = shift if @_ == 1;
- return $self->{'form'} ||= $self->cgix->get_form;
-}
-
-sub cookies {
- my $self = shift;
- $self->{'cookies'} = shift if @_ == 1;
- return $self->{'cookies'} ||= $self->cgix->get_cookies;
-}
-
-sub vob {
- my $self = shift;
- $self->{'vob'} = shift if @_ == 1;
- return $self->{'vob'} ||= do {
- require CGI::Ex::Validate;
- my $args = $self->vob_args;
- $args->{'cgix'} ||= $self->cgix;
- CGI::Ex::Validate->new($self->vob_args); # return of the do
- };
-}
-
-sub vob_args { shift->{'vob_args'} || {} }
-
-sub vob_path {
- my $self = shift;
- return $self->{'vob_path'} || $self->template_path;
-}
-
-### provide a place for placing variables
-sub stash {
- my $self = shift;
- return $self->{'stash'} ||= {};
-}
-
-sub clear_app {
- my $self = shift;
-
- delete @{ $self }{qw(
- cgix
- vob
- form
- cookies
- stash
- path
- path_i
- history
- _morph_lineage_start_index
- _morph_lineage
- hash_errors
- hash_fill
- hash_swap
- hash_common
- )};
-
- return $self;
-}
-
-###----------------------------------------------------------------###
-### default hook implementations
-
-sub path_info_map { }
-
-sub run_step {
- my $self = shift;
- my $step = shift;
-
- ### if the pre_step exists and returns true, exit the nav_loop
- return 1 if $self->run_hook('pre_step', $step);
-
- ### allow for skipping this step (but stay in the nav_loop)
- return 0 if $self->run_hook('skip', $step);
-
- ### see if we have complete valid information for this step
- ### if so, do the next step
- ### if not, get necessary info and print it out
- if ( ! $self->run_hook('prepare', $step)
- || ! $self->run_hook('info_complete', $step)
- || ! $self->run_hook('finalize', $step)) {
-
- ### show the page requesting the information
- $self->run_hook('prepared_print', $step);
-
- ### a hook after the printing process
- $self->run_hook('post_print', $step);
-
- return 1;
- }
-
- ### a hook before end of loop
- ### if the post_step exists and returns true, exit the nav_loop
- return 1 if $self->run_hook('post_step', $step);
-
- ### let the nav_loop continue searching the path
- return 0;
-}
-
-sub refine_path {
- my ($self, $step, $is_at_end) = @_;
- return 0 if ! $is_at_end; # if we aren't at the end of the path, don't do anything
-
- my $next_step = $self->run_hook('next_step', $step) || return 0;
- $self->run_hook('set_ready_validate', $step, 0);
- $self->append_path($next_step);
- return 1;
-}
-
-sub prepared_print {
- my $self = shift;
- my $step = shift;
-
- my $hash_base = $self->run_hook('hash_base', $step) || {};
- my $hash_comm = $self->run_hook('hash_common', $step) || {};
- my $hash_form = $self->run_hook('hash_form', $step) || {};
- my $hash_fill = $self->run_hook('hash_fill', $step) || {};
- my $hash_swap = $self->run_hook('hash_swap', $step) || {};
- my $hash_errs = $self->run_hook('hash_errors', $step) || {};
-
- ### fix up errors
- $hash_errs->{$_} = $self->format_error($hash_errs->{$_})
- foreach keys %$hash_errs;
- $hash_errs->{'has_errors'} = 1 if scalar keys %$hash_errs;
-
- ### layer hashes together
- my $fill = {%$hash_form, %$hash_base, %$hash_comm, %$hash_fill};
- my $swap = {%$hash_form, %$hash_base, %$hash_comm, %$hash_swap, %$hash_errs};
-
- ### run the print hook - passing it the form and fill info
- $self->run_hook('print', $step, $swap, $fill);
-}
-
-sub print {
- my ($self, $step, $swap, $fill) = @_;
- my $file = $self->run_hook('file_print', $step); # get a filename relative to template_path
- my $out = $self->run_hook('swap_template', $step, $file, $swap);
- $self->run_hook('fill_template', $step, \$out, $fill);
- $self->run_hook('print_out', $step, \$out);
-}
-
-sub print_out {
- my ($self, $step, $out) = @_;
-
- $self->cgix->print_content_type($self->mimetype($step), $self->charset($step));
- print ref($out) eq 'SCALAR' ? $$out : $out;
-}
-
-sub mimetype { shift->{'mimetype'} || 'text/html' }
-sub charset { shift->{'charset'} || '' }
-
-sub swap_template {
- my ($self, $step, $file, $swap) = @_;
-
- my $args = $self->run_hook('template_args', $step);
- $args->{'INCLUDE_PATH'} ||= $args->{'include_path'} || $self->template_path;
-
- my $t = $self->template_obj($args);
- my $out = '';
- $t->process($file, $swap, \$out) || die $t->error;
-
- return $out;
-}
-
-sub template_path {
- my $self = shift;
- return $self->{'template_path'} || $self->base_dir_abs;
-}
-
-sub template_args { shift->{'template_args'} || {} }
-
-sub template_obj {
- my ($self, $args) = @_;
-
- require CGI::Ex::Template;
- my $t = CGI::Ex::Template->new($args);
-}
-
-sub fill_template {
- my ($self, $step, $outref, $fill) = @_;
-
- return if ! $fill;
-
- my $args = $self->run_hook('fill_args', $step);
- local $args->{'text'} = $outref;
- local $args->{'form'} = $fill;
-
- require CGI::Ex::Fill;
- CGI::Ex::Fill::fill($args);