File Coverage

blib/lib/Rose/Conf/FileBased.pm

Criterion	Covered	Total	%
statement	135	158	85.4
branch	45	72	62.5
condition	21	31	67.7
subroutine	17	18	94.4
pod	3	5	60.0
total	221	284	77.8

package Rose::Conf::FileBased;

use strict;

use Carp();
use File::Spec;

use Rose::Conf;
require Tie::Hash;
our @ISA = qw(Rose::Conf Tie::StdHash);

our($CONF_ROOT, %Refresh_Time, $APACHE_CONF_PATH);

our $REFRESH_TIMEOUT = 60 * 15; # in seconds

our $CONF_SUFFIX     = '.conf';
our $LOCAL_CONF_FILE = 'local' . $CONF_SUFFIX;

use constant PRIVATE_PREFIX => '__' . __PACKAGE__ . '::';

our $VERSION = '0.02';

our $Debug = 0;

sub import
{
  my($class) = shift;

  local $Rose::Conf::ExportLevel;
  $Rose::Conf::ExportLevel++;

  $class->Rose::Conf::import(@_)  if(@_);

  my $conf = $class->conf_hash;

  my %save = %$conf;

  tie(%$conf, $class);

  %$conf = %save;
}

sub refresh
{
  my($class) = shift;

  #return  if(time < $Refresh_Time{$class} + $class->refresh_timeout);

  $class->_get_conf_root();

  if($CONF_ROOT && -d $CONF_ROOT)
  {
    #$Refresh_Time{$class} ||= 0;

    # Local conf file
    my $local_conf = File::Spec->catfile($CONF_ROOT, $LOCAL_CONF_FILE);

    if(-s $local_conf)
    {
      $class->_read_combined_conf($local_conf);
    }

    # Package-specific conf file
    my $class_conf = File::Spec->catfile($CONF_ROOT, $class . $CONF_SUFFIX);

    if(-s $class_conf)
    {
      $class->_read_class_conf($class_conf);
    }
    else
    {
      my $mod_class = $class;
      $mod_class =~ s/::/-/g;

      $class_conf = $CONF_ROOT . '/' . $mod_class . $CONF_SUFFIX;

      if(-s $class_conf)
      {
        $class->_read_class_conf($class_conf);
      }
    }
  }
}

sub FETCH
{
  my($hash, $key) = @_;

  unless(exists $hash->{PRIVATE_PREFIX . 'IMPORTED'} ||
         exists $hash->{PRIVATE_PREFIX . 'IMPORTING'})
  {
    $Debug && warn "FETCH $hash { $key }\n";

    $hash->{PRIVATE_PREFIX . 'IMPORTING'} = 1;

    my $class = ref($hash);

    $class->refresh();

    delete $hash->{PRIVATE_PREFIX . 'IMPORTING'};

    $hash->{PRIVATE_PREFIX . 'IMPORTED'}++;
  }

  ##
  ## This is broken for now...
  ##

  # Do not try refresh when looking up private keys
#   unless(index($key, PRIVATE_PREFIX) == 0)
#   {
#     my $class = ref $hash;
#
#     if(my $timeout = $class->refresh_timeout)
#     {
#       $Refresh_Time{$class} ||= 0;
#
#       if(time > $Refresh_Time{$class} + $timeout)
#       {
#         $class->refresh;
#       }
#     }
#   }

  Carp::croak "No such conf parameter: '$key'\n"
    unless(index($key, PRIVATE_PREFIX) == 0 || exists $hash->{$key});

  return $hash->{$key};
}

sub _get_conf_root
{
  $CONF_ROOT = $ENV{'ROSE_CONF_FILE_ROOT'};

  if(!$CONF_ROOT && exists $ENV{'MOD_PERL'} && require mod_perl && $mod_perl::VERSION < 1.99)
  {
    $CONF_ROOT = Apache->server_root_relative($APACHE_CONF_PATH);
    $CONF_ROOT = undef  unless(-d $CONF_ROOT);
  }
}

sub refresh_timeout
{
  my($class) = shift;

  no strict 'refs';

  if(@_)
  {
    return ${$class . '::REFRESH_TIMEOUT'} = shift;
  }

  my $timeout = ${$class . '::REFRESH_TIMEOUT'};

  $timeout = $REFRESH_TIMEOUT  unless(defined $timeout);

  return $timeout;
}

sub _parse_line
{
  my($class, $conf, $line, $file, $line_num) = @_;

  return  unless($line =~ /\S/);

  my($key, $val);

  if($line =~ /^((?:[^\\ \t]+|\\.)+)\s*=\s*(\S.*|$)/)
  {
    $key = $1;
    $val = $2;
  }
  elsif($line !~ /^(#|$)/)
  {
    die "Syntax error in $file on line $line_num: $line\n";
  }
  else { return }

  if(length($key) && length($val))
  {
    if($val =~ s/(['"])(.*)\1$/$2/)
    {
      if($1 eq '"' && index($val, '\\') >= 0)
      {
        $val = eval qq("$val");

        if($@)
        {
          die qq(Invalid value "$val" in $file on line $line_num: $@\n);
        }
      }
    }

    # Hash sub-key access
    if($key =~ m/^(?:[^\\: \t]+|\\.)+:/)
    {
      my $original_key = $key;

      if($key =~ /^(?:[^\\: \t]+|\\.)+:$/)
      {
        Carp::croak qq($class - Invalid hash sub-key access: "$key", ),
        qq(missing key name after final ':' in $file line $line_num);
      }

      my @parts;
      my $param = $conf;
      my $prev_param;

      while($key =~ m/\G((?:[^\\: \t]+|\\.)+)(?::|$)/g)
      {
        $prev_param = $param;
        $param = $param->{$1} ||= {};
        push(@parts, $1);
        $parts[-1] =~ s{\\(.)}{$1}g;
      }

      $Debug && warn "\$${class}::CONF{", join('}{', @parts), "} = $val\n";

      $prev_param->{$parts[-1]} = $val;
      $key = $original_key;
    }
    else
    {
      $key =~ s{\\(.)}{$1}g;
      $Debug && warn "\$${class}::CONF{$key} = $val\n";
      $conf->{$key} = $val;
      $key =~ s{:}{\\:}g;
    }
  }
  else
  {
    $Debug && warn "\$${class}::CONF{$key} = undef\n";
    $conf->{$key} = undef;
    $key =~ s{:}{\\:}g;
  }

  $conf->{PRIVATE_PREFIX . 'MODIFIED'}{$key} =
  {
    file        => $file,
    line_number => $line_num,
    #time        => time(),
  };
}

sub _read_class_conf
{
  my($class, $file) = @_;

  unless(open(CONF, $file))
  {
    warn "Could not open $file: $!";
    return;
  }

  #$Refresh_Time{$class} = time;

  my $conf = $class->conf_hash;

  while()
  {
    s/^\s+//;
    s/\s+$//;

    $class->_parse_line($conf, $_, $file, $.);
  }

  close(CONF);
}

sub _read_combined_conf
{
  my($class, $file) = @_;

  my $conf_fh;

  unless(open($conf_fh, $file))
  {
    warn "Could not open $file: $!";
    return;
  }

  #$Refresh_Time{$class} = time;

  my $conf = $class->conf_hash;

  my $in_domain = 0;

  my $in_domain_re  = qr(^CLASS\s+$class$);
  my $out_domain_re = qr(^CLASS\s*(?!=));

  while(<$conf_fh>)
  {
    s/^\s+//;
    s/\s+$//;

    if(/$in_domain_re/)
    {
      $in_domain = 1;
      next;
    }
    elsif($in_domain && /$out_domain_re/)
    {
      $in_domain = 0;
    }

    next  unless($in_domain);

    $class->_parse_line($conf, $_, $file, $.);
  }

  close($conf_fh);
}

sub local_conf_keys
{
  my($class) = shift;

  my $conf = $class->conf_hash;

  return keys(%{$conf->{PRIVATE_PREFIX . 'MODIFIED'}});
}

sub local_conf_setting
{
  my($class, $key) = @_;

  Carp::croak "Cannot get setting without $key"  unless(defined($key));

  my $conf = $class->conf_hash;

  return  unless($conf->{PRIVATE_PREFIX . 'MODIFIED'}{$key});

  return bless($conf->{PRIVATE_PREFIX . 'MODIFIED'}{$key}, 'Rose::Conf::File::Setting');
}

sub local_conf_value
{
  my($class, $key) = @_;

  Carp::croak "Cannot get setting without $key"  unless(defined($key));

  $class->local_conf_setting($key) || return undef;

  if($key =~ m/^(?:[^\\: \t]+|\\.)+:/)
  {
    if($key =~ /^(?:[^\\: \t]+|\\.)+:$/)
    {
      Carp::croak qq($class - Invalid hash sub-key access: "$key" - missing key name after final ':');
    }

    my @parts;
    my $param = $class->conf_hash;
    my $prev_param;

    while($key =~ m/\G((?:[^\\: \t]+|\\.)+)(?::|$)/g)
    {
      $prev_param = $param;
      $param = $param->{$1} ||= {};
      push(@parts, $1);
      $parts[-1] =~ s{\\(.)}{$1}g;
    }

    $Debug && warn "Get local conf value for \$${class}::CONF{", join('}{', @parts), "}\n";

    return $prev_param->{$parts[-1]};
  }

  $key =~ s{\\:}{:}g;
  return $class->param($key);
}

BEGIN
{
  $APACHE_CONF_PATH = 'conf/perl';

  #_get_conf_root();

  require Rose::Object;
  @Rose::Conf::File::Setting::ISA = qw(Rose::Object);
}

1;

# =item B
#
# If an argument is provided, sets the class's refresh timeout to SECS
# seconds.  Returns the class's current refresh timeout in seconds.
#
# The refresh timeout is used to determine when (if ever) to refresh the
# configuration hash by re-reading the (possibly changed) configuration
# file(s).  The configuration file(s) will only be re-read if they have
# been modified since they were last read (as determined by the files'
# "mtime").
#
# If the refresh timeout is zero, the files are never re-read.  The
# default refresh timeout is 15 minutes.

__END__