#!/usr/bin/perl -w
#################################################
# Address Book cgi script.
#    html interface:   CGI.pm module, html as strings in the perl code.
#    database      :   MLDBM tied multi-level database hash
#
# This is a bread-n-butter all-in-one perl script.
# What we saw last week.
#
#  Database structure is 
#
#  {  _users => [ user1, user2, user3, ... ],
#     user1 =>  [ fullname => 'first last', email => 'who@where'],
#     user2 =>  [...],
#  }
#
# See CGI Programming in Perl, pg 243
#
########################################################
our %database;	
openDatabase();

use CGI;
use CGI::Carp qw(fatalsToBrowser);
my $cgi = new CGI;

print $cgi->header();
print $cgi->start_html( title=>'Address Book' );
print $cgi->start_form;

my $formMessage = processFormSubmission($cgi);

print "<h1>Address Book</h1>\n";

# Loop over the users in the database.
my $users = $database{_users};		# reads list of users from the file
if ($users) {
  print "<table border=1>";
  print "<tr>" .
        " <td><b>User</b></td><td><b>Name</b></td><td><b>Email</b></td>" .
	"</tr>\n";
  foreach my $user (@$users) {
    my $userdata = $database{$user};	# reads one user's data from the file
    print "<tr>\n";
    print " <td>" . $user . "</td>\n";
    print " <td>" . $userdata->{$_} . "</td>\n" foreach qw( fullname email );
    print "</tr>\n";
  }
  print "</table>\n";
}
else {
  print "<i>No users in database.</i>\n";
}

print "
 <hr>
<table>
<tr>
 <td>User</td>
 <td><input type='text'   name='user'      size=30></td>
</tr><tr>
 <td>Full Name</td>
 <td><input type='text'   name='fullname' size=30></td>
</tr><tr>
 <td>Email</td>
 <td><input type='text'   name='email'    size=30></td>
</tr><tr>
 <td><br></td>
 <td><input type='submit' name='adduser' value='Add User'></td>
</tr>
</table>
 ";

print $formMessage;

print $cgi->end_form;
print $cgi->end_html;
closeDatabase();
exit;

# ---------------------------------------------
# misc subroutines

# If the user submits the form, then change the database.
sub processFormSubmission {
  my ($redstart,$redend) = ("<p><font color='red'>", "</font><p>\n");
  my ($cgi) = @_;
  my ($adduser, $user, $fullname, $email) 
    = map {$cgi->param($_) || ''} qw( adduser user fullname email );

  if ( $adduser ) {
    unless ( $user and $fullname and $email) {
      return $redstart . "OOPS - to add someone to the database, " .
	"you must supply a value for each of the fields." . $redend;
    }
    my $users = $database{_users};	# read list of users from the file
    push @$users, $user;
    $database{_users} = $users;	# write list of users to the file and
					# write new user's data to the file.
    $database{$user} = { fullname => $fullname, email => $email };
  }
  return '' unless $user;
  return $redstart . 
         "OK, the user '$user' has been added to the databse." . $redend;
}

# ---------------------------------------------
# Database routines.

# Open the global %database as an MLDBM tied hash, i.e. a "disk file" hash.
#   *  I'm using the recipe in "CGI Programming in Perl" and flock() for
#     locking the tied hash.  Also, for simplicity I'm simply asking
#     for a write lock whether I need it on this call or not.
#   *  Do make sure that the permissions on $datafile allow the httpd deamon
#     to modify it.  The "0660" sets the permissions to rw for user/group
#     if the file is created with this call - and that can only happen
#     if the directory allows the httpd deamon to create a file.
#     I've found it's usually easier to run the script from the command
#     line the first time, which will create the database, and then set
#     its permissions by hand, with chmod.
#   *  This hash may be a deep data structure.  However, to write to 
#     the disk you must assign to the *top* level part of the hash.
#     Thus $database{this}{that} = 2; won't change the disk file,
#     but $tmp=$database{this};$tmp->{that}=2;$database{this}=$tmp will.
sub openDatabase {
  my $datafile = 'AddressData.db';
  use MLDBM qw (DB_File Storable );
  use Fcntl qw( :DEFAULT :flock );
  my $db = tie(%database, 'MLDBM', $datafile, O_RDWR|O_CREAT, 0666)
     or die " Error - unable to connect to $datafile : $!";
  my $fd = $db->fd;
  open DBM, "+<&=$fd" or die "Could not dup DBM for lock: $!";
  flock DBM, LOCK_EX;
  undef $db;
}

sub closeDatabase {
  untie %database;
}