File Coverage

Relations.pm

Criterion	Covered	Total	%
statement	119	135	88.1
branch	40	62	64.5
condition	9	18	50.0
subroutine	21	21	100.0
pod	20	20	100.0
total	209	256	81.6

# This package contains some generalized functions for
# dealing with databases and queries. It serves as the
# base module for all other Relations packages.

package Relations;
require Exporter;
require 5.004;

# You can run this file through either pod2man or pod2html to produce pretty
# documentation in manual or html file format (these utilities are part of the
# Perl 5 distribution).

# Copyright 2001 GAF-3 Industries, Inc. All rights reserved.
# Written by George A. Fitch III (aka Gaffer), [e-mail]

# This program is free software, you can redistribute it and/or modify it under
# the same terms as Perl istelf

$Relations::VERSION='0.95';

@ISA = qw(Exporter);

@EXPORT = qw(
  rearrange
  delimit_clause
  as_clause
  equals_clause
  comma_clause
  assign_clause
  add_as_clause
  add_equals_clause
  add_comma_clause
  add_assign_clause
  set_as_clause
  set_equals_clause
  set_comma_clause
  set_assign_clause
  to_array
  to_hash
  add_array
  add_hash
  get_input
  configure_settings
);

@EXPORT_OK = qw(
  rearrange
  delimit_clause
  as_clause
  equals_clause
  comma_clause
  assign_clause
  add_as_clause
  add_equals_clause
  add_comma_clause
  add_assign_clause
  set_as_clause
  set_equals_clause
  set_comma_clause
  set_assign_clause
  to_array
  to_hash
  add_array
  add_hash
  get_input
  configure_settings
);

%EXPORT_TAGS = ();

# From here on out, be strict and clean.

use strict;



### Rearranges arguments from either the straight ordered format, or named format,
### into their respective variables.

### This code was modified from the standard CGI module by Lincoln D. Stein

sub rearrange {

  ### First we're going to get whatever's sent and make sure there's
  ### something to parse

  # Get how to order of the arguments and the arguments themselves.

  my ($order,@param) = @_;

  # Return unless there's something to parse.

  return () unless @param;

  ### Second, we're going to format whatever's sent in an array, with the
  ### even members being the keys, and the odd members being the values.
  ### If the caller just sent the argument in the order the function
  ### requires without names, we'll just return those values in their.
  ### sent order.

  # If the first parameter is a hash.

  if (ref($param[0]) eq 'HASH') {

    # Then we have to change it to an array, with the evens = keys,
    # odds = values.

    @param = %{$param[0]};

  }

  # If it's not a hash

  else {

    # Then return the values array as is, unless the first member of the array
    # is preceeded by a '-', which would be indicated of a named parameters
    # calling style, i.e. 'function(-name => $value)'.

    return @param unless (defined($param[0]) && substr($param[0],0,1) eq '-');

  }

  ### Third, we're going to figure out the where each arguments value is to
  ### go in the array returned.

  # Declare some locals (Howdy folks!) to figure out the order in which to
  # return the argument values.

  my ($i,%pos);

  # Initialize count

  $i = 0;

  # Go through each value in the order array

  foreach (@$order) {

    # The order of this argument name is the current location of the counter.

    $pos{uc $_} = $i;

    # Increase the counter to the next position.

    $i++;

  }

  ### Fourth, we're going insert the argument values into the return array in
  ### their proper order, and then send the results array on it's way.

  # Declare the array that will return the argument values in there proper
  # order.

  my (@result);

  # Preextend the results array to match the length of the order aray. I
  # guess this speeds things up a bit.

  $#result = $#$order;  # preextend

  # While there's arguments and values left to parse.

  while (@param) {

    # The argument's name is the even member (zero is even, right?)

    my $key = uc(shift(@param));

    # Take out the '-' preceeding the name of the argument

    $key =~ s/^\-//;

    # If we calculated a position for this argument name.

    if (exists $pos{$key}) {

      # Then store the arguments value at the arguments proper position in the
      # result array.

      $result[$pos{$key}] = shift(@param);

    }

  }

  # Return the array of arugments' values.

  @result;

}



### This routine is used for concatenting hashes, arrays and (leaving alone)
### strings to be used in different clauses within an SQL statement.
### If sent a hash, the key-value pairs will be concatentated with the minor
### string those pairs will be concatenated with the major string, and
### that string returned. If an array is sent, the members of the array
### will be concatenated with the major string, and that string returned.
### If a string is sent, that string will be returned.

sub delimit_clause {

  # Get delimitters passed

  my ($minor) = shift;
  my ($major) = shift;
  my ($reverse) = shift;

  # Declare the various form of the sent clause

  my (%clause,@clause,$clause);

  ### First, figure out whether we were passed a hash ref, an array ref
  ### or string.

  # Create a hash from the next argument hash reference, if next the
  # argument is in fact a hash reference.

  %clause = %{$_[0]} if (ref($_[0]) eq 'HASH');

  # Create an array from the clause_info array reference,  if next the
  # argument is in fact an array reference.

  @clause = @{$_[0]} if (ref($_[0]) eq 'ARRAY');

  # Create a string from clause_info string, unless we
  # already determined it was a hash or array.

  $clause = $_[0] unless (%clause || @clause);

  ### Second concatenate, we're appropriate. Hash ref's use the key-value
  ### to establish a relationship, like equals, as, etc., and each pair
  ### represents a piece of the clause, like something between and's in
  ### a where clause. Array ref's have each member being a piece of the
  ### clause. Strings are all the pieces of the clause concanated together.

  # Go through the keys and values, adding to the array to make it seem
  # we were really passed an array.

  foreach my $key (keys %clause) {

    # Unless we're supposed to reverse the order, like in a select or
    # from clause

    push @clause, $reverse ? "$clause{$key}$minor$key" : "$key$minor$clause{$key}";

  }

  # If the clause array has members, meaning we were passed an array
  # ref of clause info, (or made to think that we were), concatenate
  # the array into a string, as if we were really passed a string.

  $clause = join $major, @clause if (scalar @clause);

  # Return the string since that's all we were passed, (or made to think
  # we were).

  return $clause;

}



### Builds the meat for a select or from clause of an SQL
### statement.

sub as_clause {

  # Get the clause to be as'ed

  my ($as) = shift;

  # If there's something to delimit return the proper clause
  # manimpulation

  return delimit_clause(' as ',',',1,$as) if defined($as);

  # If where here, than there's nothing to
  # delimit. So return that.

  return '';

}



### Builds the meat for a where or having clause of an
### SQL statment. Concats with and, not or.

sub equals_clause {

  # Get the clause to be equals'ed

  my ($equals) = shift;

  # If there's something to delimit, return the proper
  # clause manimpulation

  return delimit_clause('=',' and ',0,$equals) if defined($equals);

  # If where here, than there's nothing to
  # delimit.

  return '';

}



### Builds the meat for a group by, order by, or limit
### clause of an SQL statement. You can send it a hash,
### but the order could be changed. That's why you
### should only send it an array or string.

sub comma_clause {

  # Get the clause to be comma'ed

  my ($comma) = shift;

  # If there's something to delimit, return the proper
  # clause manimpulation

  return delimit_clause(',',',',0,$comma) if defined($comma);

  # If where here, than there's nothing to
  # delimit.

  return '';

}



### Builds the meat for a set clause of an SQL
### statement.

sub assign_clause {

  # Get the clause to be assign'ed

  my ($assign) = shift;

  # If there's something to delimit, return the
  # proper clause manimpulation

  return delimit_clause('=',',',0,$assign) if defined($assign);

  # If where here, than there's nothing to
  # delimit.

  return '';

}



### Add the meat for a select or from clause of
### an SQL statement.

sub add_as_clause {

  # Get the clause to be add as'ed

  my ($as) = shift;
  my ($add_as) = shift;

  # If there's something to add and there's
  # something already there, return what's
  # there, plus a comma, plus what's to be
  # added.

  return $as . ',' . as_clause($add_as) if defined($add_as) && length($as);

  # If there's still something to add, but
  # nothing already there, return what's to
  # be added.

  return as_clause($add_as) if defined($add_as);

  # If we're here than there's nothing
  # to be added so just return what's
  # already there.

  return $as;

}



### Add the meat for a where or having clause of
### an SQL statement.

sub add_equals_clause {

  # Get the clause to be add equals'ed

  my ($equals) = shift;
  my ($add_equals) = shift;

  # If there's something to add, and there's
  # something already there, return what's there,
  # plus an and, plus what's to be added.

  return $equals . ' and ' . equals_clause($add_equals) if defined($add_equals) && length($equals);

  # If we're here than there's nothing
  # already there so just return what's
  # to be added.

  return equals_clause($add_equals) if defined($add_equals);

  # If we're here than there's nothing
  # to be added so just return what's
  # already there.

  return $equals;

}



### Add the meat for a order by, group by, or
### limit clause of an SQL statement.

sub add_comma_clause {

  # Get the clause to be add comma'ed

  my ($comma) = shift;
  my ($add_comma) = shift;

  # If there's something to add and there's
  # something already there, return what's
  # there, plus a comma, plus what's to be
  # added.

  return $comma . ',' . comma_clause($add_comma) if defined($add_comma) && length($comma);

  # If we're here than there's nothing
  # already there so just return what's
  # to be added.

  return comma_clause($add_comma) if defined($add_comma);

  # If we're here than there's nothing
  # to be added so just return what's
  # already there.

  return $comma;

}



### Add the meat for a set caluse of an SQL statement.

sub add_assign_clause {

  # Get the clause to be add assign'ed

  my ($assign) = shift;
  my ($add_assign) = shift;

  # If there's something to add, and there's
  # something already there, return what's there,
  # plus a comma, plus what's to be added.

  return $assign . ',' . assign_clause($add_assign) if defined($add_assign) && length($assign);

  # If we're here than there's nothing
  # already there so just return what's
  # to be added.

  return assign_clause($add_assign) if defined($add_assign);

  # If we're here than there's nothing
  # to be added so just return what's
  # already there.

  return $assign;

}



### Sets the meat for a set clause of an SQL statement.
### If there's something to be set, it overrides what's
### already there. If there's nothing to set, it'll
### leave what's there alone.

sub set_as_clause {

  # Get the clause to be set as'ed

  my ($as) = shift;
  my ($set_as) = shift;

  # If there's something to set, just
  # return what's to be set.

  return as_clause($set_as) if defined($set_as);

  # If we're here than there's nothing
  # to be set so just return what's
  # already there.

  return $as;

}



### Sets the meat for a where or having clause of
### an SQL statement. If there's something to be
### set, it overrides what's already there. If
### there's nothing to set, it'll leave what's there
### alone.

sub set_equals_clause {

  # Get the clause to be set equals'ed

  my ($equals) = shift;
  my ($set_equals) = shift;

  # If there's something to set, just
  # return what's to be set.

  return equals_clause($set_equals) if defined($set_equals);

  # If we're here than there's nothing
  # to be set so just return what's
  # already there.

  return $equals;

}



### Sets the meat for a order by, group by, or
### limit clause of an SQL statement. If there's
### something to be set, it overrides what's
### already there. If there's nothing to set, it'll
### leave what's there alone.

sub set_comma_clause {

  # Get the clause to be set comma'ed

  my ($comma) = shift;
  my ($set_comma) = shift;

  # If there's something to set,
  # return what's to be set.

  return comma_clause($set_comma) if defined($set_comma);

  # If we're here than there's nothing
  # to be set so just return what's
  # already there.

  return $comma;

}



### Sets the meat for a set clause of an SQL statement.
### If there's something to be set, it overrides what's
### already there. If there's nothing to set, it'll
### leave what's there alone.

sub set_assign_clause {

  # Get the clause to be set assign'ed

  my ($assign) = shift;
  my ($set_assign) = shift;

  # If there's something to set,
  # return what's to be set.

  return assign_clause($set_assign) if defined($set_assign);

  # If we're here than there's nothing
  # to be set so just return what's
  # already there.

  return $assign;

}



### Takes a delimitted string or array ref and
### returns an array ref. If an array ref is sent,
### a copy of the array is returned, not the
### original array.

sub to_array {

  # Grab the value sent and what to split by only
  # if split was sent. Else split by a comma.

  my $value = shift;
  my $split = scalar @_ ? shift : ',';

  # Declare the return array. Set it to the $value
  # if $value's a ref, else split $value by commas.

  my @value = ref($value) ? @$value : split $split, $value;

  # Return the array refence

  return \@value;

}



### Takes a delimitted string, array ref or hash ref
### and returns a hash ref. The hash reference will
### have the individual values as keys with their
### values set to true. If an hash ref is sent, a
### copy of the hash is returned, not the original
### hash.

sub to_hash {

  # Grab the value sent and what to split by only
  # if split was sent. Else split by a comma.

  my $value = shift;
  my $split = scalar @_ ? shift : ',';

  # Declare the hash to send back.

  my %value = ();

  # Unless it's a hash reference

  unless (ref($value) eq 'HASH') {

    # Assume its a comma delimitted string or an
    # array ref and send it to to_array

    $value = to_array($value,$split);

    # Go through each one, settting the
    # key's value to true.

    foreach my $key (@{$value}) {

      $value{$key} = 1;

    }

  } else {

    # Dump the sent hash into our hash

    %value = %$value;

  }

  # Return the hash refence

  return \%value;

}



### Takes two array refs and places one onto the
### end of the other

sub add_array {

  # Grab the arrays sent.

  my $value = shift;
  my $adder = shift;

  # Push the adder onto the value

  push @{$value},@{$adder};

  # Return the value

  return $value;

}



### Takes two hash refs and adds the key value pairs
### from one to the other.

sub add_hash {

  # Grab the hashes sent.

  my $value = shift;
  my $adder = shift;

  # Go through each adder key

  foreach my $add (keys %{$adder}) {

    $value->{$add} = $adder->{$add};

  }

  # Return the value

  return $value;

}



### Asks a question, gets input from the user,
### cleans the input, and return the input if
### given by the user, else returns the defaults
### value.

sub get_input {

  # Get the arguments sent.

  my ($question,
      $default) = rearrange(['QUESTION',
                             'DEFAULT'],@_);

  # Ask the question, get the answer, and
  # clean the answer.

  print "$question [$default]:";
  my $answer = ;
  chomp $answer;

  # If an answer was given, return it, else
  # return the default.

  return length($answer) ? $answer : $default;

}



### Creates a default database settings module.
### Takes in the defaults, prompts the user for
### info. If the user sends info, that's used.
### Once the settings are determined, it creates
### a Settings.pm file in the current direfctory.

sub configure_settings {

  # Get the defaults sent. These we be used if
  # the user just hits return for each one.

  my ($def_database,
      $def_username,
      $def_password,
      $def_host,
      $def_port) = rearrange(['DATABASE',
                              'USERNAME',
                              'PASSWORD',
                              'HOST',
                              'PORT'],@_);

  # Declare the actual values to

  my ($database,$username,$password,$host,$port,$confirm);

  # Prompt the user for each value

  print "
    Before we can get started, I need to know some
    info about your MySQL settings. Please fill in
    the blanks below. To accept the default values
    in the []'s, just hit return.
  ";

  print "
    MYSQL DATABASE NAME
    Make sure the database isn't the same as the name
    as an existing database of yours, since the this
    script will delete that database when run.
  ";

  $database = get_input("\nDatabase name",$def_database);;

  print "
    MYSQL USERNAME AND PASSWORD
    Make sure the this username password account can
    create and destroy databases.
  ";

  $username = get_input("\nUsername",$def_username);;
  $password = get_input("\nPassword",$def_password);;

  print "
    MYSQL HOST AND PORT
    Make sure the computer running the demo can connect to
    this host and port, or this script will not function
    properly.
  ";

  $host = get_input("\nHost",$def_host);;
  $port = get_input("\nPort",$def_port);;

  # Let the user know the defaults.

  print "
    Using settings:
      database: $database
      username: $username
      password: $password
      host: $host
      port: $port
  ";

  # Double check with the user

  $confirm = get_input("\nCreate Settings.pm? (y/n)",'n');;

  die "Settings configuration aborted" unless $confirm =~ /^y/i;

  # Create a Settings.pm file

  open SETTINGS, ">Settings.pm";

  print SETTINGS "\$database = '$database';\n";
  print SETTINGS "\$username = '$username';\n";
  print SETTINGS "\$password = '$password';\n";
  print SETTINGS "\$host = '$host';\n";
  print SETTINGS "\$port = '$port';\n";

  close SETTINGS;

}

$Relations::VERSION;

__END__