Description

This is a simple CGI (Common Gateway Interface) script using a dispatch hash of actions to subroutine references for logic flow and user feedback/verification. Though only a basic demonstration, its structure is ideal for extremely robust, complex CGIs of any length (even thousands of lines).

Perl was the defacto language of CGI for several years. CGIs can be written in any language that the server side supports or client side languages like JavaScript. Perl may still be the most widely used CGI language but has lost ground to other languages, especially PHP which was created specifically for web scripting. Perl has lost ground to other languages because perl CGIs, being interpreted programs, could not scale well. They had to be compiled each and every time they were executed, dragging servers down as traffic went up. Increasing acceptance of mod_perl has changed perl’s reputation from easy, powerful, but slow, to easy, powerful, and fast.

The dispatch based code here is an example of a programming style for medium to large projects, or projects that may grow arbitrarily. As such, it’s not that short. It’s a bit over 100 lines of code. Small projects can sometimes be coded very compactly. File Viewer has an example of a CGI script that can do quite a bit in less than 10 lines.

#!/usr/bin/perl -T

use strict;
#=====================================================================
#  DECLARATIONS
#=====================================================================
use CGI qw(:standard);

my $DEFAULT           = '_form';
my $DISPLAY_SELECTION = '_selection';
my $VERIFY_SELECTION  = '_verify';

my %DISPATCH = (
                $DEFAULT           => \&splash,
                $DISPLAY_SELECTION => \&display,
                $VERIFY_SELECTION  => \&verify,
                );

my $ACTION = param('action') || $DEFAULT;

my $Url = CGI::url(1); 
#  sometimes it's nice to be ultra clear about where a function is
#  coming from, so we keep the CGI:: though it's not necessary

my @Things = qw( fish Lamborghini Perl keys speakers sneakers Pikachu
                 deinonychus spam );
#=====================================================================
#  PROGRAM PROPER
#=====================================================================

print header();  # functional CGI, skipping the OOP interface

print start_html(-title => "Chooser with Dispatch");

print '<div align="center">';       # center the form

if ( exists $DISPATCH{$ACTION} ) {  # a valid action was specified

    $DISPATCH{$ACTION}->();         # execute sub reference, no args

} else {  # altered GET in URL? a non-existent sub was specified

    error("Couldn't understand your request!", 
          "Please back up and try again.");
}
print "</div>";  # close the centering for good HTML

print end_html();

exit 0;
#=====================================================================
#  SUBROUTINES
#=====================================================================
sub splash {

    my ( $note ) = @_; 
    print h1("Make your choice!");
    print status_line( $note || 'Choose as many as you like.' );

    print 
        start_form( -action => $Url ),
        checkbox_group(-name     => 'things',
                       -value    => [ @Things ],
                       -cols     => 3,
                       ),
        br,
        submit('Choose!'),
        hidden(-name     => 'action',
               -value    => $VERIFY_SELECTION,
               -override => 1 ),
        end_form();
}
#=====================================================================
sub verify {

    if ( param('things') ) {  # user made at least 1 choice

#  now we would want to enforce the choices so the user can't fiddle
#  the URL to get choices we don't specifically allow, but for the
#  sake of brevity let's skip it.

           &{ $DISPATCH{$DISPLAY_SELECTION} };

    } else {  # user made no choices

        my $note = 
            "<font color=#AA0000>Please make a selection!</font>";

        &{ $DISPATCH{$DEFAULT} }($note);
    }
}
#=====================================================================
sub display { 

    print h1("You chose...");

    my $result_sentence = serial( param('things') ) . ".";

    print h3( ucfirst $result_sentence );

    print status_line("Please take a moment to read",
                      "our marketing below.");

    print
        start_form( -action => $Url ),
        br,
        submit('Choose again!'),
        hidden(-name     => 'action',
               -value    => $DEFAULT,
               -override => 1 ),
        end_form();

    print br, br;  # couple newlines and let's do a little marketing

    if ( not grep { /Pikachu/ } param('things') ) {

        print "You didn't choose Pikachu but there's still time. ";

        my $query_string = join('&', "things=Pikachu",
                                "action=$DISPLAY_SELECTION");

        print a({-href => $Url . '?' . $query_string},
                'I choose you, Pikachu!');

    } else {

        my $query_string = join('&', 
                                "things=Bulbasaur",
                                "things=Psyduck",
                                "things=Jigglypuff",
                                "things=Articuno",
                                "action=$DISPLAY_SELECTION");
        print 
            "For special customers we offer extra ",
            "selections. You can see them by ",
            a({-href => $Url . '?' . $query_string},
              'clicking here'), 
            '.';
    }

    print 
        br, br,
        i(
          a({-href => '/perl/cgi.html'},
            'Return to code samples')
          );
}
#=====================================================================
sub status_line {

    my $status_message = join(" ", @_);

    return
        table({ -bgcolor     => '#336699',
                -cellpadding => 4,
                -cellspacing => 2,
                -width       => '400' },
              Tr(
                 td({ -align => 'center', 
                      -bgcolor => '#FFFFFF' },
                    $status_message)
                 )
              );
}
#=====================================================================
sub serial(@) {
    join(', ', @_[0..$#_-1]) . 
        (@_>2 ? ',':'' ) . 
            (@_>1 ? (' and ' . $_[-1]) : $_[-1]);
}
#=====================================================================
sub error {

    print
        '<b style="color:#a00;font-size:120%;">', 
        join(' ', @_), '</b>';
    print end_html();
    exit 1;
}

Discussion

Like all CGIs, it needs to be installed with a webserver that allows executables. Feel free to give it a try on your own server (Apache is excellent, free, and will run on almost any computer if you’re looking to set up your own webserver). It’s all standard Perl as long as you have CGI.pm (if you have an older version you might have to change the “use CGI …” from “:standard” to “:all” because “:standard” in older versions does not import the table tags used).

There are many obstacles to good, clean, and readable CGI coding. Most of them have to do with program flow/logic and user feedback/validation. Compounding the problems is the stateless nature of web pages.

Often CGIs become unreadable strings of a dozen if/elsif blocks with all kinds of &&s and ||s testing parameters and controlling flow. A script may need to be run twice before any output is sent to the browser because it must be validated first, otherwise error/feedback messages which were found last would necessarily be printed last, below the fold, where they will never be seen. The CGI can be as frustrating and unpleasant to use as it is to maintain.

The code above shows an approach that solves all these problems (except session management which is definitely non-trivial). This approach is essentially cracking open the same logic of mod_perl script handlers or a module like CGI::Application. It is absolutely the way to go for any CGI that needs to be interactive or bigger than 100 lines. Many of the largest and most trafficked websites use the same style.

The layout of the script allows user feedback and internal script redirection to be easy and easy to follow. The complicated logic trees are gone—folded into modular dispatching of actions and their related subroutines. We keep state with hidden fields; usually only needing one. Any subroutine that requires validation has its logic easily encapsulated in a verify subroutine which either returns with feedback or proceeds to the next step.

Extending the script is as easy as adding a new subroutine. No real logic changes are necessary.

Another prime benefit of this style is the GET requests (with the URL) are made trivially easy and they act the same as the POST. So you won’t get weird behavior and it has a sort of built in security enforcement. You have to consider URL manipulation since you’re using GETs and therefor you’re more likely to keep your script secure.

If you haven’t, try the script so you can see how it easily it mixes submit buttons and hyperlinks for control.

You can see there is no -w switch in the CGI, though the script uses strict as all code meant for production should. For CGIs the -w can fill up your weblogs with “Use of uninitialized value…” or “Ambiguous use of…” Some of these innocuous errors can arise long after you did the script when some small change to a related part of Perl happens. Because of this, I develop the CGI with -w (and usually the -T but that’s too big a discussion to jump into here) and take it out when the script is ship-shape and ready to start using for real. That keeps the sysadmin from carping about the weblogs filling up with megabytes of useless information.