eaiovnaovbqoebvqoeavibavo PropertyConfigurator.pm000064400000013531147635413160011326 0ustar00package Log::Log4perl::Config::PropertyConfigurator; use Log::Log4perl::Config::BaseConfigurator; use warnings; use strict; our @ISA = qw(Log::Log4perl::Config::BaseConfigurator); our %NOT_A_MULT_VALUE = map { $_ => 1 } qw(conversionpattern); #poor man's export *eval_if_perl = \&Log::Log4perl::Config::eval_if_perl; *compile_if_perl = \&Log::Log4perl::Config::compile_if_perl; *unlog4j = \&Log::Log4perl::Config::unlog4j; use constant _INTERNAL_DEBUG => 0; our $COMMENT_REGEX = qr/[#;!]/; ################################################ sub parse { ################################################ my($self, $newtext) = @_; $self->text($newtext) if defined $newtext; my $text = $self->{text}; die "Config parser has nothing to parse" unless defined $text; my $data = {}; my %var_subst = (); while (@$text) { local $_ = shift @$text; s/^\s*$COMMENT_REGEX.*//; next unless /\S/; my @parts = (); while (/(.+?)\\\s*$/) { my $prev = $1; my $next = shift(@$text); $next =~ s/^ +//g; #leading spaces $next =~ s/^$COMMENT_REGEX.*//; $_ = $prev. $next; chomp; } if(my($key, $val) = /(\S+?)\s*=\s*(.*)/) { my $key_org = $key; $val =~ s/\s+$//; # Everything could potentially be a variable assignment $var_subst{$key} = $val; # Substitute any variables $val =~ s/\$\{(.*?)\}/ Log::Log4perl::Config::var_subst($1, \%var_subst)/gex; $key = unlog4j($key); my $how_deep = 0; my $ptr = $data; for my $part (split /\.|::/, $key) { push @parts, $part; $ptr->{$part} = {} unless exists $ptr->{$part}; $ptr = $ptr->{$part}; ++$how_deep; } #here's where we deal with turning multiple values like this: # log4j.appender.jabbender.to = him@a.jabber.server # log4j.appender.jabbender.to = her@a.jabber.server #into an arrayref like this: #to => { value => # ["him\@a.jabber.server", "her\@a.jabber.server"] }, # # This only is allowed for properties of appenders # not listed in %NOT_A_MULT_VALUE (see top of file). if (exists $ptr->{value} && $how_deep > 2 && defined $parts[0] && lc($parts[0]) eq "appender" && defined $parts[2] && ! exists $NOT_A_MULT_VALUE{lc($parts[2])} ) { if (ref ($ptr->{value}) ne 'ARRAY') { my $temp = $ptr->{value}; $ptr->{value} = []; push (@{$ptr->{value}}, $temp); } push (@{$ptr->{value}}, $val); }else{ if(defined $ptr->{value}) { if(! $Log::Log4perl::Logger::NO_STRICT) { die "$key_org redefined"; } } $ptr->{value} = $val; } } } $self->{data} = $data; return $data; } ################################################ sub value { ################################################ my($self, $path) = @_; $path = unlog4j($path); my @p = split /::/, $path; my $found = 0; my $r = $self->{data}; while (my $n = shift @p) { if (exists $r->{$n}) { $r = $r->{$n}; $found = 1; } else { $found = 0; } } if($found and exists $r->{value}) { return $r->{value}; } else { return undef; } } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Config::PropertyConfigurator - reads properties file =head1 SYNOPSIS # This class is used internally by Log::Log4perl use Log::Log4perl::Config::PropertyConfigurator; my $conf = Log::Log4perl::Config::PropertyConfigurator->new(); $conf->file("l4p.conf"); $conf->parse(); # will die() on error my $value = $conf->value("log4perl.appender.LOGFILE.filename"); if(defined $value) { printf("The appender's file name is $value\n"); } else { printf("The appender's file name is not defined.\n"); } =head1 DESCRIPTION Initializes log4perl from a properties file, stuff like log4j.category.a.b.c.d = WARN, A1 log4j.category.a.b = INFO, A1 It also understands variable substitution, the following configuration is equivalent to the previous one: settings = WARN, A1 log4j.category.a.b.c.d = ${settings} log4j.category.a.b = INFO, A1 =head1 SEE ALSO Log::Log4perl::Config Log::Log4perl::Config::BaseConfigurator Log::Log4perl::Config::DOMConfigurator Log::Log4perl::Config::LDAPConfigurator (tbd!) =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. BaseConfigurator.pm000064400000020721147635413160010353 0ustar00package Log::Log4perl::Config::BaseConfigurator; use warnings; use strict; use constant _INTERNAL_DEBUG => 0; *eval_if_perl = \&Log::Log4perl::Config::eval_if_perl; *compile_if_perl = \&Log::Log4perl::Config::compile_if_perl; *leaf_path_to_hash = \&Log::Log4perl::Config::leaf_path_to_hash; ################################################ sub new { ################################################ my($class, %options) = @_; my $self = { utf8 => 0, %options, }; bless $self, $class; $self->file($self->{file}) if exists $self->{file}; $self->text($self->{text}) if exists $self->{text}; return $self; } ################################################ sub text { ################################################ my($self, $text) = @_; # $text is an array of scalars (lines) if(defined $text) { if(ref $text eq "ARRAY") { $self->{text} = $text; } else { $self->{text} = [split "\n", $text]; } } return $self->{text}; } ################################################ sub file { ################################################ my($self, $filename) = @_; open my $fh, "$filename" or die "Cannot open $filename ($!)"; if( $self->{ utf8 } ) { binmode $fh, ":utf8"; } $self->file_h_read( $fh ); close $fh; } ################################################ sub file_h_read { ################################################ my($self, $fh) = @_; # Dennis Gregorovic added this # to protect apps which are tinkering with $/ globally. local $/ = "\n"; $self->{text} = [<$fh>]; } ################################################ sub parse { ################################################ die __PACKAGE__ . "::parse() is a virtual method. " . "It must be implemented " . "in a derived class (currently: ", ref(shift), ")"; } ################################################ sub parse_post_process { ################################################ my($self, $data, $leaf_paths) = @_; # [ # 'category', # 'value', # 'WARN, Logfile' # ], # [ # 'appender', # 'Logfile', # 'value', # 'Log::Log4perl::Appender::File' # ], # [ # 'appender', # 'Logfile', # 'filename', # 'value', # 'test.log' # ], # [ # 'appender', # 'Logfile', # 'layout', # 'value', # 'Log::Log4perl::Layout::PatternLayout' # ], # [ # 'appender', # 'Logfile', # 'layout', # 'ConversionPattern', # 'value', # '%d %F{1} %L> %m %n' # ] for my $path ( @{ Log::Log4perl::Config::leaf_paths( $data )} ) { print "path=@$path\n" if _INTERNAL_DEBUG; if(0) { } elsif( $path->[0] eq "appender" and $path->[2] eq "trigger" ) { my $ref = leaf_path_to_hash( $path, $data ); my $code = compile_if_perl( $$ref ); if(_INTERNAL_DEBUG) { if($code) { print "Code compiled: $$ref\n"; } else { print "Not compiled: $$ref\n"; } } $$ref = $code if defined $code; } elsif ( $path->[0] eq "filter" ) { # do nothing } elsif ( $path->[0] eq "appender" and $path->[2] eq "warp_message" ) { # do nothing } elsif ( $path->[0] eq "appender" and $path->[3] eq "cspec" or $path->[1] eq "cspec" ) { # could be either # appender appndr layout cspec # or # PatternLayout cspec U value ... # # do nothing } else { my $ref = leaf_path_to_hash( $path, $data ); if(_INTERNAL_DEBUG) { print "Calling eval_if_perl on $$ref\n"; } $$ref = eval_if_perl( $$ref ); } } return $data; } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Config::BaseConfigurator - Configurator Base Class =head1 SYNOPSIS This is a virtual base class, all configurators should be derived from it. =head1 DESCRIPTION =head2 METHODS =over 4 =item C<< new >> Constructor, typically called like my $config_parser = SomeConfigParser->new( file => $file, ); my $data = $config_parser->parse(); Instead of C, the derived class C may define any type of configuration input medium (e.g. C 'http://foobar'>). It just has to make sure its C method will later pull the input data from the medium specified. The base class accepts a filename or a reference to an array of text lines: =over 4 =item C<< file >> Specifies a file which the C method later parses. =item C<< text >> Specifies a reference to an array of scalars, representing configuration records (typically lines of a file). Also accepts a simple scalar, which it splits at its newlines and transforms it into an array: my $config_parser = MyYAMLParser->new( text => ['foo: bar', 'baz: bam', ], ); my $data = $config_parser->parse(); =back If either C or C parameters have been specified in the constructor call, a later call to the configurator's C method will return a reference to an array of configuration text lines. This will typically be used by the C method to process the input. =item C<< parse >> Virtual method, needs to be defined by the derived class. =back =head2 Parser requirements =over 4 =item * If the parser provides variable substitution functionality, it has to implement it. =item * The parser's C method returns a reference to a hash of hashes (HoH). The top-most hash contains the top-level keywords (C, C) as keys, associated with values which are references to more deeply nested hashes. =item * The C prefix (e.g. as used in the PropertyConfigurator class) is stripped, it's not part in the HoH structure. =item * Each Log4perl config value is indicated by the C key, as in $data->{category}->{Bar}->{Twix}->{value} = "WARN, Logfile" =back =head2 EXAMPLES The following Log::Log4perl configuration: log4perl.category.Bar.Twix = WARN, Screen log4perl.appender.Screen = Log::Log4perl::Appender::File log4perl.appender.Screen.filename = test.log log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout needs to be transformed by the parser's C method into this data structure: { appender => { Screen => { layout => { value => "Log::Log4perl::Layout::SimpleLayout" }, value => "Log::Log4perl::Appender::Screen", }, }, category => { Bar => { Twix => { value => "WARN, Screen" } } } } For a full-fledged example, check out the sample YAML parser implementation in C. It uses a simple YAML syntax to specify the Log4perl configuration to illustrate the concept. =head1 SEE ALSO Log::Log4perl::Config::PropertyConfigurator Log::Log4perl::Config::DOMConfigurator Log::Log4perl::Config::LDAPConfigurator (tbd!) =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. DOMConfigurator.pm000064400000065256147635413160010134 0ustar00package Log::Log4perl::Config::DOMConfigurator; use Log::Log4perl::Config::BaseConfigurator; our @ISA = qw(Log::Log4perl::Config::BaseConfigurator); #todo # DONE(param-text) some params not attrs but values, like ... # DONE see DEBUG!!! below # NO, (really is only used for AsyncAppender) appender-ref in # DONE check multiple appenders in a category # DONE in Config.pm re URL loading, steal from XML::DOM # DONE, OK see PropConfigurator re importing unlog4j, eval_if_perl # NO (is specified in DTD) - need to handle 0/1, true/false? # DONEsee Config, need to check version of XML::DOM # OK user defined levels? see parse_level # OK make sure 2nd test is using log4perl constructs, not log4j # OK handle new filter stuff # make sure sample code actually works # try removing namespace prefixes in the xml use XML::DOM; use Log::Log4perl::Level; use strict; use constant _INTERNAL_DEBUG => 0; our $VERSION = 0.03; our $APPENDER_TAG = qr/^((log4j|log4perl):)?appender$/; our $FILTER_TAG = qr/^(log4perl:)?filter$/; our $FILTER_REF_TAG = qr/^(log4perl:)?filter-ref$/; #can't use ValParser here because we're using namespaces? #doesn't seem to work - kg 3/2003 our $PARSER_CLASS = 'XML::DOM::Parser'; our $LOG4J_PREFIX = 'log4j'; our $LOG4PERL_PREFIX = 'log4perl'; #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 $text = $self->{text}; 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, tag is unsupported in "; }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; # #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; # }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); } # }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 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 } } #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::DOMConfigurator - reads xml config files =head1 SYNOPSIS -------------------------- --using the log4j DTD-- -------------------------- -------------------------- --using the log4perl DTD-- -------------------------- mary@another.jabber.server sub { return sprintf "%1x", $$} sub {return 'thisistheGcspec'} INSERT INTO log4perltest (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) VALUES (?,?,?,?,?,?,?,?) =head1 DESCRIPTION This module implements an XML config, complementing the properties-style config described elsewhere. =head1 WHY "Why would I want my config in XML?" you ask. Well, there are a couple reasons you might want to. Maybe you have a personal preference for XML. Maybe you manage your config with other tools that have an affinity for XML, like XML-aware editors or automated config generators. Or maybe (and this is the big one) you don't like having to run your application just to check the syntax of your config file. By using an XML config and referencing a DTD, you can use a namespace-aware validating parser to see if your XML config at least follows the rules set in the DTD. =head1 HOW To reference a DTD, drop this in after the declaration in your config file: That tells the parser to validate your config against the DTD in "log4perl.dtd", which is available in the xml/ directory of the log4perl distribution. Note that you'll also need to grab the log4j-1.2.dtd from there as well, since the it's included by log4perl.dtd. Namespace-aware validating parsers are not the norm in Perl. But the Xerces project (http://xml.apache.org/xerces-c/index.html --lots of binaries available, even rpm's) does provide just such a parser that you can use like this: StdInParse -ns -v < my-log4perl-config.xml This module itself does not use a validating parser, the obvious one XML::DOM::ValParser doesn't seem to handle namespaces. =head1 WHY TWO DTDs The log4j DTD is from the log4j project, they designed it to handle their needs. log4perl has added some extensions to the original log4j functionality which needed some extensions to the log4j DTD. If you aren't using these features then you can validate your config against the log4j dtd and know that you're using unadulterated log4j config tags. The features added by the log4perl dtd are: =over 4 =item 1 oneMessagePerAppender global setting log4perl.oneMessagePerAppender=1 =item 2 globally defined user conversion specifiers log4perl.PatternLayout.cspec.G=sub { return "UID $< GID $("; } =item 3 appender-local custom conversion specifiers log4j.appender.appndr1.layout.cspec.K = sub {return sprintf "%1x", $$ } =item 4 nested options log4j.appender.jabbender = Log::Dispatch::Jabber #(note how these are nested under 'login') log4j.appender.jabbender.login.hostname = a.jabber.server log4j.appender.jabbender.login.port = 5222 log4j.appender.jabbender.login.username = bobjones =item 5 the log4perl-specific filters, see L, lots of examples in t/044XML-Filter.t, here's a short one: sub { /and that, too/ } =back So we needed to extend the log4j dtd to cover these additions. Now I could have just taken a 'steal this code' approach and mixed parts of the log4j dtd into a log4perl dtd, but that would be cut-n-paste programming. So I've used namespaces and =over 4 =item * replaced three elements: =over 4 =item handles #1) and accepts =item accepts and =item accepts custom cspecs for #3) =back =item * added a element (complementing the element) to handle #4) =item * added a root element to handle #2) =item * added which lets you put things like perl code into escaped CDATA between the tags, so you don't have to worry about escaping characters and quotes =item * added =back See the examples up in the L<"SYNOPSIS"> for how all that gets used. =head1 WHY NAMESPACES I liked the idea of using the log4j DTD I, so I used namespaces to extend it. If you really don't like having to type instead of just , you can make your own DTD combining the two DTDs and getting rid of the namespace prefixes. Then you can validate against that, and log4perl should accept it just fine. =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 ${currentsysadmin}@foo.com =head1 REQUIRES To use this module you need XML::DOM installed. To use the log4perl.dtd, you'll have to reference it in your XML config, and you'll also need to note that log4perl.dtd references the log4j dtd as "log4j-1.2.dtd", so your validator needs to be able to find that file as well. If you don't like having to schlep two files around, feel free to dump the contents of "log4j-1.2.dtd" into your "log4perl.dtd" file. =head1 CAVEATS You can't mix a multiple param-nesteds with the same name, I'm going to leave that for now, there's presently no need for a list of structs in the config. =head1 CHANGES 0.03 2/26/2003 Added support for log4perl extensions to the log4j dtd =head1 SEE ALSO t/038XML-DOM1.t, t/039XML-DOM2.t for examples xml/log4perl.dtd, xml/log4j-1.2.dtd Log::Log4perl::Config Log::Log4perl::Config::PropertyConfigurator Log::Log4perl::Config::LDAPConfigurator (coming soon!) The code is brazenly modeled on log4j's DOMConfigurator class, (by Christopher Taylor, Ceki Gülcü, and Anders Kristensen) and any perceived similarity is not coincidental. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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. Watch.pm000064400000024100147635413160006157 0ustar00package Log::Log4perl::Config::Watch; use constant _INTERNAL_DEBUG => 0; our $NEXT_CHECK_TIME; our $SIGNAL_CAUGHT; our $L4P_TEST_CHANGE_DETECTED; our $L4P_TEST_CHANGE_CHECKED; ########################################### sub new { ########################################### my($class, %options) = @_; my $self = { file => "", check_interval => 30, l4p_internal => 0, signal => undef, %options, _last_checked_at => 0, _last_timestamp => 0, }; bless $self, $class; if($self->{signal}) { # We're in signal mode, set up the handler print "Setting up signal handler for '$self->{signal}'\n" if _INTERNAL_DEBUG; # save old signal handlers; they belong to other appenders or # possibly something else in the consuming application my $old_sig_handler = $SIG{$self->{signal}}; $SIG{$self->{signal}} = sub { print "Caught $self->{signal} signal\n" if _INTERNAL_DEBUG; $self->force_next_check(); $old_sig_handler->(@_) if $old_sig_handler and ref $old_sig_handler eq 'CODE'; }; # Reset the marker. The handler is going to modify it. $self->{signal_caught} = 0; $SIGNAL_CAUGHT = 0 if $self->{l4p_internal}; } else { # Just called to initialize $self->change_detected(undef, 1); $self->file_has_moved(undef, 1); } return $self; } ########################################### sub force_next_check { ########################################### my($self) = @_; $self->{signal_caught} = 1; $self->{next_check_time} = 0; if( $self->{l4p_internal} ) { $SIGNAL_CAUGHT = 1; $NEXT_CHECK_TIME = 0; } } ########################################### sub force_next_check_reset { ########################################### my($self) = @_; $self->{signal_caught} = 0; $SIGNAL_CAUGHT = 0 if $self->{l4p_internal}; } ########################################### sub file { ########################################### my($self) = @_; return $self->{file}; } ########################################### sub signal { ########################################### my($self) = @_; return $self->{signal}; } ########################################### sub check_interval { ########################################### my($self) = @_; return $self->{check_interval}; } ########################################### sub file_has_moved { ########################################### my($self, $time, $force) = @_; my $task = sub { my @stat = stat($self->{file}); my $has_moved = 0; if(! $stat[0]) { # The file's gone, obviously it got moved or deleted. print "File is gone\n" if _INTERNAL_DEBUG; return 1; } my $current_inode = "$stat[0]:$stat[1]"; print "Current inode: $current_inode\n" if _INTERNAL_DEBUG; if(exists $self->{_file_inode} and $self->{_file_inode} ne $current_inode) { print "Inode changed from $self->{_file_inode} to ", "$current_inode\n" if _INTERNAL_DEBUG; $has_moved = 1; } $self->{_file_inode} = $current_inode; return $has_moved; }; return $self->check($time, $task, $force); } ########################################### sub change_detected { ########################################### my($self, $time, $force) = @_; my $task = sub { my @stat = stat($self->{file}); my $new_timestamp = $stat[9]; $L4P_TEST_CHANGE_CHECKED = 1; if(! defined $new_timestamp) { if($self->{l4p_internal}) { # The file is gone? Let it slide, we don't want L4p to re-read # the config now, it's gonna die. return undef; } $L4P_TEST_CHANGE_DETECTED = 1; return 1; } if($new_timestamp > $self->{_last_timestamp}) { $self->{_last_timestamp} = $new_timestamp; print "Change detected (file=$self->{file} store=$new_timestamp)\n" if _INTERNAL_DEBUG; $L4P_TEST_CHANGE_DETECTED = 1; return 1; # Has changed } print "$self->{file} unchanged (file=$new_timestamp ", "stored=$self->{_last_timestamp})!\n" if _INTERNAL_DEBUG; return ""; # Hasn't changed }; return $self->check($time, $task, $force); } ########################################### sub check { ########################################### my($self, $time, $task, $force) = @_; $time = time() unless defined $time; if( $self->{signal_caught} or $SIGNAL_CAUGHT ) { $force = 1; $self->force_next_check_reset(); print "Caught signal, forcing check\n" if _INTERNAL_DEBUG; } print "Soft check (file=$self->{file} time=$time)\n" if _INTERNAL_DEBUG; # Do we need to check? if(!$force and $self->{_last_checked_at} + $self->{check_interval} > $time) { print "No need to check\n" if _INTERNAL_DEBUG; return ""; # don't need to check, return false } $self->{_last_checked_at} = $time; # Set global var for optimizations in case we just have one watcher # (like in Log::Log4perl) $self->{next_check_time} = $time + $self->{check_interval}; $NEXT_CHECK_TIME = $self->{next_check_time} if $self->{l4p_internal}; print "Hard check (file=$self->{file} time=$time)\n" if _INTERNAL_DEBUG; return $task->($time); } 1; __END__ =encoding utf8 =head1 NAME Log::Log4perl::Config::Watch - Detect file changes =head1 SYNOPSIS use Log::Log4perl::Config::Watch; my $watcher = Log::Log4perl::Config::Watch->new( file => "/data/my.conf", check_interval => 30, ); while(1) { if($watcher->change_detected()) { print "Change detected!\n"; } sleep(1); } =head1 DESCRIPTION This module helps detecting changes in files. Although it comes with the C distribution, it can be used independently. The constructor defines the file to be watched and the check interval in seconds. Subsequent calls to C will =over 4 =item * return a false value immediately without doing physical file checks if C hasn't elapsed. =item * perform a physical test on the specified file if the number of seconds specified in C have elapsed since the last physical check. If the file's modification date has changed since the last physical check, it will return a true value, otherwise a false value is returned. =back Bottom line: C allows you to call the function C as often as you like, without paying the performing a significant performance penalty because file system operations are being performed (however, you pay the price of not knowing about file changes until C seconds have elapsed). The module clearly distinguishes system time from file system time. If your (e.g. NFS mounted) file system is off by a constant amount of time compared to the executing computer's clock, it'll just work fine. To disable the resource-saving delay feature, just set C to 0 and C will run a physical file test on every call. If you already have the current time available, you can pass it on to C as an optional parameter, like in change_detected($time) which then won't trigger a call to C, but use the value provided. =head2 SIGNAL MODE Instead of polling time and file changes, C can be instructed to set up a signal handler. If you call the constructor like my $watcher = Log::Log4perl::Config::Watch->new( file => "/data/my.conf", signal => 'HUP' ); then a signal handler will be installed, setting the object's variable C<$self-E{signal_caught}> to a true value when the signal arrives. Comes with all the problems that signal handlers go along with. =head2 TRIGGER CHECKS To trigger a physical file check on the next call to C regardless if C has expired or not, call $watcher->force_next_check(); on the watcher object. =head2 DETECT MOVED FILES The watcher can also be used to detect files that have moved. It will not only detect if a watched file has disappeared, but also if it has been replaced by a new file in the meantime. my $watcher = Log::Log4perl::Config::Watch->new( file => "/data/my.conf", check_interval => 30, ); while(1) { if($watcher->file_has_moved()) { print "File has moved!\n"; } sleep(1); } The parameters C and C limit the number of physical file system checks, simililarily as with C. =head1 LICENSE Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE and Kevin Goess Ecpan@goess.orgE. 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 , Kevin Goess 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.