HoneyClient::Util::Config - Perl extension to provide a generic interface

  use HoneyClient::Util::Config qw(getVar);

  my $address = undef;

  # Fetch the value of "address" using the default namespace.
  $address = getVar(name => "address");

  # Fetch the value of "address" using the "HoneyClient::Agent::Driver" namespace.
  $address = getVar(name      => "address", 
                    namespace => "HoneyClient::Agent::Driver");

  # Fetch the value of "address" using the "HoneyClient::Manager" namespace.
  $address = getVar(name      => "address", 
                    namespace => "HoneyClient::Manager");

  # Set the value of "address" using the default namespace
  setVar( name  => 'address',
          value => 'new_address' );

  # Set the value using a specified namespace
  setVar( name      => 'address',
          namespace => 'HoneyClient::Agent::Driver',
          value     => 'new_address' );

  <HoneyClient>
      <Agent>
          <Driver>
              <address>localhost</address>
          </Driver>
      </Agent>
  </HoneyClient>

  <HoneyClient>
      <Agent>
          <address>localhost</address>
      </Agent>
  </HoneyClient>

  <HoneyClient>
      <address>localhost</address>
  </HoneyClient>

  <HoneyClient>
      <foo>
          <bar>123</bar>
          <bar>456</bar>
          <yok>789</yok>
          <yok>xxx</yok>
      </foo>
  </HoneyClient>

  $hashref = {
      'bar' => [ '123', '456' ],
      'yok' => [ '789', 'xxx' ],
  }

  <HoneyClient>
      <foo>
          THIS_TEXT_WILL_BE_LOST
          <bar>123</bar>
          <bar>456</bar>
          <yok>789</yok>
          <yok>xxx</yok>
          <yok><CHILD>zzz</CHILD></yok>
      </foo>
  </HoneyClient>

  $hashref = {
      'bar' => [ '123', '456' ],
      'yok' => [ '789', 'xxx', 'zzz' ],
  }

#######################################################################
# Created on:  Apr 20, 2006
# Package:     HoneyClient::Util::Config
# File:        Config.pm
# Description: Generic access to the HoneyClient configuration file.
#
# CVS: $Id: Config.pm 781 2007-07-27 19:15:54Z kindlund $
#
# @author kindlund, flindiakos
#
# Copyright (C) 2007 The MITRE Corporation.  All rights reserved.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation, using version 2
# of the License.
# 
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
# 
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
# 02110-1301, USA.
#
#######################################################################

package HoneyClient::Util::Config;

use strict;
use warnings;
use Carp ();
use XML::XPath;
use XML::Tidy;
use Log::Log4perl qw(:easy);
use Sys::Syslog;
use Data::Dumper;
use Log::Dispatch::Syslog;

#######################################################################
# Module Initialization                                               #
#######################################################################

BEGIN {
    # Defines which functions can be called externally.
    require Exporter;
    our (@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);

    # Set our package version.
    $VERSION = 0.98;

    @ISA = qw(Exporter);

    # Symbols to export automatically
    @EXPORT = qw(getVar setVar);

    # Items to export into callers namespace by default. Note: do not export
    # names by default without a very good reason. Use EXPORT_OK instead.
    # Do not simply export all your public functions/methods/constants.

    # This allows declaration use HoneyClient::Util::Config ':all';
    # If you do not need this, moving things directly into @EXPORT or @EXPORT_OK
    # will save memory.

    %EXPORT_TAGS = (
        'all' => [ qw(getVar setVar) ],
    );

    # Symbols to autoexport (when qw(:all) tag is used)
    @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

    $SIG{PIPE} = 'IGNORE'; # Do not exit on broken pipes.
}
our (@EXPORT_OK, $VERSION);

#######################################################################

# Global Configuration Variables

# Relative path to the Global Configuration.
# Note: We leave this path relative, so that
# corresponding unit testing can work before
# we actually install the configuration
# file into /etc.
our $CONF_FILE = "etc/honeyclient.xml";

# The XPath object that points to the config file
our $xp;

# Temporarily Initialize Logging Subsystem
# Note: We use these sane values initially, until we can reinitialize
#       the logger with values from the global configuration file.
Log::Log4perl->init_once({
    "log4perl.rootLogger"                               => "INFO, Screen",
    "log4perl.appender.Screen"                          => "Log::Log4perl::Appender::ScreenColoredLevels",
    "log4perl.appender.Screen.stderr"                   => 0,
    "log4perl.appender.Screen.Threshold"                => "INFO",
    "log4perl.appender.Screen.layout"                   => "Log::Log4perl::Layout::PatternLayout",
    "log4perl.appender.Screen.layout.ConversionPattern" => "%d{yyyy-MM-dd HH:mm:ss} %5p [%M] (%F:%L) - %m%n",
});

# The global logging object.
our $LOG = get_logger();

# Make Dumper format more terse.
$Data::Dumper::Terse = 1;
$Data::Dumper::Indent = 0;

#######################################################################
# Private Methods Implemented                                         #
#######################################################################

# Helper function designed to read the global configuration file
#
# Inputs: config
# Outputs: None
sub _parseConfig {

    # Extract arguments.
    my ($class, $config) = @_;

    # Sanity check.  Make sure the file exists.
    if (!-f $config) {
        # Okay, if the relative path didn't work, try the absolute
        # path.
        $config = "/" . $config;
        if (!-f $config) {
            $LOG->fatal("Unable to parse global configuration file ($CONF_FILE)!");
            Carp::croak("Error: Unable to parse global configuration file ($CONF_FILE)!");
        }
        # The absolute path worked, update the global variable to reflect this.
        $CONF_FILE = $config;
    }

    # Read in the configuration settings.
    eval {
        $xp = XML::XPath->new(filename => $CONF_FILE);
    };

    # Sanity check
    if ($@ || !$xp->exists("HoneyClient")) {
        $LOG->fatal("Unable to parse global configuration file ($CONF_FILE)!" . $@);
        Carp::croak("Error: Unable to parse global configuration file ($CONF_FILE)!" . $@);
    }
}

# Helper function designed to check the arguments passed to getVar()
#
# Inputs: $args
# Outputs: None
sub _checkArgs{
    # Hashref of arguments
    our ($args) = @_;

    # Make sure we have args
    if (!%$args) {
        $LOG->fatal("No variables specified!");
        Carp::croak("Error: No variables specified!");
    }

    # Process the args
    #   If you do not specify a default value, it will croak if undefined
    _process('name');
    _process('namespace', caller(1)); # We want the namespace of the caller to getVar(),
                                      # not of the caller to _checkArgs(); hence, we
                                      # use caller(1).

    # Add any special statements to check for depending on the caller
    # Just specify the calling sub in the regex and any operations in the do{}
    #   Why can't perl actually have switch statements :(
    for((split(/::/,((caller(1))[3])))[-1]){
        /getVar/    && do {  };
        /setVar/    && do { _process('value') };
    }


    # Accepts the key to check and the default value.
    # If no default value is given, undef will be used
    sub _process{ 
        my ($name, $val) = @_;
        if ( !defined($args->{$name} )) { 
            $args->{$name} = $val; 

            # Sanity checking after
            unless( $args->{$name} ) { 
                $LOG->fatal("No variable $name specified!"); 
                Carp::croak("Error: No variable $name specified!"); 
            }
        } 
    }
}

#######################################################################
# Public Methods Implemented                                          #
#######################################################################

sub getVar {

    # Get the arguments and check their validity
    my (%args) = @_;
    _checkArgs(\%args);

    # Log resolved arguments.
    $LOG->debug(sub {
        # Make Dumper format more terse.
        $Data::Dumper::Terse = 1;
        $Data::Dumper::Indent = 0;
        Dumper(\%args);
    });
    
    # Get a copy of the original namespace.
    my $namespace = $args{namespace};

    # Fix the namespace so it is compatible with XPath
    $namespace =~ s/::/\//g; # Turn package delim :: into XPath delim /

    # Split the namespace into an array.
    my @ns = split(/\//, $namespace);

    # Check to make sure the namespace exists within our XML configuration.
    # XML::XPath does not know how to deal with unknown paths (even if the parent
    # path is known).  Thus, we recursively check the path's existance, providing
    # the first valid ancestor path found.
    while (!$xp->exists($namespace) and
           (scalar(@ns) > 1)) {
        pop(@ns);
        $namespace = join('/', @ns);
        @ns = split(/\//, $namespace);
    }

    # Get the nodeset that we need
    # The first string is the path that matches the node we want and all ancestors
    # The second string tells us whether to get the text() or an attribute
    my $exp = $namespace . "/ancestor-or-self::*/$args{name}" .
        (defined $args{attribute} ? "/attribute::" . $args{attribute} : "");
    my $nodeset = $xp->findnodes($exp);

    # The list of nodes required.  Because this is a top down list of the results,
    # if there are multiple results, we want the bottom one (most specific)
    if ($nodeset->size() == 0) {
        $LOG->warn("Warning: Unable to locate specified value in variable '" . 
                   $args{'name'} . "' using namespace '" . $args{'namespace'} . 
                   "' within the global configuration file ($CONF_FILE)!");
        return;
    }
    
    # Figure out if the (most specific) node has any children.
    my $parent = $nodeset->pop();
    $nodeset = $xp->findnodes("*", $parent);
    my $val = undef;
    if ($nodeset->size() <= 0) {
        # There are no child elements, thus stingify
        # all textual components.

        $val = $parent->string_value();

        # Trail leading and trailing whitespace 
        $val =~ s/^\s+|\s+$//g;
    } else { 

        # There are child elements; return a
        # hashtable accordingly.
        my @children = $nodeset->get_nodelist();

        # Now, build the hashtable of array references.
        $val = {};
        foreach my $child (@children) {
            push  (@{$val->{$child->getName()}}, $child->string_value());
        }
    }

    return $val;
}

sub setVar {
    # Get the arguments and check their validity
    my (%args) = @_;
    _checkArgs(\%args);

    # Log resolved arguments.
    $LOG->debug(sub {
        # Make Dumper format more terse.
        $Data::Dumper::Terse = 1;
        $Data::Dumper::Indent = 0;
        Dumper(\%args);
    });

    # Fix the namespace so it is compatible with XPath
    my $namespace = $args{namespace};
    $namespace =~ s/::/\//g; # Turn package delim :: into XPath delim /

    # Get the nodeset that we need
    # The first string is the path that matches the node we want
    # The second string tells us whether to get the text() or an attribute
    my $exp = $namespace . "/$args{name}" .
        (defined $args{attribute} ? "/attribute::" . $args{attribute} : "");
    if(!$xp->exists($exp)){
        $xp->createNode($exp);
    }
    $xp->setNodeText($exp,$args{value});

    # Create the tidy object with our document root and write out the stuff to the new conf_file
    my $tidy_obj = XML::Tidy->new(context => $xp->find('/'));
    $tidy_obj->tidy('    ');
    $tidy_obj->write($CONF_FILE);

    # Parse the conf_file again just for good measure
    _parseConfig(undef, $CONF_FILE);
}

#######################################################################

# Parse the global configuration file, upon using the package.
_parseConfig(undef, $CONF_FILE);

# Reinitialize Logging Subsystem
# TODO: Need to account for absolute "/etc" directories!
Log::Log4perl->init(getVar(name => "log_config"));

# Initialize Syslog Support
$Sys::Syslog::host = getVar(name => "syslog_address");

1;

#######################################################################
# Additional Module Documentation                                     #
#######################################################################

__END__

<!--
    vim: foldmarker==pod,=cut
-->