# -*- perl -*-

# Copyright (c) 2002 by Jeff Weisberg
# Author: Jeff Weisberg <argus @ tcp4me.com>
# Date: 2002-Dec-30 23:29 (EST)
# Function: configurable objects
#
# $Id: Configable.pm,v 1.11 2005/12/04 20:52:53 jaw Exp $

package Configable;

use strict;
use vars qw($doc);

$doc = {
    package => __PACKAGE__,
    file    => __FILE__,
    isa     => [ ],
    methods => {},
    versn   => '3.2',
    fields  =>  {
	name  => {},
	type  => {},
	quotp => {},
	subtypes => {},
	confck   => {},
	conferr  => {},
	notypos  => { descr => 'no typo complaints' }, 	
    },
};

# initialize from config data according to method described in $doc
# hmmm, perhaps $doc is a poor choice of names....

my %fieldcache;
my %hasattrcache;

sub init_from_config {
    my $me   = shift;
    my $doc  = shift;
    my $base = shift;

    my $f = $doc->{package};
    
    # the profiler didn't like this, so we cache the field list,
    # cuts time in half and reduces the number of has_attr calls
    if( my $ks = $fieldcache{$f}{$base} ){
	foreach my $k ( @$ks ){
	    my $x = init_field_from_config($me, $doc, $base, $k);
	}
    }else{
	my @f;
	foreach my $k (keys %{$doc->{fields}}){
	    # ignore fields that are not marked configurable
	    next unless has_attr($k, $doc, 'config');
	    my $keep = init_field_from_config($me, $doc, $base, $k);
	    next unless $keep;
	    push @f, $k;
	}
	$fieldcache{$f}{$base} = \@f;
    }
}

# return undef if base/key is ignored
sub init_field_from_config {
    my $me   = shift;
    my $doc  = shift;
    my $base = shift;
    my $fld  = shift;
    my( $v, $kk );

    return if( $base && $fld !~ /::/ );
    $kk = $fld;
    $kk =~ s/^($base)::// if $base;
    return if( $kk =~ /::/ );

    # for detecting config file typos
    $me->{confck}{$kk} = 1;

    # NB hasattrcache is full for this field
    my $attr = has_attr_hash($fld, $doc);
    
    # does this field inherit from parent if not set?
    if( $attr->{inherit} ){
	$v = inherit( $me, $kk );
    }elsif( $attr->{acl} ){
	$v = build_acl( $me, $kk );
    }else{
	$v = $me->{config}{$kk};
    }

    # if not set, is there a default
    $v = $doc->{fields}{$fld}{default} unless defined($v);

    return 1 unless defined $v;
    
    if( $attr->{bool} ){
	$v = ::ckbool($v);
    }
    
    # install value
    if( $base ){
	$me->{$base}{$kk} = $v;
    }else{
	$me->{$kk} = $v;
    }

    1;
}

# And he said unto him, I am the LORD that brought thee out of
# Ur of the Chaldees, to give thee this land to inherit it.
#     -- genesis 15:7
sub inherit {
    my $me    = shift;
    my $field = shift;
    
    $me->{confck}{$field} = 1;
    my $val = $me->{config}{$field};
    return $val if defined $val;
    # special case Host "hostname" {...}
    return $me->{name} if( $me->{type} eq 'Host' && $field eq 'hostname' );
    my $mom = $me->{parents}[0];
    return inherit($mom, $field) if $mom;
    return $Conf::Config{$field};
}

# build cumulative acl
sub build_acl {
    my $me = shift;
    my $field = shift;
    my( $pv, $mv, $v, %g );

    # parent values, then mine
    if( $me->{parents}[0] ){
	$pv = $me->{parents}[0]->build_acl($field) || '';
	# yes, this could be done smarter, ...
    }else{
	$pv = $Conf::Config{$field} || '';
    }
    $mv = $me->{config}{$field} || '';
    $v = "$pv $mv";

    # process directives, etc
    foreach my $g (split /\s+/, $v){
	if( $g eq '-ALL' ){
	    %g = ();
	    next;
	}
	if( $g =~ /^-(.*)/ ){
	    delete $g{$1};
	    next;
	}
	$g{$g} = 1;
    }

    $v = join ' ', keys %g;

    $v || undef;
}

# has_attr gets called for every field for every object (or about 500 times per object)
# at a 1000 objects, this adds up to some significant time
# memoize...

sub has_attr {
    my $field = shift;
    my $doc   = shift;
    my $attr  = shift;
    my( $v );

    my $c = $hasattrcache{ $doc->{package} }{$field};
    return $c->{$attr} if $c;

    $c = {};
    foreach my $a (@{$doc->{fields}{$field}{attrs}}){
	$c->{$a} = 1;
    }
    $hasattrcache{ $doc->{package} }{$field} = $c;

    $c->{$attr};
}

sub has_attr_hash {
    my $field = shift;
    my $doc   = shift;

    $hasattrcache{ $doc->{package} }{$field};
}

sub clearcache {
    %hasattrcache = ();
    %fieldcache = ();
}

# Error has no end.
#   -- Robert Browning, Paracelsus. Part iii.
sub check_typos {
    my $me = shift;
    my $cf = shift;

    return unless $cf;
    return if $me->{notypos};
    
    foreach my $k (keys %{$me->{config}}){
	next if $me->{confck}{$k};
	$cf->warning( "unused parameter '$k' - typo?" );
    }
}

sub gen_conf_decl {
    my $me  = shift;
    my $doc = shift;
    
    $me->{type}  . ' '
    . ($doc->{conf}{quotp} ? "\"$me->{name}\"" : $me->{name});
}

# generate config tree for object - in config file format
sub gen_conf {
    my $me = shift;
    my( $r, $d );

    $d = Doc::objdocs($me);
    $r = $me->gen_conf_decl($d);

    if( $d->{conf}{bodyp} || keys %{$me->{config}} ){
	$r .= " {\n";
	$r .= "\t# this object contained config errors\n"
	    if $me->{conferrs} && !$d->{conf}{notypos};
	foreach my $k (sort keys %{$me->{config}}){
	    my $v = $me->{config}{$k};
	    $v =~ s/\#/\\\#/g;
	    $v =~ s/\n/\\n\\\n/g;
	    $r .= "\t$k:\t$v";
	    $r .= "\t# unused parameter - typo?"
		unless $me->{confck}{$k} || $d->{conf}{notypos};
	    $r .= "\n";
	}
	if(exists $me->{children} || $me->{cronjobs}){
	    my $rc;
	    foreach my $c (@{$me->{cronjobs}}, @{$me->{children}}){
		$rc .= $c->gen_conf();
	    }
	    if( $rc ){
		$rc =~ s/^/\t/gm;
		$r .= "$rc";
	    }
	}
	$r .= "}";
    }
    
    $r .= "\n";
    $r;
}


1;

