Pgreet::Config - Configuration object for Penguin Greetings.

  # Bootstrap Initialization:
  $Pg_config = new Pgreet::Config($config_file);
  $Pg_config->add_error_obj($Pg_error);

  # Normal Initialization:
  $Pg_config = new Pgreet::Config($config_file,
                                  $Pg_error,
                                  $Pg_default_config
                                 );
  # Access methods:
  $Pg_config->access('config_parameter');
  $Pg_config->access('config_parameter', $Value_to_set_parameter_to);
  $Pg_config->get_hash();
  $Pg_config->put_hash($new_hash);

  # Other Misc. methods:
  $Pg_default_config->is_valid_site($site);
  $Pg_default_config->expand_config_file($site);
  $card_conf->scalar_to_array();
  $results = $Pg_config->chk_params();

  unless ($Pg_default_config = new Pgreet::Config($config_file)) {
          die;
         }

  $Pg_error = new Pgreet::Error($Pg_default_config, 'CGIApp');

  $Pg_default_config->add_error_obj($Pg_error);

  $card_conf = new Pgreet::Config($card_conf_file, $Pg_error);

  $Pg_config = new Pgreet::Config($config_file,
                                  $Pg_error,
                                  $Pg_default_config
                                 );

package Pgreet::Config;
#
# File: Config.pm
######################################################################
#
#                ** PENGUIN GREETINGS (pgreet) **
#
# A Perl CGI-based web card application for LINUX and probably any
# other UNIX system supporting standard Perl extensions.
#
#   Edouard Lagache, elagache@canebas.org, Copyright (C)  2003-2005
#
# Penguin Greetings (pgreet) consists of a Perl CGI script that
# handles interactions with users wishing to create and/or
# retrieve cards and a system daemon that works behind the scenes
# to store the data and email the cards.
#
# ** This program has been released under GNU GENERAL PUBLIC
# ** LICENSE.  For information, see the COPYING file included
# ** with this code.
#
# For more information and for the latest updates go to the
# Penguin Greetings official web site at:
#
#     http://pgreet.sourceforge.net/
#
# and the SourceForge project page at:
#
#     http://sourceforge.net/projects/pgreet/
#
# ----------
#
#           Perl Module: Pgreet::Config
#
# This is the Penguin Greetings (pgreet) shared library for
# configuration settings.  This provide a uniform interface to
# settings shared between the CGI Application and the daemon.
# It provides for systematic updating of configuration information,
# interrupt handling, and so on.
######################################################################
# $Id: Config.pm,v 1.35 2005/05/31 16:44:38 elagache Exp $

$VERSION = "1.0.0"; # update after release

# Module exporter declarations
@ISA       = qw(Exporter);
@EXPORT    = qw();
@EXPORT_OK = qw();

# Perl modules.
use FileHandle;
use File::Basename;
use CGI qw(:standard escape);
use CGI::Carp;
use Config::General;
use User::pwent;
use String::Checker;
use Data::Dumper; # Needed only for debugging.
use I18N::AcceptLanguage;
use Pgreet;

# Perl Pragmas
use strict;

# List of Penguin Greetings configuration parameters which cannot be set
# on a secondary ecard website without breaking daemon, CGI-app interface.
# Subject to change but hardwired into apps.
our %set_primary_only =   (PID_file => 1,
						   PID_path => 1,
						   batch_pause => 1,
						   tmpdir => 1,
						   today_pause => 1,
						   data_file_prefix => 1,
						   state_file_prefix => 1,
						   delete_state => 1,
						   scheduled_email_queue => 1,
						   pgreet_uid => 1,
						   pgreet_gid => 1,
						   SMTP_server => 1,
						   user_access => 1,
						   User_Pgreets => 1,
						   flush_pause => 1,
						   purge_pause => 1,
						   purge_db_hour => 1,
						   reload_config => 1,
						  );

# List of tests to be performed on Penguin Greetings configuration
# parameters via the String::Checker interface
our %check_configs =
    (cgidir => ['is_directory'],
	 imagedir => ['is_directory'],
	 datadir => ['is_directory'],
	 confdir => ['is_directory'],
	 templatedir => ['is_directory'],
	 tmpdir => ['is_directory'],
	 scheduled_mail_queue => ['is_directory'],
	 pgreet_uid => ['want_int', ['num_min' => 1], 'existing_uid'],
	 pgreet_gid => ['want_int', ['num_min' => 1], 'existing_gid'],
	 Timeout => ['want_int', ['num_min' => 1]],
	 MaxRuns  => ['want_int', ['num_min' => 1]],
	 SMTP_server =>
	     {SMTP_Timeout => ['want_int', ['num_min' => 1]],
		 },
	 today_pause => ['want_int', ['num_min' => 1]],
	 batch_pause => ['want_int', ['num_min' => 1]],
	 batch_send_hour => ['want_int', ['num_min' => 0]],
	 delete_state => ['want_int', ['num_min' => 1]],
	 flush_pause => ['want_int', ['num_min' => 1]],
	 purge_pause => ['want_int', ['num_min' => 1]],
	 purge_db_hour => ['want_int', ['num_min' => 0]],
	 reload_config => ['want_int', ['num_min' => 1]],
	 PID_path => ['is_directory'],
	);


############### Extensions to String::Checker #################

String::Checker::register_check("is_directory",
#
# Test if this parameter is an existing local directory
#
        sub {
		     my($s) = shift;
			 if ((defined($$s)) && (not -d $$s)) {
			   return 1;
			 }
			 return undef;
		   }
);

String::Checker::register_check("num_min",
#
# Test if this parameter is greater than numerical lower bound
#
        sub {
		     my($s) = shift;
			 my($t) = shift;
			 if ((defined($$s)) && (not ($t <= $$s))) {
			   return 1;
			 }
			 return undef;
		   }
);

String::Checker::register_check("existing_uid",
#
# Test if this parameter is an existing user ID number
#
        sub {
		     my($s) = shift;
			 if ((defined($$s)) && (not getpwuid($$s))) {
			   return 1;
			 }
			 return undef;
		   }
);


String::Checker::register_check("existing_gid",
#
# Test if this parameter is an existing group ID number
#
        sub {
		     my($s) = shift;
			 if ((defined($$s)) && (not getgrgid($$s))) {
			   return 1;
			 }
			 return undef;
		   }
);


########################### METHODS ###########################

sub new {
#
# Traditional empty contructor.
# Assign values needed by
# particular instances of object
#
  my $class = shift;
  my $config_file = shift;
  my $Pg_error = shift;
  my $default_config = shift;
  my $no_merge = shift;

  my $self = {};
  bless $self, $class;
  my $default_config_hash = {};
  my $config_hash = {};
  my $cache_conf;

  # Have we cached this secondary ecard site already? - if so just return it.
  if ($default_config and
	  ($cache_conf = $default_config->fetch_cache_site($config_file))
	 ) {
	return($cache_conf);

  # Otherwise we need to construct new object and read data from a file.
  } else {
	# If we have an existing Error object, bind that to object.
	if (defined($Pg_error)) {
	  $self->{'Pg_error'} = $Pg_error;
	}

	# Set value of configuration file and read data
	$self->{'config_file'} = $config_file;
	$config_hash = $self->_read_config_file($config_file);

	# Do we have a default configuration to merge into this object?
	if(defined($default_config)) {
	  # If needed, merge settings from secondary ecard site with primary
	  $self->{'default_config'} = $default_config;
	  unless ($no_merge) {
		$default_config_hash = $default_config->get_hash();
		$config_hash =
		  $self->_merge_configs($default_config_hash, $config_hash);
	  }
	  $self->{'config'} = $config_hash;
	  # Cache resulting configuration
	  $default_config->cache_site($config_file, $self);
	  return($self);
	}
	# Else if we have a configuration hash, set that and return object ref.
	elsif ($config_hash) {
	  $self->{'config'} = $config_hash;
	  $self->{'secondary_cache'} = {};
	  return($self);
	  # If opening default configuration fails - returns 0 (false).
	} else {
	  return(0);
	}
  }
} # End object constructor.

sub add_error_obj {
#
# Since this is the first module to be loaded, so it cannot
# depend on a error object existing when first created.
# This method attaches an error object once Penguin
# Greetings has bootstrapped itself.
#
  my $self = shift;
  my $Pg_error = shift;

  return($self->{'Pg_error'} = $Pg_error);
}

sub _read_config_file {
#
# Subroutine to read the contents of a configuration file and
# return the contents.
#
  my $self = shift;
  my $config_file = shift;
  my $config_obj;
  my $config_ref = {};

  # Read configuation file variables
  unless ( (-r $config_file) and
		   ($config_obj = new Config::General(-ConfigFile => $config_file,
											  -AllowMultiOptions => 'yes',
											  -CComments => 'no',
											 )
		   ) and
		   (%{$config_ref} = $config_obj->getall())
		 ) {
	# If we have an error either report via error object or ... don't!
	if (exists($self->{'Pg_error'})) {
	  my $Pg_error = $self->{'Pg_error'};
	  $Pg_error->report('error', 22,
						"Unable to read configuration data from ",
						"file: $config_file - bailing"
					   );
	} else {
	  # If first call, we have no error object yet - deal in app.
	  return(0);
	}
  }

  # Attach hash to object and return.
  return($config_ref);

} # End sub _read_config_file

sub access {
#
# A method that, depending on the number of arguments,
# either returns the value of the given parameter,
# or sets that parameter to the supplied additional value
#

  my $self = shift;
  my $parameter = shift;
  my $value = shift;

  # If value is defined, modify hash, otherwise return value.
  if (defined($value)) {
	return($self->{'config'}->{$parameter} = $value);
  } else {
	if (defined($self->{'config'}->{$parameter})) {
	  return($self->{'config'}->{$parameter});
	} else {
	  return(0);
	}
  }
} # End sub access

sub get_hash {
#
# A method to return the entire hash reference of
# parameters.  This is an transitional function
# that probably shouldn't be used too often.
#
  my $self = shift;

  return($self->{'config'});
}

sub put_hash {
#
# A method to replace the entire hash reference
# of parameters.  Needed to fix a quirk in the
# way that cards are stored in categories.
#
# Move this problem into a derivate class of
# Config.pm?
#
  my $self = shift;
  my $config_hash = shift;

  return($self->{'config'} = $config_hash);
}

sub choose_localized_site {
#
# Subroutine to see if the site selected is actually
# one of a number of localized sites and if so, to
# choose which of those sites is the one appropriate
# given the user's language settings.
#

  my $self = shift;
  my $site_name = shift;
  my $localize = $self->access('Localize');
  my $Pg_error = $self->{'Pg_error'};
  my $language;
  # XXX strict setting should become a configuration option.
  my $acceptor = I18N::AcceptLanguage->new(strict => 0);

  # If there are any localization settings for this site
  if (exists($localize->{$site_name})) {
	# If there is localization information try to match to user language
	my $site_options = $localize->{$site_name};
	my @keys = keys(%{$site_options});
	$language = $acceptor->accepts($ENV{HTTP_ACCEPT_LANGUAGE}, \@keys);

	# If we have a match return that.
	if ($language) {
	  return($site_options->{$language}, $language);
	}
	# Else if we have a default - return that
	elsif ($site_options->{'default'}) {
	  return($site_options->{'default'}, $language);
	# Otherwise issue warning and return site name - gotta return something.
	} else {
	  $Pg_error->report('warn',
						"Localized site \'$site_name\' lacks a default value"
					   );
	  return($site_name, $language);
	}
  } else {
	return($site_name, $language); # No localization lookup, not localized(??)
  }
} # End sub choose_localized_site

sub is_valid_site {
#
# Method to test if a given web site exists in
# default configuration list of secondary sites.
#
  my $self = shift;
  my $site = shift;
  my $User_Pgreets = $self->access('User_Pgreets');
  my $Pg_error = $self->{'Pg_error'};

  if ($User_Pgreets and exists($User_Pgreets->{$site})) {
	return(1);
  } else {
	$Pg_error->report('error', 4,
					  "Attempt to use a nonexistent secondary Penguin ",
					  "Greetings ecard site: ",
					  $site
					 );
	return(0);
  }
}

sub _merge_configs {
#
# Internal method to take two configuration hashes and
# merge the contents so that new values replace old ones
# but values not set in the configuration revert to
# defaults
#
  my $self = shift;
  my $default_hash = shift;
  my $config_hash = shift;
  my $new_hash = {};
  my $Pg_error = $self->{'Pg_error'};

  # Create a copy of default hash.
  %{$new_hash} = %{$default_hash};

  # Delete any Embperl_Object setting - this cannot be inherited.
  if (exists($new_hash->{Embperl_Object})) {
	delete($new_hash->{Embperl_Object});
  }

  # Change values to reflect changes from secondary site.
  foreach my $value (keys(%{$config_hash})) {
	if (exists($set_primary_only{$value})) {
	  $Pg_error->report('error', 5,
						"Attempt to set parameter: $value in a secondary ",
						"configuration file.  This parameter may only be ",
						"set the Penguin Greeting primary configuration file"
					   );
	} else {
	  $new_hash->{$value} = $config_hash->{$value};
	}
  }

  # Return copy of configuration information.
  return($new_hash);

}

sub expand_config_file {
#
# Internal method test if configuration file path is relative
# to a user account and if so to expand the path via the
# home directory.
#
  my $self = shift;
  my $account = shift;

  my $User_Pgreets = $self->access('User_Pgreets');
  my $file_path = $User_Pgreets->{$account};
  my $Pg_error = $self->{'Pg_error'};
  my $pw_obj;

  if ($file_path =~ /~/) {
	# Get home directory via system call
	unless ($pw_obj = getpwnam($account)) {
	  $Pg_error->report('error', 4,
						"Attempt to use user account $account for Penguin ",
						"Greetings that does not exist on system.",
					   );
	}
	my $home = $pw_obj->dir();
	$file_path =~ s/~/$home/;
	return($file_path);
  } else {
	return($file_path);
  }
}

sub scalar_to_array {
#
# Method to go through and process the the 'Force_to_array'
# specification in a card configuration hash.  This is
# just the access method.  The real work is done by the
# internal subroutine: _int_scalar_to_array.
#
  my $self = shift;
  my $config_hash = $self->get_hash();
  my $new_hash = {};
  %{$new_hash} = %{$config_hash};

  $self->_int_scalar_to_array($new_hash);

  $self->put_hash($new_hash);

}

sub _int_scalar_to_array {
#
# Recursive subroutine to go through configuration file
# and locate every specification for where a field could
# be containing a single item but must be maintained as
# a array reference for looping simplicity.
#
  my $self = shift;
  my $config_piece = shift;

  if ((not ref($config_piece)) or (ref($config_piece) eq "ARRAY")) {
	return(1);
  }
  elsif (ref($config_piece) eq "HASH") {
	if ($config_piece->{'Force_to_array'}) {
	  $self->_swap_arrays_for_scalars($config_piece);
	}
	foreach my $element (keys(%{$config_piece})) {
	  $self->_int_scalar_to_array($config_piece->{$element});
	}
  }

} # End: sub _int_scalar_to_array

sub _swap_arrays_for_scalars {
#
# Subroutine to "slice in" the array references to replace
# single scalar values in configuration hash.
#
  my $self = shift;
  my $config_piece = shift;
  my $fields = $config_piece->{'Force_to_array'}->{'fields'};

  unless (ref($fields) eq 'ARRAY') {
	$fields = [ $fields ];
  }

  foreach my $entry (keys(%{$config_piece})) {
	foreach my $field (@{$fields}) {
	  if (not ref($config_piece->{$entry}->{$field})) {
		$config_piece->{$entry}->{$field} =
		  [ $config_piece->{$entry}->{$field} ];
	  }
	}
  }
  delete($config_piece->{'Force_to_array'});
} # End: sub _swap_arrays_for_scalars

sub chk_params {
#
# Convenience Method to start check pgreet
# configuration parameters to see if they make
# sense for the application.  Calls recursive
# internal method _chk_params_helper to do the
# real work.
#
  my $self = shift;

  my $to_test = $self->{'config'};
  my $test_results = {};

  $self->_chk_params_helper($to_test, \%check_configs, $test_results);
  return($test_results);

}

sub _chk_params_helper {
#
# Go through list of configuration parameters and
# apply String::Checker tests as appropriate.  If
# parameter has a nexted hash reference, process
# the reference recursively as needed.
#
  my $self = shift;
  my $to_test = shift;
  my $chk_conf_ref = shift;
  my $test_results = shift;

  # Loop through every configuration parameter.
  foreach my $param (keys(%{$to_test})) {
	# Is this a reference to more parameters?
	if ((ref($to_test->{$param}) eq 'HASH') and
		(ref($chk_conf_ref->{$param}) eq 'HASH')
		) {
	      # If so recursively call subroutine to process hash references
		  $self->_chk_params_helper($to_test->{$param},
									$chk_conf_ref->{$param},
									$test_results
								   );
		}
	    # Are tests defined for this parameter?
		elsif (exists($chk_conf_ref->{$param})) {
		  # If so, perform tests
		  my $result =
			String::Checker::checkstring($to_test->{$param},
										 $chk_conf_ref->{$param}
										);
		  # If any tests failed, add them to hash of param with failed tests.
		  if(@{$result}) {
			$test_results->{$param} = $result;
		  }
		}
  }
} # end sub _chk_params_helper

sub cache_site {
#
# Method to cache the read of a secondary ecard site
# on the primary object to avoid unnecessary disk
# reloading.
#
  my $self = shift;
  my $config_file = shift;
  my $secondary_obj = shift;

  return($self->{'secondary_cache'}->{$config_file} = $secondary_obj);

}

sub fetch_cache_site {
#
# Method to return value of a previously cached
# secondary ecard site configuration object.
#
  my $self = shift;
  my $config_file = shift;

  return($self->{'secondary_cache'}->{$config_file});

}

1;