#!/usr/local/bin/perl # (The above line tells the system where the perl # language program resides on this computer.) #------------------------------------------------ # File: form2.cgi # Function: Exemplary Web Form # URL: http://www.cclabs.missouri.edu/things # /instruction/perl/demo/form2.cgi # Author: Greg Johnson, # Original: 25 Sep 1996 gkj # # Outline: # Initialize output and some variables. # If there was no input data, then # call subroutine show_form. # Otherwise (there was input data), # call subroutine interpret_inputs. # Exit. # Subroutine interpret_inputs validates the # inputs, and if they're ok, calls subroutine # write_results to append results to a disk file. # Comments: # form2.cgi differs from form1.cgi in saving the # results to disk rather than sending them by email. # form2.cgi requires the "Apache" Web server such # as MU's SHOWME and SGI systems use, or an equivalent # server to allow secure writing of files. #------------------------------------------------ # The First Thing to do in almost any Perl CGI Script: open(STDERR,'>&STDOUT'); $| = 1; # This causes error messages to display with # standard output, as soon as they occur. # Otherwise CGI-run errors display to the # web server error log, which may not be # easy to access. # The Second Thing to do in almost any Perl CGI Script: print "Content-type: text/html\n\n"; # Every browser expects a header such as this. # If we delay sending the header, and we make an # error, then this error would be the first # thing to print, as a "malformed header". # Now we can do our intended tasks. # Identify the file where we will save results. # When possible use the "tilde" login-home convention. # $savefile= '~ccgreg/form2.data'; # This is a demo, so we'll output to a temporary file $savefile= "/tmp/form2.uid$>.data"; $server=$ENV{'SERVER_NAME'}; $script=$ENV{'SCRIPT_NAME'}; # The Web Server passes several items # via environment variables $ENV{}. # Access external programs: require "cgi-lib.pl" || die "Can't find cgi-lib.pl $! "; # "require" includes the indicated file, searching # the same directory as this program file (form2.cgi) # and certain system directories. # File "cgi-lib.pl" contains the &ReadParse subroutine # and some other subroutines. You can get cgi-lib.pl # from: http://www.bio.cam.ac.uk/cgi-lib # Call the &ReadParse subroutine to try to read # data from the web form. # The call evaluates as "true" if there was input. if ( &ReadParse(*input) ) { &interpret_inputs; # There was input } else { &show_form; # No input } exit; #------------------------------------------------ # The subroutines follow: #------------------------------------------------ sub show_form { # Subroutine sub_form displays a blank form. # First, echo the URL http://servername:port/path # Did we use other than the default http port 80? $port = $ENV{'SERVER_PORT'}; if ($port eq '80' || $port eq '') { $sport = ''; } else { $sport = ':' . $port; } # Now, print the HTML for the blank form: print <Hello

Hello!

from http://$server$sport$script

to $ENV{'REMOTE_HOST'}

Full Email Address... 
Family Name.......... 
Given Name........... 
Title................ 
Comments............. 
Press to submit information, or to clear fields.
ThatsAll # We used
 to align fields for 
	# simplicity and because a few 
	# browsers still don't grok tables.

# Let's finish with an intentional 
# run-time error.
# $oops is unitialized, and therefore as 
# a number evaluates to zero.

$sport = 1 / $oops;
print "

This line won't display!\n"; } # end of subroutine show_form # #------------------------------------------------ sub interpret_inputs { # Subroutine interpret_inputs validates # that all required values were entered and # that they have the correct formats. # First, copy values from associative array # %input into convenient scalar variables: $email=$input{'email'}; $fname=$input{'fname'}; $gname=$input{'gname'}; $title=$input{'title'}; $comments=$input{'comments'}; $errmsg=''; # Check that required inputs are # present and meaningful. # Email must have form user@host.somewhere if ($email =~ /^\s*$/ ) { # Is email missing? # ^ means start of string, # \s means blank,tab,newline or return # * means "zero or more" # $ means end of string. # "Does $email match the pattern: # zero or more spaces?" $errmsg .= '

You must supply an email address!'; } elsif ($email !~ /(\S+@\S+\.\S+)/ ) { # Does $email match "user@host.somewhere"? # \S means "non-space" # + means "one or more" # \. means "period" # ( ) means "capture this part of pattern" $errmsg .= '

Email address must have form:' . 'id@host.whatever'; } else { $email = $1 } # Strips off leading and trailing blanks # $1 means "what was between () in previous # match. if ($fname =~ /^\s*$/ && $gname =~ /^\s*$/) { $errmsg .= '

You must supply family or given name.'; } print <Results EOF if ($errmsg eq '') {&write_results} if ($errmsg ne '') {print '


',$errmsg} else {print '

Your entry was submitted: ', `date`} print "

", "


\n"; } # end of subroutine interpret_inputs # #------------------------------------------------ # We've got form input values and they're ok, so # append the values to a disk file. sub write_results { # To easily read this data with a spreadsheet or database, # save it using tab-delimited fields, for example: # # 128.11.22.37^96-09-25 14:03^jd@x.y.edu^Doe^John Q.^Dr.^Some comment. # # (where ^ symbolizes a tab). # Start the record with user's IP address: $record = $ENV{'REMOTE_ADDR'}; # Add a second field, the current time in a readable form: ($sec,$mi,$hr,$da,$mo,$yr) = localtime($^T); $record .= sprintf("\t%04d-%02d-%02d %02d:%02d", $yr, $mo+1, $da, $hr, $mi); # Add remaining fields to record. # Translate to blank any tabs, newlines, or other # non-printable characters that the user of your form # may have entered. foreach $field ($email, $fname, $gname, $title, $comments) { $field =~ tr/\x20-\x7e/ /c; $record .= "\t" . $field; } # The following use of < > is called globbing. # It expands a ~userid file specification to # an explicit file path like /Net/laika/Users/userid $savepath = <${savefile}>; # In the following open command, the >> means # "append to any existing file". if (! open(SAVE, ">>$savepath") ) { # If we can't open the file, tell the user: $errmsg .= "

UID $> can't open file $savefile,
" . "path $savepath,
reason: $!
" . `/bin/ls -lgd $savepath`; return; } # Lock the output file so multiple simultaneous uses of # this program won't mess up the file: flock(SAVE, 2); # Set exclusive advisory lock on file. seek(SAVE, 0, 2); # Make sure we're at the very end. # Now try to output the data record! if (! print(SAVE $record,"\n")) { $errmsg .= "

UID $> could not write $savefile,
" . "reason: $!
\n"; } flock(SAVE, 8); # Free the advisory lock close(SAVE); } # end of subroutine write_results # ## end of program form1.cgi ##