File Coverage

blib/lib/CGI/Builder.pm

Criterion	Covered	Total	%
statement	140	150	93.3
branch	43	60	71.6
condition	16	33	48.4
subroutine	34	38	89.4
pod	11	11	100.0
total	244	292	83.5

package CGI::Builder ;
$VERSION = 1.36 ;
use strict ;

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

; use 5.006_001
; use Carp
; $Carp::Internal{+__PACKAGE__}++
; $Carp::Internal{__PACKAGE__.'::_'}++
; use IO::Util
; use Class::Util
; use warnings::register

; my @phase
; BEGIN
   { @phase  = qw | CB_INIT
                    GET_PAGE
                    PRE_PROCESS
                    SWITCH_HANDLER
                    PRE_PAGE
                    PAGE_HANDLER
                    FIXUP
                    RESPONSE
                    REDIR
                    CLEANUP
                  |
   ; no strict 'refs'
   ; foreach my $i (0..$#phase)
      { *{$phase[$i]} = sub(){$i}
      }
   }

; sub phase
   { $phase[$_[1]||$_[0]->PHASE]
   }

; sub capture
   { my ($s, $h, @args) =  @_
   ; IO::Util::capture{ $s->$h(@args) }
   }

; sub import
   { my ($cbb, $CB, @ext) = (scalar caller, @_)
   ; Class::Util::load for @ext
   ; no strict 'refs'
   ; foreach my $c (reverse @_)
      { push @{$cbb.'::ISA'}, $c unless $cbb->isa($c)
      }
   ; $cbb->isa('Apache::CGI::Builder') && $Apache::CGI::Builder::usage
     && carp $Apache::CGI::Builder::usage
   ; my $sub = sub
                { +{ map
                      { my $h = $_
                      ; my @op = grep
                                  { defined &{$_.'::OH_'.$h}
                                  }
                                  $h =~ /up$/   # ;-)
                                  ? reverse ($CB, @ext, $cbb)
                                  :         ($CB, @ext, $cbb)
                      ; @op ? ($h => \@op) : ()
                      }
                      qw| init pre_process pre_page fixup cleanup |
                   }
                }
   ; eval qq
      ! package $cbb
      ; use Class::groups
          { name    => 'overrun_handler_map'
          , default => \$sub
          }
      ; *import = sub{} unless defined &import
      !
   }

; my $exec = \&CGI::Builder::_::exec

; sub CGI::Builder::_::exec
   { my $s = shift
   ; my $h = shift
   ; Class::Util::gather { $s->$_(@_) } '&OH_'.$h
     , $s->overrun_handler_map($h)
   }

; use Class::constr
  ( { init      => \&CGI::Builder::_::init
    , no_strict => 1
    }
  )

; sub CGI::Builder::_::init
   { my $s = shift
   ; local $SIG{__DIE__} = sub{$s->die_handler(@_)}
   ; $s->$exec('init', @_)
   }

; use Class::groups  qw | overrun_handler_map
                          switch_handler_map
                          page_handler_map
                        |
; use Object::groups qw | param
                          header
                          page_error
                        |
; use Class::props
  ( { name       => 'no_page_content_status'
    , default    => '204 No Content'
    }
  )

; use Object::props
  ( { name       => 'PHASE'
    , default    => CB_INIT
    , allowed    => qr/^CGI::Builder/  # only settable from CBF
    }
  , { name       => 'cgi_page_param'
    , default    => 'p'
    }
  , { name       => 'cgi'
    , default    => sub{ shift()->cgi_new }
    }
  , { name       => 'page_name'
    , default    => 'index'
    }
  , { name       => 'requested_page'
    , allowed    => qw/^CGI::Builder::process$/
    }
  , { name       => 'page_path'
    , default    => './tm'
    , no_strict  => 1    # doesn't croak if ./tm is not a directory
    , validation => sub { -d or croak "'$_' is not a directory, died" }
    }
  , { name       => [ qw| page_content page_suffix | ]
    , default    => ''
    }
  , 'dont_send_header'
  )

; our $AUTOLOAD
; sub AUTOLOAD : lvalue              # param AUTOLOADING
   { (my $n = $AUTOLOAD) =~ s/.*://
   ; carp qq(Use of unprefixed autoloaded parameter "$n". )
        . qq(Autoloaded parameters should start with 'my_' or '_')
     if warnings::enabled && $n !~ /^(?:my)?_/
   ; @_ == 2
     ? ( $_[0]{param}{$n} = $_[1] )
     :   $_[0]{param}{$n}
   }

; sub DESTROY {}

; sub cgi_new
   { require CGI
   ; CGI->new
   }

; sub process
   { my ($s, $p) = @_
   ; local $SIG{__DIE__} = sub{$s->die_handler(@_)}
   ; $s->PHASE(GET_PAGE)
   ; if ( defined $p && length $p )
      { $s->requested_page($p)
      ; $s->page_name($p)
      }
     else
      { $s->requested_page( $s->get_page_name() )
      }
   ; if ($s->PHASE < PRE_PROCESS)
      { $s->PHASE(PRE_PROCESS)
      ; $s->$exec('pre_process')
      }
   ; if ($s->PHASE < SWITCH_HANDLER)
      { $s->switch_to( $s->page_name )
      }
   ; if ($s->PHASE < FIXUP)
      { $s->PHASE(FIXUP)
      ; $s->$exec('fixup')
      }
   ; if ($s->PHASE < RESPONSE)
      { $s->PHASE(RESPONSE)
      ; my $has_content = $s->page_content_check
      ; $s->header( -status => $s->no_page_content_status )
            unless $has_content || defined $s->header->{-status}
      ; $s->send_header() unless $s->dont_send_header
      ; $s->send_content() if $has_content
      }
   ; $s->PHASE(CLEANUP)
   ; $s->$exec('cleanup') # done however
   }

; sub switch_to
   { my ($s, $p) = splice @_, 0, 2
   ; $s->PHASE < PRE_PROCESS && croak 'Too early to call switch_to(), died'
   ; $s->PHASE > FIXUP       && croak 'Too late to call switch_to(), died'
   ; defined $p && length $p || croak 'No page_name name passed, died'
   ; $s->page_name($p)
   ; $s->PHASE(SWITCH_HANDLER)
   ; my $shm = $s->switch_handler_map
   ; my $SH  = $$shm{$p} || $s->can("SH_$p")
   ; $s->$SH(@_) if $SH
   ; if ($s->PHASE < PRE_PAGE)
      { $s->PHASE(PRE_PAGE)
      ; $s->$exec('pre_page')
      }
   ; if ($s->PHASE < PAGE_HANDLER)
      { $s->PHASE(PAGE_HANDLER)
      ; my $phm = $s->page_handler_map
      ; my $PH  =  $$phm{$p}        || $s->can("PH_$p")
                || ! $s->page_content_check
                && ($$phm{AUTOLOAD} || $s->can('PH_AUTOLOAD'))
      ; $s->$PH(@_) if $PH
      }
   }

; sub get_page_name
   { my $s = shift
   ; my $p = $s->cgi->param($s->cgi_page_param)
   ; $s->page_name($p) if defined($p) && length($p)
   }

; sub page_content_check
   { length $_[0]->page_content
   }

; sub send_header
   { print $_[0]->cgi->header( %{$_[0]->header} )
   }

; sub send_content
   { my $pc = $_[0]->page_content
   ; if ( ref $pc eq 'CODE' )
      { $_[0]->$pc
      }
     elsif ( ref $pc eq 'SCALAR' )
      { print $$pc
      }
     elsif ( not ref $pc )
      { print $pc
      }
   }

; sub redirect
   { my ($s, $url) = @_
   ; $s->PHASE < GET_PAGE        && croak 'Too early to call redirect(), died'
   ; $s->PHASE > RESPONSE        && croak 'Too late to call redirect(), died'
   ; defined $url && length $url || croak 'No URL passed, died'
   ; $s->PHASE(REDIR)
   ; $s->header(-url => $url)
   ; print $s->cgi->redirect( %{$s->header} )
   }

; sub die_handler
   { my ( $s, $msg ) = @_
   ; for ( my $i = 1
         ; my $sub = (caller($i))[3]
         ; $i++
         )
      { die $msg if $sub eq '(eval)' && (caller($i+1))[3]
      }
   ; die sprintf 'Fatal error in phase %s for page "%s": %s'
               , $s->phase
               , $s->page_name
               , $msg
   }

; 1

__END__