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;
Copyright © 1994 - 2018 Linux Journal. All rights reserved.