CGI-Auth-Basic

 view release on metacpan or  search on metacpan

lib/CGI/Auth/Basic.pm  view on Meta::CPAN


# For form errors
sub _error {
   my $self  = shift;
   my $error = shift;
   return $self->_screen(
            content => qq~<span class="error">$error</span>~,
            title   => $self->_get_title('error'),
         );
}

sub _screen {
   my($self, @args) = @_;
   my %p      = @args % 2 ? () : @args;
   my @cookie = $p{cookie} ? (-cookie => $p{cookie}) : ();

   my $refresh_url;
   if ( $self->{hidden_q} ) {
      $refresh_url = "$self->{program}?$self->{hidden_q}";
   }
   else {
      my @qs;
      foreach my $p ( $self->{cgi}->param ) {
         next if $p eq $self->{logoff_param}
              || $p eq $self->{changep_param}
              || $p eq $self->{cookie_id}
              || $p eq $self->{cookie_id} . '_new';
         push @qs, $p . q{=} . $self->{cgi}->param( $p );
      }
      my $url = $self->{program};
      if ( @qs ) {
         $url =~ s{\?}{}xmsg;
         $url .= q{?} . join q{&}, @qs;
      }
      $refresh_url = $url;
   }

   # Set template vars
   $self->{page_logoff_link}    = $self->logoff_link;
   $self->{page_content}        = $p{content};
   $self->{page_title}          = $p{title};
   $self->{page_refresh}        = $p{forward}
                                ? qq~<meta http-equiv="refresh" content="0; url=$refresh_url">~
                                : EMPTY_STRING
                                ;
   $self->{page_inline_refresh} = $p{forward}
                                ? qq~<a href="$refresh_url">&#187;</a>~
                                : EMPTY_STRING
                                ;
   my $out = $self->_compile_template('screen') || <<"MAIN_TEMPLATE";
<html>
   <head>
      $self->{page_refresh}
      <title>$self->{page_title}</title>
      <style>
         body       {font-family: Verdana, sans; font-size: 10pt}
         td         {font-family: Verdana, sans; font-size: 10pt}
         .darktable  { background: black;   }
         .lighttable { background: white;   }
         .titletable { background: #dedede; }
         .error      { color = red; font-weight: bold}
         .small      { font-size: 8pt}
      </style>
   </head>
   <body>
      $self->{'page_logoff_link'}
      $self->{'page_content'}
      $self->{'page_inline_refresh'}
   </body>
</html>
MAIN_TEMPLATE
   my $header = $self->{cgi}->header(
                  -charset => $self->{http_charset},
                  @cookie
               );
   my $pok = print $header . $out;
   return $self->_exit_program;
}

sub fatal_header {
   my($self, @args) = @_;
   $FATAL_HEADER = shift @args if @args;
   return $FATAL_HEADER || qq~Content-Type: text/html; charset=ISO-8859-1\n\n~;
}

# Trap deadly errors
sub _fatal {
   my $self      = shift;
   my $error     = shift || EMPTY_STRING;
   my @rep       = caller 0;
   my @caller    = caller 1;
      $rep[1]    =~ s{.*[\\/]}{}xms;
      $caller[1] =~ s{.*[\\/]}{}xms;
   my $class     = ref $self;
   my $version   = $self->VERSION;
   my $fatal     = $self->fatal_header;
      $fatal    .= <<"FATAL";
<html>
   <head>
      <title>Flawless Victory</title>
      <style>
         body  {font-family: Verdana, sans; font-size: 11pt}
         .error { color : red }
         .finfo { color : gray}
      </style>
   </head>
   <body>
      <h1>$class $version - Fatal Error</h1>
      <span class="error">$error</span> 
      <br>
      <br>
      <span class="finfo">Program terminated at <b>$caller[1]</b>
      (package <b>$caller[0]</b>) line <b>$caller[2]</b>.
      <br>
      Error occurred in <b>$rep[0]</b> line <b>$rep[2]</b>.
      </span>
   </body>
</html>
FATAL
   my $pok = print $fatal;
   return $self->_exit_program;



( run in 0.852 second using v1.01-cache-2.11-cpan-39bf76dae61 )