File Coverage

blib/lib/CGI/Screen.pm

Criterion	Covered	Total	%
statement	73	163	44.7
branch	18	58	31.0
condition	14	45	31.1
subroutine	12	32	37.5
pod	4	18	22.2
total	121	316	38.2

#                              -*- Mode: Perl -*-
# $Basename: Screen.pm $
# $Revision: 1.27 $
# Author          : Ulrich Pfeifer
# Created On      : Thu Dec 18 09:26:31 1997
# Last Modified By: Ulrich Pfeifer
# Last Modified On: Fri Feb  5 17:05:16 1999
# Language        : CPerl
#
# (C) Copyright 1997, Ulrich Pfeifer
#

package CGI::Screen;
use CGI;
use strict;
use vars qw($VERSION $AUTOLOAD);

# $Format: "$\VERSION = sprintf '%5.3f', ($ProjectMajorVersion$ * 100 + ($ProjectMinorVersion$-1))/1000;"$
$VERSION = sprintf '%5.3f', (1 * 100 + (22))/1000;

sub _set_screen {
  my ($self, $screen, $title)  = @_;
  my $func;

  if      ($self->{screen_func} = $self->can($screen . '_data'  )) {
    $self->{no_headers}  = 1;
  } elsif ($self->{screen_func} = $self->can($screen . '_screen')) {
  } else {
    warn "No such screen: '$screen'\n";
    return;
  }
  $self->{screen_name}  = $screen;
  $self->{screen_title} = $title || $self->param('screen_'.$screen);

  # We keep track of the screens here in order to be able to jump back
  my @screen_last_name  = $self->param('screen_last_name');
  my @screen_last_title = $self->param('screen_last_title');
  if ( @screen_last_name > 1 and $screen_last_name[-2] eq $screen) {
    # User did hit a 'back' button
    pop @screen_last_name; pop @screen_last_title;
  } elsif (not $self->{dont_cut_loops} and
           @screen_last_name and $screen_last_name[-1] eq $screen) {
    # Do nothing. We did jump to the same screen again
  } else {
    while (@screen_last_name > 7) {shift @screen_last_name; shift @screen_last_title;}
    push @screen_last_name,  $self->{screen_name};
    push @screen_last_title, $self->{screen_title};
  }
  $self->param('screen_last_name',  @screen_last_name);
  $self->param('screen_last_title', @screen_last_title);
  $self->{screen_last_name}  = $screen_last_name[-2];
  $self->{screen_last_title} = $screen_last_title[-2];

  $self;                        # return true
}

sub last_screen {
  my $self = shift;

  if (wantarray) {
    ($self->{screen_last_name}, $self->{screen_last_title}||$self->{screen_last_name});
  } else {
    $self->{screen_last_name};
  }
}

sub _check_auth_user {
  my $query  = shift;
  my $user   = $query->param('screen_user')   or return;
  my $passwd = $query->param('screen_passwd') or return;


  $query->check_auth_user($user, $passwd);
}
my $D;

sub new {
  my $type  = shift;
  my $self  = {};

  if (@_>1 and $_[0] eq '-screen') { # grab our parameters
    shift; $self = shift;
  }

  $self->{cgi} = CGI->new(@_);

  bless $self, $type; $D = $self;

  # Poor man's Authentication.
  if (my $func = $self->can('check_auth_ip')) {
    &$func($self, $ENV{REMOTE_ADDR})
      or $self->_set_screen('login', 'Will not serve your ip address')
        && return $self;           # shortcut the rest
  }
  if (my $func = $self->can('check_auth_user')) {
    $self->_check_auth_user
      or $self->_set_screen('login', 'Need user id and password')
        && return $self;           # shortcut the rest
  }

  for ($self->{cgi}->param) {      # hunt for the target screen
    if (/^screen_function(.*)$/) {
      if ($self->_set_screen($1)) {
        $self->{cgi}->delete($_);
        return $self;              # shortcut the rest
      }
    }
  }

  # provide a default screen
  $self->_set_screen('main', '');
}

sub import {
  my $pkg = shift;
  my ($callpack, $callfile, $callline) = caller;
  my %old;

  package CGI::Screen::import;

  for my $sym (keys %CGI::Screen::import) {
    $old{$sym}++;# if defined &$sym;
  }

  CGI->import(@_);

  no strict 'refs';
  for my $sym (keys %CGI::Screen::import::) {
    if (not exists $old{$sym} and
        not defined &{"CGI::Screen::${sym}"}) {
      next if $sym =~ /^(BEGIN|DESTROY|END)$/;
      *{"${callpack}::$sym"} = sub {
        my $self = $D;
        if (
            ref $_[0] and
            eval { $_[0]->isa('CGI::Screen') }
           ) {
          $self = shift;
        }
        if (@_ and $_[0] eq '-name') {
          $self->{passed}->{$_[1]} = 1;
        }
        #warn "CGI $sym(@_)\n";
        &{"CGI::$sym"}(@_);
      }
    }
  }

}

sub AUTOLOAD {
  my $func = $AUTOLOAD; $func =~ s/.*:://;
  my $self = $_[0];

  if (my $code = $self->{cgi}->can($func)) {
    no strict 'refs';
    *$func = sub {
      my $self = shift;

      if (@_>1 and $_[0] eq '-name') {
        $self->{passed}->{$_[1]} = 1;
      }
      #warn "AL $func(@_)\n";
      &$code($self->{cgi}, @_);
    };
    goto &$func;
  } else {                      # Function not yet AUTOLOADED in CGI.pm
    my $self = shift;

    if (@_>1 and $_[0] eq '-name') {
      $self->{passed}->{$_[1]} = 1;
    }
    $self->{cgi}->$func(@_);    # Force autoloading in CGI.pm
  }
}

sub _call {
  my ($query, $method)  = @_;

  my $func = ref($method) eq 'CODE' ? $method : $query->can($method)
    or die "No method '$method' defined";

  @_ = ($query, $query->{screen_name}, $query->{screen_title});

  goto &$func;
}

sub dispatch {
  my $query  = shift;
  my $func;

  $query->_call('prologue') unless $query->{no_headers};
  $query->_call($query->{screen_func});
  $query->_call('epilogue') unless $query->{no_headers};
}

sub application { 'CGI::Screen Test' }
sub default_title { 'Welcome' }

sub title {
  my ($query, $screen, $title)  = @_;

  $query->application . ': ' . ($title || $screen || $query->default_title);
}

sub headline {
  my $query  = shift;

  $query->h1($query->title(@_));
}

sub prologue {
  my $query  = shift;
  my $screen = $query->{'screen_name'};
  my $title  = $query->{'screen_title'} || $query->default_title;
  print
    $query->header    ('-type'  => 'text/html', -expires => '+10s'),
    $query->start_html('-title' => $query->title($screen, $title)),
    $query->_call('headline'),
    $query->start_form
      ;
}

sub trailer {''}

sub epilogue {
  my $query  = shift;

  print
    $query->_call('trailer'),
    $query->close_form,
    $query->end_html;
}


sub start_form {
  my $query  = shift;
  my $screen = $query->param('screen');

  $query->{passed} = {};
  $query->startform(-method=>'POST', -action=>$query->url);
}

sub new_form {
  my $query  = shift;
  my $screen = $query->param('screen');

 $query->close_form .
    $query->start_form;
}

sub close_form {
  my $query = shift;
  my $html;

  for my $param ($query->param) {
    next if exists $query->{passed}->{$param};
    $html .= $query->hidden(-name=>$param) if defined $query->param($param);
  }
  $html .= $query->endform;
}

sub goto_screen {
  my ($query, $screen, $name) = @_;

  $query->submit
    (
     -name  => 'screen_function' . $screen,
     -value => $name,
    );
}

sub url_to_screen {
  my ($query, $screen, $title, %parm) = @_;
  my $url = $query->url . '?';
  my $escape = $query->{cgi}->can('escape'); # should have our own
                                             # since CGI does not
                                             # announce this function
                                             # ;-(

  $url .= $escape->('screen_function' . $screen) . '=' . $escape->($title||'');
  for my $param ($query->param) {
    next if exists $parm{$param};
    for my $value ($query->param($param)) {
      $url .=  '&' . $escape->($param) . '=' .
        $escape->($value);
    }
  }

  for my $param (keys %parm) {
    $url .=  '&' . $escape->($param) . '=' . $escape->($parm{$param});
  }

  $url;
}

sub link_to_screen {
  my ($query, $screen, $title, %parm) = @_;

  $query->a({href => $query->url_to_screen($screen, $title, %parm)}, $title);
}

sub login_screen {
  my $query = shift;

  print
    $query->table
      (
       $query->TR($query->td('Login'),
                  $query->td($query->textfield('-name' => 'screen_user')),
                 ),
       $query->TR($query->td('Passwd'),
                  $query->td($query->password_field('-name'=>'screen_passwd')),
                 )
      );
  print
    $query->submit
      (
       -name =>'screen',
       -value=>'login',
      );
}

sub main_screen {
  my $query  = shift;

  print
    $query->p("Users of this module should overwrite this method");
}

package CGI::Screen::Debug;
use vars qw(@ISA);

@ISA = qw(CGI::Screen);

sub prologue {
  my $query = shift;
  my @tab = $query->TR($query->td({colspan => 2}, 'CGI Parameters'));

  $query->SUPER::prologue;

  for ($query->param) {
    next if /^screen_/; # you don't want to know!
    push @tab, $query->TR($query->td($_),
                          $query->td(join ', ', $query->param($_)));
  }
  print $query->table({border => 1}, @tab);
}

1;

__END__