Listing 2. People.pm, a Perl Object Module That Communicates with the Package People

use strict;
use DBI;
# Declare global variables
use vars qw($dbhost $dbuser $dbpassword $dsn @ISA);
my $dbhost = 'localhost';
my $dbuser = 'reuven';
my $dbpassword = '';
my $dsn = "DBI:Pg:dbname=atf;host=$dbhost;";
# We don't inherit from anyone
@ISA = ();
# Constructor: Takes a class as an argument, and
# connects to the database.
# Returns a new People object, or undef if there
# was an error.
sub new
{
   # Get our class
   my $class = shift;
   # Create our instance
   my $self = {};
   # Connect to the database. Set RaiseError, but
   # not PrintError, since objects should not
   # display errors when they occur.
   my $dbh = DBI->connect($dsn, $dbuser, $dbpassword,
                 {
                  RaiseError => 1, AutoCommit => 1});
   # If we could not connect, return undef
   return undef unless (defined $dbh);
   # Store the database handle as an instance
   # variable
   $self->{dbh} = $dbh;
   # Set the current person
   $self->{current_person} = undef;
   # Turn $self into an object
   bless $self, $class;
   # Return the new instance
   return $self;
}
# get_current_person: Returns a unique internal
# numeric ID for the current person.
sub get_current_person
{
   # Get myself
   my $self = shift;
   # Get my current person
   my $current_person = $self->{current_person};
   # Return the value
   return $current_person;
}
# get_all_full_names: Returns a list of strings
# containing the first and last names of all people
# in the database
sub get_all_full_names
{
   # Get myself
   my $self = shift;
   # Get the database handle
   my $dbh = $self->{dbh};
   # Initialize the array
   my @full_names = ();
   # Set the SQL to retrieve all names
   my $sql = "SELECT first_name || ' ' || last_name ";***
   $sql .= "FROM People ";
   $sql .= "ORDER BY first_name ";
   # Perform the query
   my $sth = $dbh->prepare($sql);
   $sth->execute();
   # Retrieve query results
   while (my ($name) = $sth->fetchrow_array)
   {
       push @full_names, $name;
   }
   # Finish with this statement
   $sth->finish();
   # Return self
   return @full_names;
}
# get_current_info: Returns a hash reference with
# name-value pairs describing information about the
# current person.
sub get_current_info
{
# get_current_info: Returns a hash reference with
# name-value pairs describing information about the
# current person.
sub get_current_info
{
   # Get myself
   my $self = shift;
   # Get the database handle
   my $dbh = $self->{dbh};
   # Get the current person
   my $current_person = $self->{current_person};
   # Create the empty hash reference
   my $user_info = {};
   # Make sure that we have a current person set!
    return undef unless $current_person;
    # Set the SQL to retrieve all information
    my $sql = "SELECT first_name, last_name, address1, address2, ";***
  $sql .= "email, city, state, postal_code, country, comments ";***
    $sql .= "FROM People ";
    $sql .= "WHERE person_id = ? ";
    # Perform the query
    my $sth = $dbh->prepare($sql);
    $sth->execute($current_person);
   # Retrieve query results, copying the returned
   # hashref into another hashref.
   while (my $person_hashref = $sth->fetchrow_hashref)***
    {
        %{$user_info} = %{$person_hashref};
    }
    # Finish with this statement
    $sth->finish();
    return $user_info;
}
# Returns a list all of the e-mail addresses in
# the database.
sub get_email_addresses
{
    # Get myself
    my $self = shift;
    # Get the database handle
    my $dbh = $self->{dbh};
    # Get ready to store IDs
    my @email_addresses = ();
    # Set the SQL
    my $sql = "SELECT email People ";
    $sql .=   "ORDER BY email";
    # Perform the query
    my $sth = $dbh->prepare($sql);
    $sth->execute();
    # Retrieve query results
    while (my ($address) = $sth->fetchrow_array)
    {
 push @email_addresses, $address;
    }
    # Finish with this statement
    $sth->finish();
    # Return self
    return @email_addresses;
}
# Set the current person, based on the e-mail address
sub set_current_person_by_email
{
    # Get myself
    my $self = shift;
    # Get the e-mail address
    my $email_address = shift;
    # Get the database handle
    my $dbh = $self->{dbh};
    # Set the SQL
    my $sql = "SELECT person_id ";
    $sql .= "FROM People ";
    $sql .= "WHERE email = ? ";
    # Perform the query
    my $sth = $dbh->prepare($sql);
    $sth->execute($email_address);
    # Get the person_id
    my ($person_id) = $sth->fetchrow_array;
    # Finish with this statement
    $sth->finish();
    # Set the current person to the ID from
    # the database
    $self->{current_person} = $person_id;
    # Return the object
    return $self;
}
# Set the current person, based on the first and
# last names
sub set_current_person_by_name
{
    # Get myself
    my $self = shift;
    # Get the names
    my $first_name = shift;
    my $last_name = shift;
    # Get the database handle
    my $dbh = $self->{dbh};
    # Set the SQL
    my $sql = "SELECT person_id ";
    $sql .= "FROM People ";
    $sql .= "WHERE first_name = ? ";
    $sql .= "  AND last_name = ? ";
    # Perform the query
    my $sth = $dbh->prepare($sql);
    $sth->execute($first_name, $last_name);
    # Get the person_id
    my ($person_id) = $sth->fetchrow_array;
    # Finish with this statement
    $sth->finish();
    # If we got a user ID, set it and return the
    # object
    if ($person_id)
    {
        # Set the current person to the ID from
        # the database
        $self->{current_person} = $person_id;
        # Return the object
        return $self;
    }
    else
    {
 return undef;
    }
}
# Create a new person
# Takes a hash of arguments, and
sub new_person
{
    # Get myself
    my $self = shift;
    # Use the rest of the arguments as a hash
    my %args = @_;
    # Get the database handle
    my $dbh = $self->{dbh};
    # Make sure we have at least the items we need
    return undef unless ($args{first_name} and $args{last_name} and***
                         $args{email} and $args{country});***
    # Start a transaction, so that we can be sure
    # everything is done together
    $dbh->{AutoCommit} = 0;
    # Does a person with this e-mail address
    # (a UNIQUE key) already exist:
    my $sql = "SELECT person_id ";
    $sql .=   "FROM People ";
    $sql .=   "WHERE email = ? ";

    # Look for such a primary key
    my $sth = $dbh->prepare($sql);
    $sth->execute($args{email});
    # Get a primary key, if one exists
    my ($person_id) = $sth->fetchrow_array;
    # If we got an ID, then the user exists:
    # rollback, and return undef
    if ($person_id)
    {
        $dbh->rollback();
        $dbh->{AutoCommit} = 1;
        return undef;
    }
    # Create the SQL to insert a new row
    $sql = "INSERT INTO People ";
    $sql .= "(first_name, last_name, address1, address2, email, ";***
    $sql .= " city, state, postal_code, country, comments) ";***
    $sql .= "VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?) ";
    # Insert the row
    my $affected_rows =
        $dbh->do($sql, undef, $args{first_name}, $args{last_name},***
                 $args{address1}, $args{address2}, $args{email},***
                 $args{city}, $args{state}, $args{postal_code},***
                 $args{country}, $args{comments});
    # If the INSERT was successful, set the current
    # person to be the newly inserted primary key
    if ($affected_rows)
    {
        # Get the inserted primary key
        my $sql = "SELECT currval(?)";
        # Prepare and execute the SELECT
        my $sth = $dbh->prepare($sql);
        $sth->execute('people_person_id_seq');
        # Retrieve the primary key
        my ($person_id) = $sth->fetchrow_array;
        # We're finished with this statement handle
        $sth->finish;
        # Get the latest
        $self->{current_person} = $person_id;
        # Commit the transaction
        $dbh->commit();
        $dbh->{AutoCommit} = 1;
        return $self;
    }
    # If the INSERT was unsuccessful, return undef
    else
    {
        # Commit the transaction
        $dbh->rollback();
        $dbh->{AutoCommit} = 1;
        return undef;
    }
}
# Takes one argument (in addition to the object
# instance), a new first name. The new name is
# updated in the database. Returns the object upon
# success, and undef upon failure.
sub update_first_name
{
    # Get myself
    my $self = shift;
    # Get the new first name
    my $new_first_name = shift;
    # Get the database handle
    my $dbh = $self->{dbh};
    # Set the SQL
    my $sql = "UPDATE People ";
    $sql .= "SET first_name = ? ";
    $sql .= "WHERE person_id = ? ";
    # Perform the UPDATE
    my $modified_rows =
        $dbh->do($sql, undef, $new_first_name, $self->{current_person});***
    # We succeeded; return the object
    if ($modified_rows)
    {
        return $self;
    }
    # We failed; return undef
    else
    {
 return undef;
    }
}
# Destructor: Called automatically by Perl. We use
# this to close the database handle. This isn't
# really necessary if we are running under
# Apache::DBI.
sub DESTROY
{
    # Get myself
    my $self = shift;
    # Get the database handle
    my $dbh = $self->{dbh};
    # Close the database handle
    $dbh->disconnect;
    return;
}
# Always return a true value from a module 1;
1;