CMS-Experte | IT-Consultant in Berlin

A simple guestbook that uses a DBM file to store the data entered by visitors (name, e-mail, URL of website, comment). This script uses the Perl Module WebForm.pm for input validation and the HTML output methods provided by Lincoln Stein's CGI module.

#!/usr/local/bin/perl -wT
# guestbook.cgi is a simple guestbook. The data entered by the 
# user is stored in a DBM file. Form generation and input validation
# is achieved through using the WebForm methods build() and check().
#
# Copyright 2003, Ramiro Gómez.
#
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
use strict;
use DB_File;
use Fcntl;
use CGI::Carp qw(fatalsToBrowser);
use CGI;
use lib qw(/var/www/lib/perl);
use WebForm;

$CGI::POST_MAX=1024*100;  # max 100 KBytes posts
$CGI::DISABLE_UPLOADS = 1;  # no uploads

# Security
$ENV{'PATH'} = '/bin:/usr/bin';
delete @ENV{'IFS','CDPATH','ENV','BASH_ENV'};

# Configuration
my $mail = 0; # send confirmation mail to $recipient if true
my $mail_prog = '/usr/ucb/mail'; 
my $recipient = 'ramiro@rahoo.de';
my $title = 'Guestbook'; # title of HTML page
my $dbm_file = "./gb/formdata.db";

# Globals
my %dbm_hash;

# create CGI object
my $q = new CGI;
if ($q->cgi_error()) {
    print $q->header( { status => $q->cgi_error()} ), 
    $q->start_html( { title => 'Error'} ), $q->end_html();
    exit 1;	
}
my $choice = lc $q-> param('choice');

# define the attributes of the start form element
my %form_def = (
		action => $q->url(),
		method => 'post',
		enctype => 'application/x-www-form-urlencoded'
		);

# Array that stores the name of the form field,
# the form element to use, the label, the type,
# whether the field is required, the size and 
# the maximum length in a reference to a hash.
my @form_fields = (
		   { name => 'name', field => 'textfield', label => 'Name: ',
		     type => 'text', req => 1, size => 40, max => 80 },
		   { name => 'email', field => 'textfield', label => 'E-Mail: ',
		     type => 'email', req => 1, size => 40, max => 80 },
		   { name => 'url', field => 'textfield', label => 'URL: ',
		     type => 'url', req => 1, max => 100 },
		   { name => 'comment', field => 'textarea', label => 'Comment: ',
		     type => 'text', req => 1, cols => 40, rows => 5, max => 1000 },
		   );

# create WebForm object
my $wf = WebForm->new();

# store the HTML form in $form
my $form = $wf->build(\%form_def, \@form_fields);

# add a link to view the guestbook
$form .=  $q->p( $q->a( { -href => $q->url() 
. sprintf( "?cmd=%s", "view" ) }, 
			"View Guestbook" ) );

# tied hash reference to the CGI parameters
# used in the validation step
my $r_params = $q->Vars();

# print header
print $q->header(), $q->start_html( -title => $title ), $q->h2( $title );

# main dispatch logic
# user wants to view guestbook
if ( $q->param('cmd') eq 'view' ) {
    print display_guestbook(), $form;
}
# user entered data
elsif ($q->param()) {
    # validate user input
    my $ref_errors = $wf->check(\@form_fields, $r_params);
    
    # if there are errors
    if ( scalar( @{$ref_errors} ) > 0 ) {
	print $q->h4('The following error(s) occurred'),
	$q->ul( $q->li($ref_errors) ),
	$form;
    }
    # everything's okay 
    else {
	save_data();
	print display_guestbook(), $form;
	send_mail() if $mail;
    }
} 
# invoked without parameters
else {
    print $form;
}

# print end
print $q->end_html();

sub get_date {
    my @months = ('January','February','March','April','May','June','July',
		  'August','September','October','November','December');
    my ($mday,$mon,$year) = (localtime(time))[3,4,5];
    $year += 1900;
    my $date = "Date of entry: $mday $months[$mon] $year:";
    return $date;
} # sub get_date

sub save_data {
    # open db with read and write access
    my $db = tie %dbm_hash, "DB_File", $dbm_file, O_CREAT | O_RDWR, 0644 
	or die "Could not tie to $dbm_file: $!";
    my $fd = $db->fd; # get file descriptor
     # get dup filehandle
     open DBM, "+<&=$fd" or die "Could not dup DBM for lock: $!";
    
    {
	no strict;
	flock DBM, LOCK_EX; # lock exclusively
    }
    
    undef $db;

    # generate unique key
    my $key = time() . $r_params->{name};
    
    # string that is stored as the value of the DBM-Hash key
    my $value = get_date() . $q->br();
    if ( $r_params->{email} ) {
	$value .= $q->a( { -href => 'mailto:' . $r_params->{email} }, 
			 $r_params->{name} ) . $q->br();
    } else {
	$value .=  $r_params->{name} . $q->br();
    }
    
    if ( $r_params->{url} ) {
	$value .= $q->a( { -href => $r_params->{url} },
			 $r_params->{url} ) . $q->br();
    }
    $value .= $r_params->{comment} . $q->hr();
    
    # save data
    $dbm_hash{$key} = $value;
    untie %dbm_hash;
} # sub save_data

sub display_guestbook {
    tie %dbm_hash, "DB_File", $dbm_file, O_RDONLY
	or die "Unable to open dbm file $dbm_file: $!";
    return map { $q->p( $dbm_hash{$_} ) } sort keys %dbm_hash;
    untie %dbm_hash;
} # sub display_guestbook

sub send_mail {
    open(MAIL, "|$mail_prog -s 'New Guestbook entry' $recipient")
	or die "Can't open pipe to $mail_prog\n";
    close(MAIL) or die "Can't close pipe to $mail_prog\n";
} # sub send_mail