LDAPConfigurator.pm | searchcode

/lib/Log/Log4perl/Config/LDAPConfigurator.pm

http://github.com/mschilli/log4perl
Perl | 790 lines | 189 code | 114 blank | 487 comment | 20 complexity | 727683f6b49e4efb32c5929eb8e1bece MD5 | raw file

#NOTE: this LDAP stuff is experimental, in progress,
#not meant to be used for ANYTHING yet --kg 5/2004

package Log::Log4perl::Config::LDAPConfigurator;
use Log::Log4perl::Config::BaseConfigurator;
our @ISA = qw(Log::Log4perl::Config::BaseConfigurator);

use Net::LDAP;
use URI;
use Log::Log4perl::Level;
use Data::Dump qw(dump); #DEBUG
use Carp;
use strict;

use constant _INTERNAL_DEBUG => 1;

our $VERSION = 0.01;

#poor man's export
*eval_if_perl = \&Log::Log4perl::Config::eval_if_perl;
*unlog4j      = \&Log::Log4perl::Config::unlog4j;


############################################
sub parse {
############################################
    my($self, $newtext) = @_;

    $self->text($newtext) if defined $newtext;

    my $uri = $self->{text}->[0];

    $uri = 
        URI->new($uri); #ldap://localhost/dc=testsystem,dc=log4perl,dc=goess,dc=org??sub?



    my ($userdn, $passwd, $ldap, $mesg, $host, $base, $searchString, $scope);

    $userdn = $ENV{LOG4PERL_LDAP_USERDN};   #cn=log4perluser,dc=people,dc=goess,dc=org
    $passwd = $ENV{LOG4PERL_LDAP_PWD};  #note not very secure
    #http://www.faqs.org/rfcs/rfc2255.html
    #   Some authentication methods, in particular reusable passwords sent to
    #   the server, may reveal easily-abused information to the remote server
    #   or to eavesdroppers in transit, and should not be used in URL
    #   processing unless explicitly permitted by policy.

    eval {
        #DEBUG need to check for presence of necessary strings
        $host = $uri->host;   #localhost
        $base = $uri->dn;    #"dc=testsystem,dc=log4perl,dc=goess,dc=org" ;
        $searchString = $uri->filter;#"(objectclass=*)";
        $scope = $uri->scope || 'sub';

        $ldap = Net::LDAP->new ( "localhost" ) or die "$@";

        $mesg = $ldap->bind ( $userdn,           
                             ($passwd ? (password => $passwd) : (noauth => 1)),
                              version => 3 ); 
    
        #DEBUG, check authentication failures
        if ( $mesg->code ) {
            die $mesg->error;
        }
    };
    if ($@) {
        die "log4perl: LDAP unable to bind to $uri:\n$@";
    }

    my $result = $ldap->search ( base    => $base,
                                 scope   => $scope,
                                 filter  => $searchString, #"sn=*"
                                 attrs   =>  [] , #arrayref
                                );

    #DEBUG where are errors here?
    #if ($result->code) {
    #    die $mesg->error;
    #}

    my $l4p_tree = {};

    foreach my $entry ($result->all_entries){
        my $objectclasses = join("\n",$entry->get_value('objectclass'));
        if ($objectclasses =~ /^log4(perl|j)Appender/m) { #DEBUG, make a constant?
            parse_appender($l4p_tree, $entry);

        }elsif ($objectclasses =~ /^log4(perl|j)Layout/m) { 
            parse_layout($l4p_tree, $entry);

        }elsif ($objectclasses =~ /^log4(perl|j)RootLogger/m) { 
            my $level = $entry->get_value("log4perlLevel");
            my @appenders = $entry->get_value("log4perlAppenderName");
            map {s/ +$//} @appenders;#ldap preserves trailing spaces :-(

            $l4p_tree->{category}{value} = $level;
            $l4p_tree->{category}{value} .= ", ".join(',',@appenders);

        }elsif ($objectclasses =~ /^log4(perl|j)(Logger|Category)/m) { 
            parse_category($l4p_tree, $entry);
        }else{
            ;#?
        }
    }

    #my $href = $result->as_struct;
    ##DEBUG, keys don't seem to be normalized?
    #dump $href;

    $mesg = $ldap->unbind;   # take down session

    return $l4p_tree;
}

sub parse_appender {
    my ($l4p_tree, $entry) = @_;
    #foreach my $attr ($entry->attributes) {
    #    print STDERR join( "\n ", $attr, $entry->get_value( $attr ) ), "\n";
    #}

    my $name = subst($entry->get_value("name"));

    my $l4p_branch = {};

    my $class = subst($entry->get_value("log4perlclass")); #DEBUG: handle log4j

    $l4p_branch->{value} = $class;

    print "looking at $name----------------------\n"  if _INTERNAL_DEBUG;

    $l4p_tree->{appender}{$name} = $l4p_branch;

    my ($attrname, $attrvalue);

    foreach ($entry->attributes) {
       /^objectclass$/i        && next;
       /^log4perlclass$/i      && next; #already handled

       #a gross kind of translation?
       /^log4perl/   && do {
            ($attrname = $_)  =~ s/log4perl//;
            $attrvalue = $entry->get_attribute($_);

            #note the '->[0]', log4perl doesn't
            #accept any multi-valued attributes, does it?
            #DEBUG
            $attrvalue = $attrvalue->[0] if (ref $attrvalue eq 'ARRAY');

            if (lc $attrvalue =~ /true/) {
               $attrvalue = 1;
            }elsif (lc $attrvalue eq 'false'){
               $attrvalue = 0;
            }

       };
       next unless $attrname && defined $attrvalue;

       $l4p_branch->{$attrname} = {value => $attrvalue};
                     

    }

}
sub parse_layout {
    my ($l4ptree, $entry) = @_;

    my $layout_tree = {};

    my $class_name = subst($entry->get_value("log4perlLayoutClass"));

    my $dn = $entry->dn;

    $dn =~ /^name=layout,name=(.+?),/ 
       or do {
         warn "layout object at $dn doesn't seem to be in a spot wanting a layout, ",
               "like 'name=layout,name=<some appender>";
         return;
       };
    my $appender_name = $1;

    $l4ptree->{appender}{$appender_name}{layout} = $layout_tree;

    $layout_tree->{value} = $class_name;

    foreach ($entry->attributes) {
       /^objectclass$/i        && next;
       /^name$/i               && next; #is always 'layout'
       /^log4perlLayoutClass$/ && next; #already handled
       /^log4perlConversionPattern$/       && do 
          {
             $layout_tree->{ConversionPattern}
                   = {value => $entry->get_attribute($_)};
             next;
          };

    }

    return $layout_tree;
    
}

sub parse_category {
   my ($l4p_tree, $entry) = @_;

    my $category_name = subst($entry->get_value("log4perlCategoryName"));

    print STDERR "parsing category $category_name\n";

    $l4p_tree->{category} ||= {};
 
    my $ptr = $l4p_tree->{category};

    for my $part (split /\.|::/, $category_name) {
        $ptr->{$part} = {} unless exists $ptr->{$part};
        $ptr = $ptr->{$part};
    }

    my $l4p_branch = $ptr;

    my $level = $entry->get_value("log4perlLevel");
    my @appenders = $entry->get_value("log4perlAppenderName");
    map {s/ +$//} @appenders;#ldap preserves trailing spaces :-(

    $l4p_branch->{value} = $level;

    $l4p_branch->{value} .= ", ".join(',',@appenders);

    return $l4p_tree;
    
}



#all other code below is still from DOMConfigurator (kg 5/12)

=pod

    my $parser = $PARSER_CLASS->new;
    my $doc = $parser->parse (join('',@$text));


    my $l4p_tree = {};
    
    my $config = $doc->getElementsByTagName("$LOG4J_PREFIX:configuration")->item(0)||
                 $doc->getElementsByTagName("$LOG4PERL_PREFIX:configuration")->item(0);

    my $threshold = uc(subst($config->getAttribute('threshold')));
    if ($threshold) {
        $l4p_tree->{threshold}{value} = $threshold;
    }

    if (subst($config->getAttribute('oneMessagePerAppender')) eq 'true') {
        $l4p_tree->{oneMessagePerAppender}{value} = 1;
    }

    for my $kid ($config->getChildNodes){

        next unless $kid->getNodeType == ELEMENT_NODE;

        my $tag_name = $kid->getTagName;

        if ($tag_name =~ $APPENDER_TAG) {
            &parse_appender($l4p_tree, $kid);

        }elsif ($tag_name eq 'category' || $tag_name eq 'logger'){
            &parse_category($l4p_tree, $kid);
            #Treating them the same is not entirely accurate, 
            #the dtd says 'logger' doesn't accept
            #a 'class' attribute while 'category' does.
            #But that's ok, log4perl doesn't do anything with that attribute

        }elsif ($tag_name eq 'root'){
            &parse_root($l4p_tree, $kid);

        }elsif ($tag_name =~ $FILTER_TAG){
            #parse log4perl's chainable boolean filters
            &parse_l4p_filter($l4p_tree, $kid);

        }elsif ($tag_name eq 'renderer'){
            warn "Log4perl: ignoring renderer tag in config, unimplemented";
            #"log4j will render the content of the log message according to 
            # user specified criteria. For example, if you frequently need 
            # to log Oranges, an object type used in your current project, 
            # then you can register an OrangeRenderer that will be invoked 
            # whenever an orange needs to be logged. "
         
        }elsif ($tag_name eq 'PatternLayout'){#log4perl only
            &parse_patternlayout($l4p_tree, $kid);
        }
    }
    $doc->dispose;

    return $l4p_tree;

}

#this is just for toplevel log4perl.PatternLayout tags
#holding the custome cspecs
sub parse_patternlayout {
    my ($l4p_tree, $node) = @_;

    my $l4p_branch = {};

    for my $child ($node->getChildNodes) {
        next unless $child->getNodeType == ELEMENT_NODE;

        my $name = subst($child->getAttribute('name'));
        my $value;

        foreach my $grandkid ($child->getChildNodes){
            if ($grandkid->getNodeType == TEXT_NODE) {
                $value .= $grandkid->getData;
            }
        }
        $value =~ s/^ +//;  #just to make the unit tests pass
        $value =~ s/ +$//;
        $l4p_branch->{$name}{value} = subst($value);
    }
    $l4p_tree->{PatternLayout}{cspec} = $l4p_branch;
}


#for parsing the root logger, if any
sub parse_root {
    my ($l4p_tree, $node) = @_;

    my $l4p_branch = {};

    &parse_children_of_logger_element($l4p_branch, $node);

    $l4p_tree->{category}{value} = $l4p_branch->{value};

}


#this parses a custom log4perl-specific filter set up under
#the root element, as opposed to children of the appenders
sub parse_l4p_filter {
    my ($l4p_tree, $node) = @_;

    my $l4p_branch = {};

    my $name = subst($node->getAttribute('name'));

    my $class = subst($node->getAttribute('class'));
    my $value = subst($node->getAttribute('value'));

    if ($class && $value) {
        die "Log4perl: only one of class or value allowed, not both, "
            ."in XMLConfig filter '$name'";
    }elsif ($class || $value){
        $l4p_branch->{value} = ($value || $class);

    }

    for my $child ($node->getChildNodes) {

        if ($child->getNodeType == ELEMENT_NODE){

            my $tag_name = $child->getTagName();

            if ($tag_name =~ /^(param|param-nested|param-text)$/) {
                &parse_any_param($l4p_branch, $child);
            }
        }elsif ($child->getNodeType == TEXT_NODE){
            my $text = $child->getData;
            next unless $text =~ /\S/;
            if ($class && $value) {
                die "Log4perl: only one of class, value or PCDATA allowed, "
                    ."in XMLConfig filter '$name'";
            }
            $l4p_branch->{value} .= subst($text); 
        }
    }

    $l4p_tree->{filter}{$name} = $l4p_branch;
}

   
#for parsing a category/logger element
sub parse_category {
    my ($l4p_tree, $node) = @_;

    my $name = subst($node->getAttribute('name'));

    $l4p_tree->{category} ||= {};
 
    my $ptr = $l4p_tree->{category};

    for my $part (split /\.|::/, $name) {
        $ptr->{$part} = {} unless exists $ptr->{$part};
        $ptr = $ptr->{$part};
    }

    my $l4p_branch = $ptr;

    my $class = subst($node->getAttribute('class'));
    $class                       && 
       $class ne 'Log::Log4perl' &&
       $class ne 'org.apache.log4j.Logger' &&
       warn "setting category $name to class $class ignored, only Log::Log4perl implemented";

    #this is kind of funky, additivity has its own spot in the tree
    my $additivity = subst(subst($node->getAttribute('additivity')));
    if (length $additivity > 0) {
        $l4p_tree->{additivity} ||= {};
        my $add_ptr = $l4p_tree->{additivity};

        for my $part (split /\.|::/, $name) {
            $add_ptr->{$part} = {} unless exists $add_ptr->{$part};
            $add_ptr = $add_ptr->{$part};
        }
        $add_ptr->{value} = &parse_boolean($additivity);
    }

    &parse_children_of_logger_element($l4p_branch, $node);
}

# parses the children of a category element
sub parse_children_of_logger_element {
    my ($l4p_branch, $node) = @_;

    my (@appenders, $priority);

    for my $child ($node->getChildNodes) {
        next unless $child->getNodeType == ELEMENT_NODE;
            
        my $tag_name = $child->getTagName();

        if ($tag_name eq 'param') {
            my $name = subst($child->getAttribute('name'));
            my $value = subst($child->getAttribute('value'));
            if ($value =~ /^(all|debug|info|warn|error|fatal|off|null)^/) {
                $value = uc $value;
            }
            $l4p_branch->{$name} = {value => $value};
        
        }elsif ($tag_name eq 'appender-ref'){
            push @appenders, subst($child->getAttribute('ref'));
            
        }elsif ($tag_name eq 'level' || $tag_name eq 'priority'){
            $priority = &parse_level($child);
        }
    }
    $l4p_branch->{value} = $priority.', '.join(',', @appenders);
    
    return;
}


sub parse_level {
    my $node = shift;

    my $level = uc (subst($node->getAttribute('value')));

    die "Log4perl: invalid level in config: $level"
        unless Log::Log4perl::Level::is_valid($level);

    return $level;
}



sub parse_appender {
    my ($l4p_tree, $node) = @_;

    my $name = subst($node->getAttribute("name"));

    my $l4p_branch = {};

    my $class = subst($node->getAttribute("class"));

    $l4p_branch->{value} = $class;

    print "looking at $name----------------------\n"  if _INTERNAL_DEBUG;

    for my $child ($node->getChildNodes) {
        next unless $child->getNodeType == ELEMENT_NODE;

        my $tag_name = $child->getTagName();

        my $name = unlog4j(subst($child->getAttribute('name')));

        if ($tag_name =~ /^(param|param-nested|param-text)$/) {

            &parse_any_param($l4p_branch, $child);

            my $value;

        }elsif ($tag_name =~ /($LOG4PERL_PREFIX:)?layout/){
            $l4p_branch->{layout} = parse_layout($child);

        }elsif ($tag_name =~  $FILTER_TAG){
            $l4p_branch->{Filter} = parse_filter($child);

        }elsif ($tag_name =~ $FILTER_REF_TAG){
            $l4p_branch->{Filter} = parse_filter_ref($child);

        }elsif ($tag_name eq 'errorHandler'){
            die "errorHandlers not supported yet";

        }elsif ($tag_name eq 'appender-ref'){
            #dtd: Appenders may also reference (or include) other appenders. 
            #This feature in log4j is only for appenders who implement the 
            #AppenderAttachable interface, and the only one that does that
            #is the AsyncAppender, which writes logs in a separate thread.
            #I don't see the need to support this on the perl side any 
            #time soon.  --kg 3/2003
            die "Log4perl: in config file, <appender-ref> tag is unsupported in <appender>";
        }else{
            die "Log4perl: in config file, <$tag_name> is unsupported\n";
        }
    }
    $l4p_tree->{appender}{$name} = $l4p_branch;
}

sub parse_any_param {
    my ($l4p_branch, $child) = @_;

    my $tag_name = $child->getTagName();
    my $name = subst($child->getAttribute('name'));
    my $value;

    print "parse_any_param: <$tag_name name=$name\n" if _INTERNAL_DEBUG;

    #<param-nested>
    #note we don't set it to { value => $value }
    #and we don't test for multiple values
    if ($tag_name eq 'param-nested'){
        
        if ($l4p_branch->{$name}){
            die "Log4perl: in config file, multiple param-nested tags for $name not supported";
        }
        $l4p_branch->{$name} = &parse_param_nested($child); 

        return;

    #<param>
    }elsif ($tag_name eq 'param') {

         $value = subst($child->getAttribute('value'));

         print "parse_param_nested: got param $name = $value\n"  
             if _INTERNAL_DEBUG;
        
         if ($value =~ /^(all|debug|info|warn|error|fatal|off|null)$/) {
             $value = uc $value;
         }

         if ($name !~ /warp_message|filter/ &&
            $child->getParentNode->getAttribute('name') ne 'cspec') {
            $value = eval_if_perl($value);
         }
    #<param-text>
    }elsif ($tag_name eq 'param-text'){

        foreach my $grandkid ($child->getChildNodes){
            if ($grandkid->getNodeType == TEXT_NODE) {
                $value .= $grandkid->getData;
            }
        }
        if ($name !~ /warp_message|filter/ &&
            $child->getParentNode->getAttribute('name') ne 'cspec') {
            $value = eval_if_perl($value);
        }
    }

    $value = subst($value);

     #multiple values for the same param name
     if (defined $l4p_branch->{$name}{value} ) {
         if (ref $l4p_branch->{$name}{value} ne 'ARRAY'){
             my $temp = $l4p_branch->{$name}{value};
             $l4p_branch->{$name}{value} = [$temp];
         }
         push @{$l4p_branch->{$name}{value}}, $value;
     }else{
         $l4p_branch->{$name} = {value => $value};
     }
}

#handles an appender's <param-nested> elements
sub parse_param_nested {
    my ($node) = shift;

    my $l4p_branch = {};

    for my $child ($node->getChildNodes) {
        next unless $child->getNodeType == ELEMENT_NODE;

        my $tag_name = $child->getTagName();

        if ($tag_name =~ /^param|param-nested|param-text$/) {
            &parse_any_param($l4p_branch, $child);
        }
    }

    return $l4p_branch;
}

#this handles filters that are children of appenders, as opposed
#to the custom filters that go under the root element
sub parse_filter {
    my $node = shift;

    my $filter_tree = {};

    my $class_name = subst($node->getAttribute('class'));

    $filter_tree->{value} = $class_name;

    print "\tparsing filter on class $class_name\n"  if _INTERNAL_DEBUG;  

    for my $child ($node->getChildNodes) {
        next unless $child->getNodeType == ELEMENT_NODE;

        my $tag_name = $child->getTagName();

        if ($tag_name =~ 'param|param-nested|param-text') {
            &parse_any_param($filter_tree, $child);
        
        }else{
            die "Log4perl: don't know what to do with a ".$child->getTagName()
                ."inside a filter element";
        }
    }
    return $filter_tree;
}

sub parse_filter_ref {
    my $node = shift;

    my $filter_tree = {};

    my $filter_id = subst($node->getAttribute('id'));

    $filter_tree->{value} = $filter_id;

    return $filter_tree;
}



sub parse_layout {
    my $node = shift;

    my $layout_tree = {};

    my $class_name = subst($node->getAttribute('class'));
    
    $layout_tree->{value} = $class_name;
    #
    print "\tparsing layout $class_name\n"  if _INTERNAL_DEBUG;  
    for my $child ($node->getChildNodes) {
        next unless $child->getNodeType == ELEMENT_NODE;
        if ($child->getTagName() eq 'param') {
            my $name = subst($child->getAttribute('name'));
            my $value = subst($child->getAttribute('value'));
            if ($value =~ /^(all|debug|info|warn|error|fatal|off|null)$/) {
                $value = uc $value;
            }
            print "\tparse_layout: got param $name = $value\n"
                if _INTERNAL_DEBUG;
            $layout_tree->{$name}{value} = $value;  

        }elsif ($child->getTagName() eq 'cspec') {
            my $name = subst($child->getAttribute('name'));
            my $value;
            foreach my $grandkid ($child->getChildNodes){
                if ($grandkid->getNodeType == TEXT_NODE) {
                    $value .= $grandkid->getData;
                }
            }
            $value =~ s/^ +//;
            $value =~ s/ +$//;
            $layout_tree->{cspec}{$name}{value} = subst($value);  
        }
    }
    return $layout_tree;
}

sub parse_boolean {
    my $a = shift;

    if ($a eq '0' || lc $a eq 'false') {
        return '0';
    }elsif ($a eq '1' || lc $a eq 'true'){
        return '1';
    }else{
        return $a; #probably an error, punt
    }
}

=cut 

#this handles variable substitution
sub subst {
    my $val = shift;

    $val =~ s/\${(.*?)}/
                      Log::Log4perl::Config::var_subst($1, {})/gex;
    return $val;
}




1;

__END__

=encoding utf8

=head1 NAME

Log::Log4perl::Config::LDAPConfigurator - configures log4perl via LDAP

=head1 SYNOPSIS


=head1 DESCRIPTION

This module implements 

=head1 WHY


=head1 HOW

=head1 VARIABLE SUBSTITUTION

???

This supports variable substitution like C<${foobar}> in text and in 
attribute values except for appender-ref.  If an environment variable is defined
for that name, its value is substituted. So you can do stuff like

        <param name="${hostname}" value="${hostnameval}.foo.com"/>
        <param-text name="to">${currentsysadmin}@foo.com</param-text>


=head1 REQUIRES

=head1 CAVEATS

=head1 CHANGES

0.01 2004-05-12 initial version

=head1 SEE ALSO

t/047-ldap.t


ldap/log4perl.schema DEBUG

Log::Log4perl::Config

=head1 LICENSE

Copyright 2002-2013 by Mike Schilli E<lt>m@perlmeister.comE<gt> 
and Kevin Goess E<lt>cpan@goess.orgE<gt>.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself. 

=head1 AUTHOR

Please contribute patches to the project on Github:

    http://github.com/mschilli/log4perl

Send bug reports or requests for enhancements to the authors via our

MAILING LIST (questions, bug reports, suggestions/patches): 
log4perl-devel@lists.sourceforge.net

Authors (please contact them via the list above, not directly):
Mike Schilli <m@perlmeister.com>,
Kevin Goess <cpan@goess.org>

Contributors (in alphabetical order):
Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton
Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony
Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy
Grundman, Paul Harrington, Alexander Hartmaier  David Hull, 
Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, 
Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, 
Lars Thegler, David Viner, Mac Yang.