Example

This long example is a CGI script that allows a select set of students to upload assignments and to check grades. It illustrates CGI security, form processing, bluestem, file upload, dbm files, and object-oriented programming.

Note This is just an example. There are ample opportunities for the reader to improve this code. For example, error reporting is minimal. Or there should be a better object orientation throughout (hint: create a Grades class). Or creating a dispatch table that uses function pointers rather than if..then..else structure. And additional funtionality for inserting grades would be useful. Caveat emptor.

#!/usr/local/bin/perl


use CGI;
use IO::File;

#
#-------------Configuration Parameters ----------------------
#
## These would be better off in some separate config file,
## and read in with 'do file'
##
    $Student::DIR     = '/homes/home1/bobg/grades'; #directory for files
    $Student::GRADES  = 'grades';		    # dbm file
    $A_MAX 	      = 10000;		    # Assignments are 10kb max
    %assignments = (			    # Allowed assignments
	a1 => 'Assignment 1',
	a2 => 'Assignment 2',
	a3 => 'Assignment 3',
	a4 => 'Assignment 4',
	a5 => 'Assignment 5',
    );

    @students = qw( moe larry curly bobg);  # Authorized netids
#
#---------------End Configuration------------------------------
#

    $ENV{PATH} = "";        # security
    print_header();	    # Beginning of HTML response

#
# $url is needed for return links in emitted html.
# Note portable treatment, not dependent on current directory
#
    my $url = "https://$ENV{SERVER_NAME}$ENV{SCRIPT_NAME}";

		## untaint netid from ENV
    $ENV{REMOTE_USER} =~ /([\w-]{2,8})/;
    $netid = $1;

    if ( $netid and grep (/^$netid$/, @students) ) {
	$parse = new CGI;	        # Initialize form parsing

		## Dispatch table
	$action = $parse->param('action');
	if ($action eq 'upload') {
	    upload( $netid );		# Allow uploading
	}
	elsif ($action eq 'check') {
	    check_grades( $netid );     # Print grades
	}
	else {
	    input_form();		# Send out initial form
	}
    }
    else {
	$url =~ s#perlwrap/#perlwrap-auth/#;	# Just in case
	print "<h1>BAD, Bad,  bad</h1>\n";
	print "<p>Hey, you didn't use bluestem or you are not authorized!\n";
	print "<a href=\"$url\">Try this.</a>\n";
    }

    print "</body></html>\n";
    exit;

#########################################
sub upload {
    my $netid = shift;

    my $a = $parse->param('assignment');
    $a =~ /(\w+)/;
    $a = $1;   # untainted

	    ## Make sure user doesn't alter form
    unless ( exists($assignments{$a})  ) {
	print "Don't be naughty. Choose a valid assignment.\n";
	return;
    }

    my $fname = $parse->param('filename');
    my $bytes_read = read($fname, $file, $A_MAX);
    if ($bytes_read >= $A_MAX) {
	print "You're assignment is too big\n";
	return;
    }
    if ($bytes_read == 0) {
	print "I couldn't read the uploaded file\n";
	return;
    }
    $file =~ /^(.*)$/s;     ## Note anchors and multiline treatment.
    $file = $1;	    	    ## Untainted.  Is this a security risk?

    $s = new Student ($netid);
    $s->add($a, $file);
}

#########################################
sub check_grades {
    my $netid = shift;

    my $s = new Student ($netid);
    my $g = $s->list;

    print "<table>\n<tr><th>Assignment</th><th>Date</th><th>Grade</th>\n";
    foreach my $a ( @$g ) {
	print "<tr>";
	foreach my $e ( @$a ) {
	    print "<td>$e</td>";
	}
	print "</tr>\n";
    }
    print "</table>\n";
}



#################################################3
sub input_form {
    print <<EOF;
<h1>Dr. Bob's Grades</h1>
<p>
Check your grades or upload a new assignment.
But hey! no cheating.
<hr>
<a href="$url?action=check">
Check your current grades</a>
<hr>
Upload a new assignment. 
<form method=post enctype="multipart/form-data" action="$url">
Assignment:
<input type=hidden name=action value=upload>
<select name=assignment size=1>
<option value=choose>Choose Assignment
EOF

    foreach my $k (sort keys %assignments) {
	print "<option value=$k>$assignments{$k}\n";
    }

    print <<EOF;
</select>
<br>
Local File:
<input type=file name=filename size=15>
<br>
<input type=submit value="Submit assignment">
</form>
EOF
}

#######################################
sub print_header {
    print <<EOF;
Content-type: text/html

<html>
<head><title>CGI Example</title></head>
<body bgcolor=#FFFFFF>
EOF
}

########################################
########################################
## Define class "Student" here
##

package Student;
use Fcntl qw(:flock);    ## Note 'use' must be inside package
use DB_File;

########################################
## Create a new object, and populate it
## from DB file if possible
##
sub new {
    my $class = shift;
    my $netid = shift;
    my $self = bless {netid=>$netid}, $class;
    my %students;

    my $glist = tie %students, 'DB_File', "$DIR/$GRADES", O_RDONLY, 0600;
    return $self unless ($glist);

    my $fd = $glist->fd;
    open (DB, "+<&=$fd");
    flock(DB, LOCK_SH); 	    ## lock for reading
    my $entry = $students{$netid};
    flock(DB, LOCK_UN); 	    ## unlock
    untie %glist;
    undef $glist;
    close DB;

	    ## Parse record and populate object
    my @items = split(/!/, $entry);
    foreach my $item (@items) {
	my ($a, $d, $g) = split(/;/, $item);
	$self->{$a} = {date=>$d, grade=>$g};
    }
    return $self;
}

#############################################
## Add new assignment to disk, DB file, and object
##
sub add {
    my ($self, $a, $file) = @_;

    my %students;
    if (exists ($self->{$a}) ) {
	print "You already submitted that assignment\n";
	return;
    }

	    ## Write assignment file to disk
    if (-e "$DIR/$self->{netid}.$a" ) {
	print "Internal error.\n";  
	print "The assignment file exists, but the record does not.\n";
	return;
    }
    open (F, ">$DIR/$self->{netid}.$a") 
			    or print "Can't open $DIR/$self->{netid}.$a\n";
    flock(F, LOCK_EX);     ## lock for writing
    print F $file;
    flock(F, LOCK_UN);     ## unlock 
    close F;

	    ## update DB file
    my $date = `/usr/bin/date`;
    chomp $date;
    $self->{$a} = {date=>$date, grade=>""};
    my $glist = tie %students, 'DB_File', "$DIR/$GRADES", O_CREAT|O_RDWR, 0600;
    my $fd = $glist->fd;
    open (DB, "+<&=$fd");
    flock(DB, LOCK_EX);     	    ## lock for writing
    $students{$self->{netid}} .= "!$a;$date;";
    $glist->sync;	    	    ## flush buffer
    flock(DB, LOCK_UN);     	    ## unlock
    undef $glist;           	    ## includes closing DB
    untie %glist;

    print "You've uploaded $main::assignments{$a}\n";
}

###############################################
## Return list of assignments and grades
##
sub list {
    my $self = shift;
    my @result = ();	# Initialize in case called many times

    foreach $a (sort keys %$self) {
	next if ($a eq 'netid');     # Clunky. Should have Grades class.
	push (@result, [ $a, $self->{$a}{date}, $self->{$a}{grade} ] );
    }
    return \@result;
}