File Coverage

blib/lib/CGI/Application/Plus.pm

Criterion	Covered	Total	%
statement	18	34	52.9
branch	0	14	0.0
condition	0	3	0.0
subroutine	6	7	85.7
pod			n/a
total	24	58	41.3

package CGI::Application::Plus ;
$VERSION = 1.21 ;
use strict ;

# This file uses the "Perlish" coding style
# please read http://perl.4pro.net/perlish_coding_style.html

; use Carp

######### NEW ############

; use Class::constr
      ( { init       => [ qw| cgiapp_init setup | ]
        , no_strict  => 1
        }
      )

######### GROUPS ############

; use Object::groups
      ( { name       => [ qw | param header_props | ]
        , no_strict  => 1
        }
      , { name       => 'run_modes'
        , no_strict  => 1
        , pre_process=> sub
                         { if ( ref $_[1] eq 'ARRAY' )
                            { $_[1] = { map { $_=>$_ } @{$_[1]} }
                            }
                         }
        }
      , { name       => 'qparam'
        , default    => sub
                         { eval{ scalar $_[0]->query->Vars }
                           || croak qq(The query object cannot "Vars", )
                                  . qq(you cannot use the "qparam" )
                                  . qq(property.)
                         }
        }

      )

######### PROPERTIES ############

; use Object::props
      ( { name       => '__STEP'
        , default    => 0
        , allowed    => qr/::run$/
        }
      , { name       => 'mode_param'
        , default    => 'rm'
        }
      , { name       => 'query'
        , default    => sub { shift()->cgiapp_get_query(@_) }
        , no_strict  => 1  # doesn't croak if fetched too late
        , validation => sub
                         { croak qq(Too late to set the query)
                           if $_[0]->__STEP > 0       # just before run
                         ; 1
                         }
        }
      , { name       => 'runmode'
        , default    => 'start'
        , validation => sub
                         { croak qq(Too late to set the run mode)
                           if ( $_[0]->__STEP >= 2     # after prerun
                              && (caller(2))[3] !~ /::_run_runmode$/
                              )
                          ; 1
                          }
        }
      , { name       => 'tmpl_path'
        , default    => './tm'
        , no_strict  => 1    # doesn't croak if ./tm is not a valid path
        , validation => sub { -d or croak qq(Not a valid path) }
        }
      , { name       => 'RM_prefix'
        , default    => 'RM_'
        }
      , { name       => 'header_type'
        , default    => 'header'
        , validation => sub{ /^(header|redirect|none)$/ }
        }
      , { name       => 'page'
        }
      )


######### PARAM AUTOLOAD ############

; our $AUTOLOAD

; sub AUTOLOAD :lvalue                 # Param AUTOLOADING
   { (my $n = $AUTOLOAD) =~ s/.*://
   ; return if $n eq 'DESTROY'
   ; @_ == 2
     ? ( $_[0]{param}{$n} = $_[1] )
     :   $_[0]{param}{$n}
   }

######### OVERRIDE METHODS ############

; BEGIN
   { no strict 'refs'
   ; foreach my $n qw| cgiapp_init
                       cgiapp_prerun
                       cgiapp_postrun
                       teardown
                     |
      { *$n = sub {}
      }

   }

; sub cgiapp_get_query
   { require CGI
   ; CGI->new()
   }

; sub setup
   { $_[0]->run_modes( start => \&dump_html )
   }

######### METHODS ############


; sub run
   { my ($s, $RM) = @_
   ; $s->__STEP = 1
   ; unless ( defined $RM && length $RM )        # no RM from script
      { $RM = ref $s->mode_param eq 'CODE'
              ? $s->mode_param->($s)             # RM from code ref
              : $s->query->param($s->mode_param) # RM from query
      }
   ; unless ( defined $RM && length $RM )        # no RM yet
      { $RM = $s->runmode                        # RM from default
      }
     else
      { $s->runmode = $RM                        # shitch RM
      }
   ; $s->__STEP = 2
   ; $s->cgiapp_prerun( $RM )          # passed just for full compatibility
   ; $s->__STEP = 3
   ; $s->_run_runmode( $RM )
                 if $RM eq $s->runmode # if unchanged by prerun
   ; $s->__STEP = 4
   ; $s->page = \ ( my $p = $s->page )
                unless ref $s->page
   ; $s->cgiapp_postrun( $s->page )    # passed just for compatibility
   ; my $output = $s->_send()
   ; $s->teardown()
   ; $output
   }

; *switch_to = sub{shift()->_run_runmode(@_)}

; sub _run_runmode         # __STEP must be 2 or 3 to run this
   { my ($s, $RM, @args) = @_
   ; $s->__STEP < 2 && croak qq(Too early to call this method)
   ; $s->__STEP > 3 && croak qq(Too late to call this method)
   ; defined $RM && length $RM || croak qq(No run mode passed)
   ; $s->runmode = $RM    # switch RM allowed just from here
   ; my $rm = $s->run_modes
   ; my $runmethod = $$rm{$RM}
                   || $s->can($s->RM_prefix.$RM) && $s->RM_prefix.$RM
                   || ($$rm{AUTOLOAD} && ++ my $al && $$rm{AUTOLOAD})
   ; $^W && $al && carp qq(No run-method found for run mode "${\$s->runmode}" )
                      . qq(using run mode "AUTOLOAD")
   ; my $page
   ; if ( $runmethod )
      { unshift @args, $RM if $al
      ; $page = $s->can($runmethod)
                ? $s->$runmethod( @args )
                : eval{ $s->$runmethod( @args ) }
      ; $@ && croak qq(Error executing run mode "${\$s->runmode}": $@)
      }
   ; unless ( defined $s->page )
      { $runmethod
        || croak qq(No run-method found for run mode "${\$s->runmode}")
      ; $s->page = $page
      }
   }

; sub _send
   { my $s = shift
   ; $s->start_capture if $ENV{CGI_APP_RETURN_ONLY}     # testing only
   ; print $s->query->${\$s->header_type}( %{$s->header_props} )
           unless $s->header_type eq 'none'
   ; my $p = $s->page
   ; if ( ref $p eq 'CODE' )
      { eval { $p->($s) }
      ; $@ && croak qq(Error executing the code referenced )
                  . qq(by run mode "${\$s->runmode}": $@)
      }
     elsif ( ref $p eq 'SCALAR' )
      { print $$p
      }
     elsif ( not ref $p )
      { print $p
      }
   ; $s->stop_capture if $ENV{CGI_APP_RETURN_ONLY}   # testing only
   }

######### OLD CGI APP ############

; BEGIN
   { # useless but aliased for compatibility (support OO overriding)
   ; *QUERY               = sub{shift()->query(@_)}
   ; *PARAMS              = sub{shift()->param(@_)}
   ; *TMPL_PATH           = sub{shift()->tmpl_path(@_)}
   ; *start_mode
   = *get_current_runmode = sub{shift()->runmode(@_)}
   ; *prerun_mode         = sub{shift()->_run_runmode(@_)}
   ; *header_add          = sub{shift()->header_props(@_)}
   }

######### JUST FOR TEST ############

; BEGIN  # block needed just to allow testing
   { no strict 'refs'
   ; foreach my $n qw| dump dump_html load_tmpl |
      { *$n = sub
               { require CGI::Application::Plus::Util
               ; goto &{"CGI::Application::Plus::Util::$n"}
               }
      }
   }

######### CAPTURE ############

; my $output
; local *H

; sub start_capture  # starts to capture output
   { $output = ''
   ; *H = '*'.select()
   ; tie *H , 'CGI::Application::Plus::Capt' , \ $output
   }

; sub stop_capture   # returns captured output
   { untie *H
   ; $output
   }

; package CGI::Application::Plus::Capt

; sub TIEHANDLE
   { bless \@_, shift
   }

; sub PRINT
   { my $s = shift
   ; ${$$s[0]} .= join $,||'', map{defined $_? $_ : ''} @_
   }

; 1

__END__