diff options
163 files changed, 35657 insertions, 0 deletions
diff --git a/.licensizer.yml b/.licensizer.yml new file mode 100644 index 0000000..05c79c2 --- /dev/null +++ b/.licensizer.yml @@ -0,0 +1,30 @@ +# .licensizer.yml +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. + +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. @@ -0,0 +1,1194 @@ +################################################## + Revision history for Log::Log4perl +################################################## + +1.46 (2014/10/31) + * (ms) Fixed Gianni's utc time test for machines set to utc time. + +1.45 (2014/10/25) + * (ms) fgeueke provided a pull request for short-circuiting boolean + filters: https://github.com/mschilli/log4perl/pull/48 + * (ms) [rt.cpan.org #94009] Tim Bunce had requested that the + PatternLayout's %m specifier allow for fixed indentation, + variable indentation, and at the same time permit the use + of the chomp option. Added with tests and docs. + * (ms) Gianni Ceccarelli added the log4perl.utcDateTimes config + option to select UTC instead of localtime: + https://github.com/mschilli/log4perl/pull/53 + * (ms) @bokutin fixed Catalyst.pm buffer flush: + https://github.com/mschilli/log4perl/pull/51 + https://github.com/mschilli/log4perl/issues/54 + +1.44 (2014/05/17) + * (ms) Skipped mkpath umask tests on Win32 which doesn't support it + properly. + * (ms) Requiring core module File::Path 2.06_06, which has remove_tree() + (fixes test suite for ancient perl-5.6.2). + * (ms) Brian Wightman fixed temporary file cleanup in the test suite + for Win32: https://github.com/mschilli/log4perl/pull/45 + +1.43 (2014/03/16) + * (ms) Added %m{indent} to indent multi-line messages according to the + PatternLayout (inspired by Wolfgang Pecho) + * (ms) [rt.cpan.org #84818] Deven T. Corzine suggested adding + a conditional use Win32 on Win32 platform to fix a + chicken-and-egg problem with the resurrector. + * (ms) Brian Wightman fixed Win32 log file cleanup in test suite + https://github.com/mschilli/log4perl/pull/39. New FAQ + entry on Win32 log file cleanup. + +1.42 (2013/07/25) + * (ms) BenRifkah Bergsten-Buret added ';!' for property configurator + comment delimiters: + https://github.com/mschilli/log4perl/issues/25 + * (ms) [rt.cpan.org 84723] Suppress error if close() in the file + appender in pipe mode returns "No child processes". + * (ms) Ronald J Kimball fixed a bug with the file appender's + create_at_logtime option in combination with + recreate_check_signal: + https://github.com/mschilli/log4perl/pull/28 + * (ms) Fixed additivity() modifications after init(): + https://github.com/mschilli/log4perl/issues/29 + * (ms) [rt.cpan.org 87191] Applied patch by Zefram for better + maintainable line number checks (and coping with 5.19 buggy + line numbering, cough, cough). + +1.41 (2013/04/21) + * (ms) [rt 81731] Added 'trace' level to Log4perl::Catalyst, as + suggested by Ashley Pond. + * (ms) Alexander Hartmaier added Log::Log4perl::Filter::MDC to filter + based on MDC key/value + * (ms) [rt.cpan.org 83193] The file appender now ignores owner/group + settings on all types of existing file system entries (previously, + this was only the case for actual files). + * (ms) [rt.cpan.org 84289] Documented Level.pm's isGreaterOrEqual() + comparator. + * (ms) [rt.cpan.org #84725] Fixed test suite to allow running tests + in parallel via HARNESS_OPTIONS=j10:c HARNESS_TIMER=1. + Reported by Brendan Byrd. + +1.40 (2012/11/30) + * (ms) Denis Ibaev added support for DBI appender attributes. + * (ms) Chris Weyl put in a workaround for a DBD::CSV bug that + tripped our test suite. + * (ms) Tim Bunce provided a patch using Carp::confess() instead of die() + on the "Root Logger not initialized" message which pops up + during global construction to make it easier to find the + offending code. + * (ms) Cygwin masks MSWin32-ishness by setting $^O to "cygwin" and not + to "Win32". Modified check to catch both. + * (ms) Fixed unescaped brace in regex that perl 5.17.4 was complaining + about. + +1.39 (2012/10/27) + * (ms) Markus Benning reported that logcroak/confess/die stringify + their arguments, which gets in the way when throwing data + structures as exceptions. Added flag $STRINGIFY_DIE_MESSAGE. + * (ms) [rt.cpan.org #80086] David Morel pointed out misleading + documentation in the Limiter composite appender. Fixed docs + and added C<appender_method_on_flush> parameter to support + appender flush calls by the limiter. + * (ms) [rt.cpan.org #79960] Fabrice Gabolde asked for %X{x} to be + interpolated as NULL for the database appender if its value is + undef. The DBI appender now inits PatternLayout with the + undef_column_name parameter set to undef (defaults to "[undef]"). + * (ms) Updated license/copyright/author sections in all files using + licensizer and .licensizer.yml. + * (ms) Skipped log file recreation test on Win32 as it won't remove + busy files anyway. + +1.38 (2012/09/23) + * (ms) Bob Kleemann reported that logdie() in wrapper classes + printed incorrect caller lines. Fixed by adding + caller_depth_offset() utility to Log4perl.pm. + * (ms) Meir Guttman reported a use case for logging messages + with dynamic levels on log4perl-devel@lists.sourceforge.net. + Added to manual page. + * (ms) Implemented suggestion by Neil Hooey to check for and report + undefined message elements before they're assembled in Appender.pm + and a warning is issued without a proper code location: + https://github.com/mschilli/log4perl/issues/15 + * (ms) [rt.cpan.org #78734] Added spell check on filter parameter names + +1.37 (2012/05/30) + * (ms) [rt.cpan.org #75655] Meir Guttman found the module to make + Log::Log4perl::Appender::ScreenColoredLevels work on Win32, + updated docs. + * (ms) [rt.cpan.org #76827] UTF-8 encoded configuration files are + now supported (see Log::Log4perl::Config). + * (ms) [rt.cpan.org #77501] Unescaped left brace in regex is deprecated + with perl 5.17. Times we live in. + +1.36 (2012/02/21) + * (ms) [rt.cpan.org #74833] Reini Urban fixed "defined @array" for + perl 5.16 + * (ms) [rt.cpan.org #74836] Cope with Carp's questionable decision to + add a trailing dot to its messages. + +1.35 (2012/01/03) + * (ms) [rt.cpan.org #73462] Changed logwarn/logcluck/logcarp/error_warn + to warn() unconditionally and send the message to log4perl which + will log it only if the log level conditions are met. + * (ms) [rt.cpan.org #73598] Gerda Shank reported test suite problems + with DBD::CSV-0.26. Bumped up to DBD::CSV-0.33 if installed. + +1.34 (2011/11/04) + * (ms) InternalDebug now replaces all instances of INTERNAL_DEBUG, + not just the first one. + * (ms) Added test case for get_logger() with a ref() on the actual + object instead of on a static category. Updated docs. + * (ms) %d{e} in PatternLayout now returns epoch seconds + * (ms) [RT 72056] Messages blocked by an appender threshold are no + longer passed on to the L4p::Appender::Buffer as undefined + entries. + +1.33 (2011/05/31) + * (ms) [RT 67132] Applied patch by Darin McBride to allow for + empty syswrite messages in the file appender. + * (ms) [RT 68105] Fixed init-hash handling of subroutine references, + reported by Frew Schmidt. + * (ms) Mike Schwern noticed confusing DESTROY calls to clean up loggers + and appenders (http://stackoverflow.com/questions/5914088 and + https://github.com/mschilli/log4perl/issues/7), so I put on my + hazmat suit and cleaned it up. Now perl's garbage collector takes + care of disposing of logger and appender carcasses. + * (ms) Added Log::Log4perl->remove_logger($logger) to remove a logger + from the system. + +1.32 (2011/02/26) + * (ms) Fixed %T caller_depth with wrapper_register(), reported + by David Christensen. + * (ms) [RT 63053] Fixed for qw() {} deprecated (Todd Rinaldo) + * (ms) [RT 62674] Fixed call to deprecated form of UNIVERSAL::can (Karen + Etheridge). + * (ms) [RT 62896] Log::Log4perl::Appender::ScreenColoredLevels now + inherits from Log::Log4perl::Appender::Screen and therefore + supports the utf8 flag. + * (ms) [RT 64318] Andrew Sayers provided a better error message for + "threshold needs to be uppercase". + * (ms) CharleyDixon fixed LOGWARN when :no_extra_logdie_message is + in use to no longer exit(). + +1.31 (2010/10/27) + * (ms) Fixed the number of skipped tests for Windows for previous fix + of [RT 60665]. + +1.30 (2010/08/30) + * (ms) [RT 60665] HUP handlers are stacked on top of each other now, + to make sure that multiple file appenders recreate multiple + files and not just one (patch provided by Karen Etheridge). + * (ms) [RT 60197] Fixed uninitialized value warnings with + the multiline appender and provided a test case (patch provided + by Karen Etheridge) + * (ms) [rt.cpan.org #59617] Fixed system-wide threshold without appender + thresholds. Bug reported by Dmitry Bigunyak. + * (ms) [rt.cpan.org #24884] Using require() instead of incomplete + logic in L4p::Util::module_available(). local __DIE__ + handler takes care of user-defined __DIE__ handlers + ignoring $^S (suggested by Eric Wilhelm and others). + * (ms) [rt.cpan.org #60386] Fixed init_and_watch() which + double-bumped the caller_level and led to uninitialized + values in the pattern layout. Thanks to Mitja Bartsch for + the report. + * (ms) Applied patch by Karsten Silkenbäumer to add an optional + $log_dispatch_level to create_custom_level(). Updated + documentation. + +1.29 (2010/06/16) + * (ms) Added documentation on how to use Log4perl's :easy macros + with Catalyst in Log::Log4perl::Catalyst. + * (ms) wrapper_register() now deals with caller_depth automatically. + Backwards compatibility with old wrapper classes using + caller_depth directly is provided. Documentation has been + updated. + * (ms) Felix Antonius Wilhelm Ostmann reported Resurrector.pm + crashes, fixed as suggested by setting the %INC value to + the module path. + * (ms) Another caller_depth fix in Log::Log4perl::Catalyst. + * (ms) Fixed logdie() caller_depth bug reported by Rob Retter. + * (ms) [RT 56145] Saving errstr in DBI appender to survive ping() + * (ms) Added INTERNAL_DEBUG env variable to test suite triggering + all _INTERNAL_DEBUG statements to be printed for better + error diagnosis on misbehaving systems. + +1.28 (2010/02/24) + * (ms) Fixed caller stack with Buffer composite appender + * (ms) Fixed 'local caller_depth' error in various places. First + localizing a variable and then increasing it is incorrect, + as this ignores previous settings. The correct way of + increasing the caller level is: 'local depth = depth + 1'. + * (ms) Added Log::Log4perl::Catalyst for use in Catalyst applications. + +1.27 (2010/02/07) + * (ms) ***WARNING: This might break backward compatibility + with some wrapper classes. + [RT 52913] Fixed category fetching in + wrapper classes (reported by Martin Evans). Wrapper classes + now need to call Log::Log4perl->wrapper_register to adapt + get_logger() category fetching. Detailed docs under + "Using Log::Log4perl with wrapper functions and classes" + * (ms) Made meta tag compatible with MakeMaker versions < 6.50 + (ms) [RT 52083] Fixed manifest glitch from 1.26 (reported by + Lars Thegler). + * (ms) Added note to FAQ on 'no init happened' warnings for API + initializations, as suggested by Malcolm Nooning. + * (ms) Applied patch by Christopher Mckay which sets + Log4perl::Logger::INITIALIZED only if it's fully initialized. + * (ms) Emmanuel Rodriguez suggested changing TestBuffer's reset() + method to leave the logger population alone. Added clear() + to accomodate the need for a single buffer reset. + * (ms) Xavier Caron added %p{1} to allow abbreviated priority + strings in the pattern layout. + * (ms) Redid composite appenders to address problems with incorrect + caller() data. L4p now supports a $cache parameter to be + passed to the log() function, which stores the completely + rendered message and can be passed to log_cached() later on. + +1.26 (2009/11/22) + * (ms) [RT 50495] Perl code in the config file is now evaluated/ + compiled after the configuration parser has done its work, + opening up Perl subroutines to all configuration parsers, not + just PropertyConfigurator. Configuration subs for cspecs, + filter, warp_message and appender triggers are sheltered. + The previous, flawed implementation surfaced while using + a 'trigger' category, reported by Olivier Bilodeau. + * (ms) [RT 50090] Added non-portable linebreaks to PatternLayout + (requested by Zdeněk Juran). + * (ms) [RT 50094] Docfix for PatternLayout in main manpage (spotted + by Peter Rabbitson). + * (ms) [RT 28679] Added exists() to "Threshold" keyword uppercase + check. + * (ms) Took out Class::Prototyped testcase after it got all weird + and introduced backward-incompatible changes. + +1.25 (2009/09/27) + * (ms) Appender::File is now closing (or sysclosing) the file + on file_close() instead of just undef'ing the handle. + * (ms) Added l4p-tmpl helper script to help whipping up a new + log4perl configuration file. + * (ms) Fixed uninitialized warning on XML configuration files, + reported by jbkilian on the sourceforge mailing list. + * (ms) Applied patch [RT 43426] by AFF <aff@cpan.org> to have + appender_thresholds_adjust return number of appenders changed. + * (ms) [RT 34400] New :nostrict target which allows redefining a + category within a Log4perl configuration file without error + or even a warning. + * (ms) [RT 34401] Applied patch by Jae Gangemi, who fixed + code references in @INC on Win32 systems. + * (ms) [RT 32259] Patternlayout now supports %R, which returns the + number of milliseconds elapsed from last logging event to + the current logging event (thanks to Emmanuel Rodriguez for + the patch). + * (ms) [RT 30899] Color configuration and attribute support + added to ScreenColoredLevels appender by Jason Kohles. + * (ms) [RT 28987] If UNIVERSAL is available, appender existence is + now verified by checking can() on the appender's new() + method (applied modified patch by Gabriel Berriz). + +1.24 (2009/07/08) + * (ms) Fixed bug with Log::Log4perl::Util::tmpfile_name which + surfaced on VMS, reported by Ben Humphreys. + * (ms) Fixed system-wide threshold to no longer lower appender + thresholds. Bug reported by Jean-Denis Muys. + * (ms) Added benchmark to determine impact of eval-free handlers + * (ms) Merged with eval_free branch. Now there are no more + eval("") statements left in the code, making it much easier + to debug. Performance on init() is about the same, performance + on init_and_watch() (noops and logged statements alike) is + 25% slower but still in the range of 400,000/sec on my + 1.80Ghz CPU. + +1.23 (2009/05/12) + * (ms) DBI-1.608 removed a DBD::File 'feature' that allowed leaving + out parameters in a bound execute(). This caused the test + suite to fail (http://groups.google.com/group/perl.cpan.testers/browse_thread/thread/af1f5c875165c387). Fixed the test cases to pass the correct + number of parameters every time. + * (ms) Better error message in the DBI appender on bad SQL, missing + bind parameters, or other execute() errors. + * (ms) Made DBI test suite more robust against preexisting conditions + * (ms) Added force_next_check() for init_and_watch(), cleaned up + Config::Watcher code. + * (ms) Fixed test suite to run on Strawberry Perl on Win32 (reported + by kmx on https://rt.cpan.org/Ticket/Display.html?id=45983) + * (ms) Added 'utf8' option to screen appender and easy mode, some of + it suggested in + http://rt.cpan.org/Public/Bug/Display.html?id=36673 by + Shantanu Bhadoria. + +1.22 (2009/05/02) + * (ms) is_xxx() returned true prior to L4p initialization. Fixed it + and adapted test suite. + * (ms) Added test cases on syswrite in recreate mode + * (ms) Applied patch by Jens Berthold <log4perl@jebecs.de> to + avoid semaphore cleanup in spawned children. + * (ms) Added %m{chomp} feature, 'message_chomp_before_newline' option, + and documentation on newlines and logging messages, all + suggested by Tim Bunce (see PatternLayout). + +1.21 (2009/03/16) + * (ms) Documentation typos fixed, reported by Breno G. de Oliveira + [rt.cpan.org #42428]. + * (ms) Fixed DBI appender error message, bug reported by DavidZ. + * (ms) Fixed [rt.cpan.org #43740] reported by Martin Koehler. Now using + proper POSIX return code EEXISTS instead of error message + depending on English locale. + +1.20 (2008/12/09) + * (ms) Using semctl to reset the value of the semaphore in the + Synchronized appender to prevent "Numerical result out of + range" problem caused by an unbalanced SEM_UNDO when + incrementing it. Reported by John Little. + * (ms) Added parameters in curly braces to cspecs in PatternLayout. + * (ms) As explained in http://rt.cpan.org/Ticket/Display.html?id=41505 + the latest LWP release (5.822) got rid of all of its internal + debugging functions, making infiltrate_lwp() and its test + case useless. Disabling it for LWP>=5.822. + +1.19 (2008/10/22) + * (ms) Applied patch by Peter Rabbitson, which fixes the caller() + level when calling get_logger() on a subclass of Log4perl. + * (ms) Added documentation on is_xxx() methods and clarified that + it doesn't necessarily mean that a message gets logged if + they're returning true (requested by Conway Allen via + [rt.cpan.org #39085]. + * (ms) Applied patch by Lee Johnson to appender_by_name() to allow + for undefined appender names without issuing a warning, + which was occurring with Catalyst::Log4perl. + * (ms) Added docs on numerical levels and level strings in + Log::Log4perl::Level. + * (ms) Applied patch by Anthony Foiani for support of literal + text in DateFormat format strings. + +1.18 (2008/08/23) + * (ms) Added explanation that categories and loggers are the same + thing (thanks to Rabbit). + * (ms) Fixed t/053Resurrect to work with 5.005_03 + * (ms) Added preinit_callback function for init_and_watch() + * (ms) Applied patch by Andy Grundman which speeds up is_LEVEL() + calls by skipping unnecessary string concatenations + (http://rt.cpan.org/Ticket/Display.html?id=38537). + * (ms) Applied patch by Jae Gangemi addding a no_warning option to the + socket appender + (http://rt.cpan.org/Ticket/Display.html?id=34399). + +1.17 (2008/07/19) + * (ms) Fixed test suite to run on Strawberry Perl on Win32. + * (ms) Added 'l4p' as a valid prefix in configuration files (equal + to 'log4j' and 'log4perl' now). + +1.16 (2008/05/15) + * (ms) Changed appender destruction during cleanup to show warning + messages thrown by destructors. Previously L4p ignored these + messages which caused failed DB flushes to go unnoticed with + the DB appender. + * (ms) Added explanation for Log4perl messages during global + destruction to FAQ. + * (ms) Corrected 'Trapper' listing in FAQ, thanks to Christian Reiber. + * (ms) Applied patch by Mitchell Perilstein for 5.005it and the + two-argument binmode() that 5.005 doesn't support. + (http://rt.cpan.org/Ticket/Display.html?id=34051) + * (ms) Applied patch by Emmanuel Rodriguez (POTYL) doing away with + hard-coded line numbers in 024WarnDieCarp.t to make it work + cpan2rpm for building RPM packages + (http://rt.cpan.org/Public/Bug/Display.html?id=35370) + * (ms) Fixed recreate_check_interval = 0 bug reported by + Bill Moseley. + * (ms) Added 'header_text' parameter to the file appender to + have it write a header every time it opens (or re-opens) + a new log file (suggested by Steven Lembark). + +1.15 (2008/02/10) + * (ms) appender_thresholds_adjust() with a parameter of 0 now + does nothing (requested by Oliver Koch). + * (kg) Added 'defer_connection' to Socket appender so it's more useful + under Apache. + * (ms) [rt.cpan.org #32738] fixed caller_depth for error_warn() + (reported by Felix Antonius Wilhelm Ostmann) + * (ms) [rt.cpan.org #32942] fixed get_logger() for subclassed Log4perl + (reported by Felix Antonius Wilhelm Ostmann) + +1.14 (2007/11/18) + * (ms) Fixed test suite bug which surfaced in Darwin because temporary + files contain '++' which freaked out the sloppy regex match. + * (ms) Better handling of empty config files (reported by Robert Raisch) + * (ms) Rewrote the Synchronized appender to use semaphores exclusivly + (got rid of IPC::Shareable). + * (ms) Added Log::Log4perl::Util::Semaphore for easy semop handling + * (ms) Fixed t/026FileApp.t to work on MSWin32. + +1.13 (2007/10/11) + * (ms) Another doc fix by Craig + * (ms) Applied Fedora 7 patches + * (ms) Added create_at_logtime option to file appender + * (ms) Added trace level color (yellow) in ScreenColoredLevels + appender as suggested by Arvind Jayaprakash in + https://sourceforge.net/tracker/index.php? + func=detail&aid=1791445&group_id=56939&atid=482388 + +1.12 (2007/06/23) + * (ms) Added Log::Log4perl::Resurrector to resurrect commented-out + Log4perl statements in all subsequently loaded modules (allows + for deploying L4p-enabled CPAN modules without requiring L4p). + * (ms) Added ALWAYS easy mode macro (level=OFF) + * (ms) Fixed logconfess() frame level bug reported by Ali Mesdaq. + Added test case. + +1.11 (2007/05/29) + * (ms) Added PatternLayout::Multiline code by Cory Bennett to + render multiline messages. + * (ms) Added log level TRACE (lets through even more messages + than DEBUG) (suggested by Craig). + * (ms) Added 'syswrite' flag to file appender to have it use + 'syswrite' instead of 'print', avoiding buffered or + interleaving messages originating from different processes + (thanks to Evan Miller). + +1.10 (2007/03/27) + * (kg) Nikita Dedik pointed out that Saturday is missing from + @Log::Log4perl::DateFormat::WEEK_DAYS + * (ms) Scott Cline noticed a potential problem with the DBI + appender reconnection logic in 'buffered' mode. Applied + a patch. + * (ms) Changed DBI reconnect logic to perform even if the DB + is pingable again. + * (ms) Applied code by Valerio Valdez Paolini with modifications + to PropertyConfigurator.pm to allow pulling values from + the property configurator by path. + +1.09 (2007/02/07) + * (ms) Added $^S check to FAQ, as suggested by J. David Blackstone. + * (ms) Applied Robert Jacobson's patch for the "DDD" formatter + in L4p::DateFormats, which now formats the day-of-year values + numerically and precedes them with zeroes if necessary. + * (ms) Added %M{x} PatternLayout notation as requested by + Ankur Gupta. + * (ms) Another Win32 test suite fix, no longer deleting an open + file but moving it aside (rt.cpan:23520). + +1.08 2006/11/18 + * (ms) Applied test suite patch by Lars Thegler for + ancient perl 5.005_03. + * (ms) Applied patch by Jeremy Bopp to fix test suite running + under Cygwin. + * (ms) Fixed documentation bug in L4p:Appender::File, + s/recreate_signal/recreate_check_signal. Thanks to + Todd Chapman and Robert Jacobson for reporting this. + * (ms) Fixed init(), which now deletes any config file watchers + left over from previous init_and_watch() calls. Reported + by Andreas Koenig who saw sporadic errors in the test suite, + thanks! + +1.07 2006/10/11 + * (ms) Removed checks for unlink() in t/017Watch.t since they + failed on win32. + * (ms) Fixed doc bug in Appender::File reported by Robert + Jacobson. + * (ms) Added FAQ on why to use Log4perl and not another + logging system on CPAN. + * (ms) Fixed %M, %L, etc. level in logcarp/cluck/croak/confess + (thanks to Ateeq Altaf) + * (ms) Autocorrecting rootlogger/rootLogger typo + * (ms) Better warning on missing loggers in config sanity check + +1.06 2006/07/18 + * (ms) Applied patch by Robert Jacobson to fix day-of-year in + DateFormat, which was off by one. + * (ms) Added FAQ on syslog + * (ms) umask values for the file appender are now also accepted + in octal form (0xxx). + * (ms) The file appender now accepts owner/group settings of + newly created log files. + * (ms) Fixed appender cleanup, a bug caused composite appenders + to be cleaned up during global destruction, which caused an + ugly segfault with the Synchronized appender on FreeBSD. + +1.05 2006/06/10 + * (ms) Added recreate signal handler to L4p::Appender::File for + newsyslog support. Two new FAQ entries on dealing with + newsyslog and log files being removed by external apps. + * (ms) L4p::Config::Watch no longer sets the global $SIGNAL_CAUGHT by + default but uses an instance variable instead to prevent + clobbering L4p's config and watch mechanism. + * (ms) die() on undefined configuration (rt 18103 by justice8@wanadoo.fr) + * (ms) Hugh Esco submitted a FAQ on where to put logfiles + * (ms) Applied patch provided by Chia-liang Kao to suppress an error + message and skip tests in the suite when DBI is missing. + +1.04 2006/02/26 + * (ms) Duplicate log4perl directives, which previously just overwrote + existing ones, are no longer permitted and cause the config + parser to throw an error. + * (ms) If a conversion pattern was specified twice in a config + file, the output was "ARRAY(0x804da00)" (bug reported by + Bill Mason). Now, gobbling up property configurator values + into an array is limited to appender properties and + excludes the conversion pattern. + * (ms) Multiple calls to import (usually happens if 'use L4p' gets + called twice within the same namespace) caused nasty warnings, + bug reported by Greg Olszewski. Fixed by ignoring subsequent + calls from the same package to import(). + * (ms) Changed rendering of logdie/warn/cluck/croak/... messages + to fix a bug reported by Martin J. Evans. + * (ms) Added a L4p::Appender::String appender to handle the + rendering internally. + * (ms) Documentation patch by Matisse Enzer on increased/ + decreased log levels. + * (ms) Fixed stack trace level of logcarp() + * (ms) Carl Franks reported that the test suite failed on WinXP SP2 + because of a hardcoded /tmp - fixed by File::Spec->tempdir(). + * (ms) Added reconnect_attempts and reconnect_sleep parameters to + DBI appender. + * (ms) Bugfix for rt.cpan.org #17886 (tmp files in test suite) + +1.03 (2006/01/30) + * (ms) Some perl-5.6.1 installations have a buggy Carp.pm. Skipping + 4 test cases for these. Reported by Andy Ford and Matisse Enzer. + * (ms) The DBI appender now reconnects on stale DB connections. + * (ms) Fixed Win32 test bug as reported in + http://rt.cpan.org/Ticket/Display.html?id=17436 by barbie. + Instead of deleting a file still in use by an appender (which + Windows doesn't like), the file gets now truncated. + +1.02 (2005/12/10) + * (ms) Adapted t/006Config-Java.t to cope with Win32 path separators + * (ms) Corrected typo in Chainsaw FAQ, reported by Bernd Dirksen. + * (ms) Brian Edwards noticed that (Screen, File) were missing a + base class declaration, causing $logger->add_appender() to + fail. Fixed with test case. + * (ms) Log::Log4perl::Appender::File now handles the case where the + logfile suddenly disappears. + * (ms) Fixed section indentation in main man page + * (ms) Converted Ceki's last name to UTF-8 (a historic step!) + +1.01 (09/29/2005) + * (ms) Added 'utf8' and 'binmode' flags to Log::Log4perl::Appender::File + per suggestion by Jonathan Warden. + * (ms) Made test cases 003Layout.t and 033UsrCspec.t resilient against + broken ActiveState 5.8.4 and 5.8.7. + * (ms) Skipped failing test cases for 5.005, looks like the caller() level + in carp() is wrong, but not worth fixing. + * (ms) Fixed the bug with the caller level of the first + log message sent after init_and_watch() detected a change. Added + test case to 027Watch2.t. + * (ms) Added FAQ on UTF-8. + * (ms) Applied patch by David Britton, improving performance during + the init() call. + * (ms) Fixed bug https://rt.cpan.org/Ticket/Display.html?id=14776 + to prevent it from modifying $_. Thanks to Steffen Winkler. + +1.00 (08/13/2005) + * (ms) Added tag qw(:no_extra_logdie_message) to suppress duplicate + die() messages in scripts using simple configurations and LOGDIE(). + Added logexit() as an alternative way. + * (ms) Fixed bug with logcarp/croak/cluck, which were using the + wrong Carp level. + * (kg) Fixing bug in Appender::Limit regarding $_ scope + * (ms) corrected typo in Synchronized.pm found by Rob Redmon. + * (ms) Fixed bug with Appender::File reported by Michael Smith. Checking + now if print() succeeds, catching errors with full disks and + ulimit'ed environments. + * (ms) Added LOGCARP(), LOGCLUCK(), LOGCONFESS(), LOGCROAK() macros + in :easy mode (suggested by Jud Dagnall). + * (ms) $INITIALIZED now gets reset during logger cleanup. + +0.52 (05/08/2005) + * (ms) Jonathan Manning <jmanning@alisa-jon.net> provided a patch + for DateFormat.pm to fix 3-letter month abbreviations and a + shortcut to simulate Apache's log format. + * (kg) Ola Finsbraaten provided a patch to provide a better error + message when a logger is defined twice in a config. + +0.51 (01/08/2005) + * (ms) Jon Bjornstad noticed that the file appender wasn't including + $! in the die() exception thrown if open_file() fails. Added it. + * (ms) Added umask option to file appender + * (ms) Fix to L4p::Util::module::available() for Win32 + compliance by Roger Yager <roger.yager@eyestreet.com> + * (ms) Added check to L4p::Util::module_available() returning true + if the pm file is available in %INC, indicating that it has + already been loaded. This fixes a problem when running L4p + in a PAR binary. + * (ms) Added remove_appender() and eradicate_appender() method to + Logger.pm, test cases and documentation on the main Log4perl + page. + * (ms) Added a generic buffered composite appender, L4p::Appender::Buffer, + buffering messages until a trigger condition is met. + +0.50 (12/08/2004) + * (ms) Added ':resurrect' source filter, which uncomments all lines + starting with "###l4p". Can be used for hidden L4p statements, + which are then activated by calling + 'use Log::Log4perl qw(:resurrect)'. + * (ms) Fixed Win32 test suite bug: File::Spec->catfile() returns '/' + as a path separator on both Unix and Win32, while Log4perl's + layouts (derived from caller() info) use '\' on Win32 and '/' + on Unix. Changed tests to only verify file name, not path. + * (ms) Added 'appender_by_name()' to retrieve an appender defined + in the configuration file by name later. + * (ms) Added FAQ on "stubbing out" L4p macros in environments + that don't have L4p installed. + * (ms) Added convenience function appender_thresholds_adjust() to adjust + thresholds of chosen (or all) appenders + * (ms) Got rid of Test::Simple dependency + * (ms) Moved autoflush setting in L4p::Appender::File from log() + to file_open(), running only once, not with every message. + * (ms) Applied doc fixes suggested by Jon Bjornstad. + * (ms) Added ScreenANSIColor appender to colorize messages based on + their priority. See Log::Log4perl::Appender::ScreenANSIColor. + +0.49 (11/07/2004) + * (ms) init_and_watch() no longer die()s on reloading syntactically + wrong configuration files but issues a warning and then + reloads the last working config. + * (ms) init() now also accepts an open file handle (passed in as a + glob) to a configuration file or a ref to an IO::File object. + * (ms) Jos I. Boumans <kane@xs4all.net> and + Chris Winters <chris@cwinters.com> reported an error thrown + by L4p in their app SPOPS: During global construction. Looks + like the Logger object's internal hash is cleared and then + the is_<level> method gets called, resulting in a runtime + exception. Added proposed remedy checking if the called + method is defined by ref. + * (ms) Added check to init_and_watch if obtaining the mod + timestamp failed. + +0.48 (08/20/2004) + * (ms) fixed bug reported by Chip Salzenberg <chip@pobox.com>: logdie() + and logwarn() are now compliant with the warn() and die() + standard which suppresses the "at file line x" message if + the message ends with a "\n". + * (ms) New interface for custom config parsers. + Log::Log4perl::Config::BaseConfigurator now provides a base class + for new config parsers. Init can now be called like + Log::Log4perl->init($parser) with a parser object, which is + derived from Log::Log4perl::Config::BaseConfigurator and + provides a parse() method (no arguments). The file (or whatever) + to be parsed can be set by calling $parser->text(\@lines) or + $parser->file($name) before calling L4p->init($parser). + The Property, DOM and LDAP configurators have been + adapted, check their implementation for details. + * (ms) Added integrity check for Log4perl configurations: Log4perl + now issues a warning if a configuration doesn't define any + appenders. Should anyone not like this, it can be turned + off by setting $L4p::Config::CONFIG_INTEGRITY_CHECK = 0 + before calling init(). + * (ms) Fixed bug reported by Johannes Kilian <jok@vitronic.com> + with __DIE__ handler and "PatternLayout" shortcut. Replaced + 'eval { require ... }' by L4p::Util::module_available in + L4p::Config.pm. + * (ms) Did away with $IS_LOADED internal variable. + * (ms) Fixed bug with L4p::INITIALIZED vs. L4P::Logger::INITIALIZED, + added t/020Easy2.t. + * (ms) Added adm/cvskwexp script to check if we're running into CVS + trouble because of <dollar>Log keyword expansion. + +0.47 (07/11/2004) + * (ms) Added suggestion by Hutton Davidson <Davidson.Hutton@ftid.com> + to make the socket appender more forgiving. New option + "silent_recovery" will silently ignore errors and recover + if possible on initiallly dead socket connections. + * (ms) Fixed bug with initialized() -- checking once caused + subsequent calls to return true. + * (ms) run t/045Composite.t only if Storable is installed -- earlier + perl versions (like 5.6.1) don't have it by default. + * (ms) fixed test case in t/020Easy.t for buggy perl 5.6.1 + * (ms) added Log::Log4perl::infiltrate_lwp() to make LWP::UserAgent + play in the L4p framework upon request. + * (ms) perl 5.00503 mysteriously core dumps in t/017Watch.t, seems like + this was introduced in 0.46. Disabled these tests for now + if we're on 5.00503 to avoid installation hickups. Longer term, + need to investigate. + +0.46 (06/13/2004) + * (ms) removed superfluous eval() in Log4perl.pm, reported anonymously + on the CPAN bugtracker. + * (ms) Added a cleanup() function to Logger.pm which is used by an + END {} block in Logger.pm to tear down all Loggers/Appenders + before global destruction kicks in. In addition, Kevin found + that the eval "" is the cause of an Appender memleak. Moved + assignment variable out of the eval to plug the leak. + Added $Log::Log4perl::CHATTY_DESTROY_METHODS, which shows + what L4p objects are destroyed and when. + * (ms) Kevin's idea is in now, on localizing $? in the L4p global END {} + block. It prevents logdie() et. al from exiting with unwanted + exit codes when global cleanup / global destruction modifies $?, + as seen by Tim with the Email appender. + * (ms) Dave Viner <dviner@yahoo-inc.com> added isLevelEnabled() methods + as aliases to is_level(). + +0.45 (05/23/2004) + * (ms) fix for t/045Composite.t on perl 5.6.1 by Jeff Macdonald + <jeff.macdonald@e-dialog.com> (specify number of test cases, + getting rid of no_plan). + * (ms) Dennis Gregorovic <dgregor@redhat.com> provided a patch to + protect applications who are tinkering with $/. It is set + to "\n" now locally when L4p is reading the conf file. Added + a test case to t/004Config.t. + * (ms) Fixed a documentation error with initialized(), pointed + out by Victor Felix <vfelix@tigr.org>. + +0.44 (04/25/2004) + * (ms) added filename() method to L4P::Appender::File as suggested + by Lee Carmichael <lecar_red@yahoo.com> + * (ms) added RRDs appender Log::Log4perl::Appender::RRDs and testcases + * (ms) fixed Log::Log4perl::Appender to check if a an appender package + has already been loaded and skip 'require' in this case. + Packages injected via Class::Prototyped caused an error with this. + * (ms) Extended the FAQ's "How can I write my own appender?" on + how to dynamically create new appenders via Class::Prototyped. + +0.43 (03/22/2004) + * (ms) Applied patch by Markus Peter <warp@spin.de> for 'pipe' + mode in Log::Log4perl::Appender::File + * (ms) Added composite appender Log::Log4perl::Appender::Limit to + limit message delivery to adjustable time windows. + * (ms) Fixed last 033UsrCspec.t test case to run on Win32 as well + (path fixed). + * (ms) Lars Thegler <lars@thegler.dk> provided a patch to keep + compatibility with 5.005_03. + * (ms) Added a patch to avoid warnings on undefined MDC values referenced + via %X in PatternLayout. Now, the string "[undef]" is used. Bug + was reported by Ritu Kohli <Ritu.Kohli@ubs.com> + +0.42 (02/14/2004) + * (kg) added filters to XML DOMConfig and DTD + * (ms) Fixed caller level to cspecs by adding one + * (ms) Added init_once() and documentation + * (ms) Worked around the perl bug that triggers __DIE__ handlers + even if die() occurs within an eval(). So if you did + BEGIN { $SIG{__DIE__} = sub { print "ouch!"; die }; } + use Log::Log4perl; + and Time::HiRes wasn't available, the + eval { require Time::HiRes } + in PatternLayout.pm triggered the __DIE__ handler. Now there's + a function module_available() in L4p::Util to check if a + module is installed. + * (ms) Fixed %M cspec in PatternLayout in case a logging + method is called within one (or more) eval {} block(s). + caller(n+m) will be called repeatedly if necessary + to get the next real subroutine. Anonymous subroutines will + still be called __ANON__, but this can be overridden by + defining + local *__ANON__ = "subroutine_name"; + in them explicitely (thanks, Perlmonks :). + +0.41 (12/12/2003) + * (ms) Applied documentation update for Synchronized appender, suggested + by David Viner E<lt>dviner@yahoo-inc.comE<gt> + * (ms) Added option to Log::Log4perl::Layout::PatternLayout to + enable people to provide their own timer functions. + +0.40 (11/11/2003) + * (ms) perl 5.005_03 fix for l4p::Appender::Synchronized + * (ms) Fixed a bug in 0.39 (thanks to James King for finding) which + caused composite appenders like Synchronized to just use + SimpleLayout. With the fix, composite appenders are now relaying + messages unmodified to their delegates, which can then apply + any layout they desire. + * (ms) Added file_open(), file_close() and file_switch() to + l4p::Appender::File + +0.39 (10/23/2003) + * (kg) fixed bug in interaction between Logger::Level and Level::is_valid + so that now you can do $logger->level('INFO') instead of just $INFO. + * (ms) Added logic for 'composite appenders'. Appenders can now be + configured to relay messages to other appenders. Added + Log::Log4perl::Appender::Synchronized, an appender guaranteeing + atomic logging of messages via semaphores. + * (ms) Added basic substitution to PropertyConfigurator. Now you can + define variables (like in "name=value") and subsequent patterns + of "${name}" will be replaced by "value" in the configuration file. + * (kg) Followed Mike's lead and added variable substitution to the + DOMConfigurator. + * (ms) Added Log::Log4perl::Appender::Socket as a simple Socket + appender featuring connection recovery. + +0.38 (09/29/2003) + * (kg) fixed bug where custom_levels beneath DEBUG didn't work + * (ms) fixed 5.00305 incompatibility reported by + Brett Rann <brettrann@mail.com> (constants with leading _). + * (ms) Log::Log4perl->easy_init() now calls ->reset() first to make sure + it's not duplicating the existing logging environment. Thanks + to William McKee <william@knowmad.com> for bringing this up. + * (ms) fixed bug with error_die() - printed the wrong function/line/file. + Reported by Brett Rann <brettrann@mail.com>. + * (ms) added %T to PatternLayout as a stack traced as suggested by + Brett Rann <brettrann@mail.com>. + +0.37 (09/14/2003) + * (kg) adjusting tests for XML::Parser 2.32 having broken + XML::DOM 1.42 and lower + * (ms) Added signal handling to init_and_watch + * (ms) renamed l4p-internal DEBUG constant to avoid confusion with + DEBUG() and $DEBUG as suggested by Jim Cromie <jcromie@divsol.com>. + * (ms) Applied patch by Mac Yang <mac@proofpoint.com> for + Log::Log4perl::DateFormat to calculate the timezone for the 'Z' + conversion specifier. + +0.36 (07/22/2003) + * (ms) Matthew Keene <mkeene@netspace.net.au> suggested to have + an accessor for all appenders currently defined -- added + appenders() method + * (ms) Test case 041SafeEval.t didn't share $0 explicitely and + created some warnings, fixed that with (jf)'s help. + * (ms) Added performance improvements suggested by + Kyle R. Burton <mortis@voicenet.com>. is_debug/is_info/etc. + are now precompiled, similar to the debug/info/etc. methods. + * (ms) Added a fix to have is_debug()/is_info()/etc. pay + attention to on-the-fly config file changes via init_and_watch(). + * (ms) Fixed bug that reloaded the config under init_and_watch() + every time the check period expired, regardless if the config + file itself had changed. Added test case. + +0.35 06/21/2003 + * (kg) got rid of warnings during make test in 014ConfErrs.t + added user-defined hooks to JavaMap + * Jim Cromie <jcromie@divsol.com> provided a patch to get + rid of deprecated our-if syntax in Level.pm + * (ms) removed test case for RollingFileAppender because of recent + instability. Added dependency for Log::Dispatch::RollingFile 1.10 + in Log/Log4perl/JavaMap/RollingFileAppender.pm. + +0.34 06/08/2003 + * (ms) James FitzGibbon <james.fitzgibbon@target.com> noticed a major + bug in Log::Log4perl::Appender::File and provided a patch. Problem + was that 0.33 was reusing the same file handle for every opened file, + causing all messages to end up in the same file. + +0.33 05/30/2003 + * (kg) CPAN rt#2636, coordinating XML::DOM version required across modules + and unit tests + * (ms) Removed Log::Dispatch dependency, added standard + Log::Log4perl::Appender appenders File and Screen. + Log::Dispatch is still supported for backwards compatibility + and special purpose appenders implemented within this hierarchy. + +0.32 05/17/2003 + * (ms) Added fix to Makefile.PL to compensate for MakeMaker bug + in perl < 5.8.0, causing man pages below Log::Log4perl::Config + not to be installed. Thanks to Mathieu Arnold <mat@mat.cc> + for bringing this up. + * (ms) 0.31 had a Win32 test suite glitch, replaced getpwuid() + (not implemented) by stat() for Safe test. + +0.31 05/08/2003 + * (kg) fixed bug Appender::DBI where it was consuming the message + array before other appenders could get to it + * (ms) changed config_and_watch to ignore clock differences between + system time and file system time (helpful with skewed NFS + systems). Added Log::Log4perl::Config::Watch. + * James FitzGibbon <james.fitzgibbon@target.com>: Added support for + optionally restricting eval'd code to Safe compartments. + * (ms) allow/deny code in configuration files should now be controlled + via the accessor Log::Log4perl::Config->allow_code(0/1). + $Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE is still supported + for backwards compatibility. + +0.30 03/14/2003 + * (ms) Added Log4perl custom filter logic and standard filter set + * (kg) Added url support to init(), finally documenting it + * (kg) Finished implementation of DOMConfigurator allowing xml configs. + * (ms) Corrected DateFormat inconsistencies as reported by + Roger Perttu <roger.perttu@easit.se> + +0.29 01/30/2003 + * (kg) Removing debugging from 0.28, big woops + * (kg) Fixing 036JSyslog.t, Syslog implementations are too often broken + to base any results on. + * (kg) Fixing XML-DOM tests, Data::Dumper doesn't return data exactly the + same way. + +0.28 (01/28/2003) + * (ms) '#' in the conf file are now interpreted as comment starters only + if they're at the start of a line with optional whitespace. + The previous setting (comments starting anywhere) had problems + with code containing '#''s, like in layout.cref = sub { $#_ = 1 } + * (ms) warp_message accepts code refs or function names + * (kg) Split config bits into PropertyConfigurator and implemented + DOMConfigurator for XML configs. + * (kg) Adding appender.warp_message parameter as a help to DBI + appender + * (kg) Added NoopLayout to help DBI appender + * (ms) Added message output filters: + log({filter => \&filter, value => $value}) + * (kg) t/024WarnDieCarp was assuming / as directory separator, failed + on Win32 + * (kg) implemented JavaMaps for NTEventLogAppender, SyslogAppender + * (kg) found and addressed circular ref problem in Logger->reset + * (kg) moved TestBuffer under Appender/ directory along with DBI + * (kg) fixed docs, Pattern layout, %f not supported, s/b %F + * (kg) added Log::Log4perl::Appender::DBI to implement JDBCAppender + * (ms) Every value in the config file can now be a perl function, + dynamically replaced by its return value at configuration + parse time + * (ms) NDC now prints entire stack, not just + top element (as mandated by Log4j) + * (ms) Allow trailing spaces after a line-breaking '\' in the + config file to be fault-tolerant on cut-and-pasted code + +0.27 12/06/2002 + * (ms) Updated FAQ with "Recipes of the Week" + * (ms) Added Log::Log4perl::NDC (Nested Diagnostic Contexts) and + Log::Log4perl::MDC (Mapped Diagnostic Contexts) + * (ms) LOGDIE and LOGWARN added to stealth loggers + * (ms) Logging methods ($lo->debug(), $lo->info() ...) now return + a value, indicating the number of appenders that the message + was propagated to. If the message was suppressed due to level + constraints, undef is returned. Updated manpage (new section + "return values"). + * (ms) Fixed bug reported by Francisco Olarte Sanz. + <folarte@peoplecall.com>: ISO date format and documentation mixed + up MM with mm in the simple date format + * (kg) User-defined conversion specifiers for PatternLayout in + configuration file and as C API + * (kg) implementing map to log4j.RollingFileAppender + * (kg) trying out oneMessagePerAppender parameter + * (kg) changed unit tests to use File::Spec + +0.26 11/11/2002 + * (kg) enabled %l (was missing from PatternLayout::define) + * (kg) got rid of "Use of uninitialized value in join or string" message + when some of $logger->debug(@array) when some of @array are undef + * (ms) Stealth loggers and documentation + * (kg) Better error message for case reported by Hai Wu + * (ms) Added Log/Log4perl/FAQ.pm, which the homepage links to + * (ms) Took dependency on Test::More and Test::Simple out of the PPD file + because of a problem with Activestate 5.6.1 reported + by James Hahn <jrh3@att.com> + * (ms) Added Log::Dispatch equivalent levels to the Log4perl loggers, + which are passed on the Log::Dispatch appenders now according + to the priority of the message instead of the default "DEBUG" + setting + * (ms) Added %P process ID to PatternLayout as suggested by + Paul Harrington <Paul-Harrington@deshaw.com>. Also added + %H as hostname + * (kg) Added %min.max formatter to PatternLayout + * (ms) Updated docs for Log::Log4perl::DateFormat + +0.25 10/06/2002 + * (ms) backwards-compatibility with perl 5.00503 + * (ms) added system-wide threshold, fixed java-app thresholds + * (kg) Nested configuration structures for appenders like L::D::Jabber + * (ms) ::Log4perl::Appender::threshold() accepts strings or integer + levels (as submitted by Aaron Straup Cope <asc@vineyard.net>) + * (ms) Fixed logdie/logwarn caller(x) offset bug reported by + Brian Duffy <Brian.Duffy@DFA.STATE.NY.US> + * (ms) dies now on PatternLayout without ConversionPattern (helps detecting + typos in conf files) + +0.24 09/26/2002 + * (kg) Fix for init_and_watch and test cases + * (ms) Added documentation for Log::Log4perl::Config + * (ms) Added log4perl.additivity.loggerName conf file syntax + * (ms) Assume Log::Log4perl::Layout prefix of 'relative' + layout class names in conf file (say 'SimpleLayout' + instead of 'Log::Log4perl::Layout::SimpleLayout'). + * (ms) accidently appending a ';' at the end of an appender + class in a conf file now spits out a reasonable error message + * (ms) added a by_name() method to TestBuffer to retrieve an + instance of the TestBuffer population by name instead of + relying on the order of creation via POPULATION[x] + (for testing only). + * (kg) Win32 compatibility fixes + +0.23 09/14/2002 + * Both Log4perl/log4perl is now accepted in conf file + * Added documentation to Log::Log4perl::Appender + * Made Time::HiRes optional. If it's missing, PatternLayout will + just use full seconds as %r. + * SimpleDateFormat "%d{HH:SS}", including predefined formats (DATE etc.) + * Added another cut-and-paste example to the docs (EXAMPLE) + * Added new logdie/logwarn/error_warn/error_die/logcarp/ + logcluck/logcroak/logconfess functions written by + Erik Selberg <erik@selberg.com> + * Added PatternLayout documentation + * Changed suppression of duplicate newline in log message algorithm + * Custom levels and inc_level/dec_level/more_logging/less_logging + added by Erik Selberg <erik@selberg.com> + * Append to logfile by default if Log::Dispatch::File is used + (previously clobbered by default) + * Kevin's init_and_watch fix + +0.22 8/17/2002 + * Threshold settings of appenders: + $appender->threshold($ERROR); + log4j.appender.A.Threshold = ERROR + * Chris R. Donnelly <cdonnelly@digitalmotorworks.com> + submitted two patches: + - extended init() to take obj references (added, also added a test + case and documentation) + - fixed %F and %L if Log4perl is used by a wrapper class (accepted, + but changed variable name to Log::Log4perl::caller_depth as + a tribute to Log::Dispatch::Config, added test case 022Wrap + and documentation + +0.21 8/08/2002 + * Synopsis shows code samples in Log4perl.pm/README + * Slight Log4j incompatibility but useful: %F{n} lets you + limit the number of entries the source file path is logged + * Erik W. Selberg (erik@selberg.com) suggested having PatternLayout.pm + suppress another \n if the messages already contains a \n and the + format requires a %n. Done. + * Erik W. Selberg (erik@selberg.com) suggested loggers should take + any number of messages and concatenate them. Done. + * Fixed double-init problem and added a test case. Now the entire + configuration is cleared before the second init(). However, this + surfaced a problem with init_and_watch: If a program obtains + references to one or more loggers, rewriting the configuration + file during program execution and re-initing makes these reference + point to loggers which hold obsolete configurations. Fixed that by + code in debug(), info(), etc. which *replaces* (shudder) the + logger reference the program hands in to them with a new one of + the same category. This happens every time if 'init_and_watch' has + been enabled. However, this introduces a small runtime penalty. + This is different from the original log4j, which does some + half-assed re-initialization, because Java isn't expressive enough + to allow for it. Making this thread-safe might be tough, though. + * Added DEBUG statements to Logger.pm and Config.pm to trace execution + (debugging won't work because of "eval"s). Both files define a + constant named DEBUG towards the top of the file, which will + have perl optimize away the debug statements in case it's set to 0. + * A warning is issued now (once) if init() hasn't been called or + no appenders have been defined. + * Added ':levels' target to Log::Log4perl to import $DEBUG, $ERROR, + etc. levels (just like 'use Log::Log4perl::Level' works). + * Added ':easy' target to allow for simple setup + * Code references can be passed in as log messages to avoid parameter + passing penalty + +0.20 7/23/2002 + * Strip trailing spaces in config file + * Accept line continuations in properties file + * Refactored Logger.pm for speed, defined the logging behavior when + the logger is created, not when a message is logged + * Fixing test suites so that SimpleFormat newline is accounted for + * Fixed a bug with root inheritance where the category name wasn't + coming through + * added init_and_watch + +0.19 07/16/2002 + * Added Log::Log4perl::Appender::TestBuffer back in the distribution, otherwise + regression test suite would fail. + +0.18 07/16/2002 + * Failed attempt to fix the Log::Dispatch::Buffer problem. + +0.17 07/11/2002 + * Updated documentation according to Dave Rolsky's suggestions + * Lots of other documentation fixes + * Fixed bug in renderer, %M was displayed as the logger function + bumped up the level by 1 + * Fixed %% bug + +0.16 07/10/2002 + * Updated documentation for CPAN release + * Applied Kevin's patch to limit it to one Log::Dispatcher + +0.15 07/10/2002 + * There were name conflicts in Log::Dispatch, because we used *one* + Log::Dispatch object for the *all* loggers in the Log::Log4perl + universe (it still worked because we were using log_to() for + Log::Dispatch to send messages to specific appenders only). Now + every logger has its own Log::Dispatch object. Logger.pm doesn't + call Kevin's anti-dupe logic anymore -- is this ok? Maybe there's + some leftovers which need to be cleaned up. + * Kevin fixed t/014ConfErrs.t after last night's Appender.pm change + +0.14 07/09/2002 + * (!) Added new class Log::Log4perl::Appender as a wrapper around + Log::Dispatch::*. Layouts are no longer attached to the loggers, + but to the appenders instead. $app->layout($layout) sets the + layout. $logger->add_appender($app) is the new syntax to add + an appender to a logger. The $logger->layout method is gone + for that reason. + * Added documentation on categories + * Added documentation on Log::Log4perl::Appender, + Log::Log4perl::Layout::SimpleLayout, + Log::Log4perl::Layout::PatternLayout. + +0.13 07/09/2002 + * in the config files, 'debug' is not a level, 'DEBUG' is + * expanded the layouts so that we can add subclassess, added + SimpleLayout, note that api usage changes + -$logger->layout('buf',"The message is here: %m"); + +$logger->layout(new + Log::Log4perl::Layout::PatternLayout('buf',"The message is + here: %m")); + * did benchmarks, see doc/benchmark*, t/013Bench.t + * further tweaked errors for bad configuration, added a test for those + +0.12 07/08/2002 + * Log::Log4perl::Logger->get_logger now accessible via + Log::Log4perl->get_logger() + * Log::Log4perl::Config->init now accessible via + Log::Log4perl->init() + * Adapted test cases to new shortcuts + * Constrained some files to 80 chars width + * Added test case t/009Deuce.t for two appenders in one category + via the config file + * Changed default layout in case there's none defined (SimpleLayout) + * Implemented dictatory date format for %d: yyyy/MM/dd hh:mm:ss + +0.11 07/07/2002 + * added documentation to Log/Log4perl.pm + * added is_debug/is_error/is_info etc. functions to Logger.pm, + test cases to t/002Logger.t + +0.10 07/05/2002 + * %p should return level name of the calling function, so + $logger->warn('bad thing!!') should print 'WARN - bad thing' + even if the category is set to debug, so took level_str out of + Logger.pm (kg) + +0.09 07/03/2002 + * %p should return level name, not number, adding level_str to Logger.pm (kg) + * Level.pm - discriminating: priorities are 1-4, levels are + 'info','debug',etc (kg) + +0.08 07/03/2002 + * Non-root loggers are working now off the config file + +0.07 07/02/2002 + * Updated documentation + * removed "diagnostics" + +0.06 07/01/2002 + * Bug discovered by Kevin Goess <cpan@goess.org>, revealed + in 004-Config.t: Wrong layout used if Appender is inherited. + Fixed. + * Changed Log::Log4perl::Appender::TestBuffer to keep track of the + object population -- so we can easily reference them + in the Log::Log4perl test cases. Got rid of get_buffer(). + * Added a reset() method to Log::Log4perl and Log::Log4perl::Logger + for easier testing. It resets all persistent loggers to + the inital state. + * Added documentation + +0.05 06/30/2002 + * Fixed bug with mapped priorities between java/Log::Dispatch + * Java/Perl integration with conf file + +0.04 06/30/2002 + * Layout tests + * %r to layout + * Added lib4j configuration file stuff and tests + +0.03 06/30/2002 + * Layout + * Curly braces in Layout first ops + +0.02 06/30/2002 + * Created Logger and test cases + +0.01 06/22/2002 + * Where it all began + +TODO List: +################################################## + * Layout.pm: '%t' + * Wild idea: Could we possibly utilize the compiler + frontend to eliminate log statements that are not going to be + triggered? This would be a HUGE performance increase! + * get_logger() thread safety (two try to create it at the same time) + * Thread safety with re-reading the conf file (watch) + * log4j.logger.blah = INHERITED, app @@ -0,0 +1,14 @@ +=head1 COPYRIGHT AND LICENSE + +Copyright 2002-2012 by +Mike Schilli <m@perlmeister.com> and Kevin Goess <cpan@goess.org>. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +THE SOFTWARE IS PROVIDED "AS IS" AND WITHOUT WARRANTIES OF ANY KIND, +INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OF ACCURACY OR +COMPLETENESS OF ANY INFORMATION CONTAINED IN THE SOFTWARE OR IMPLIED +WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..c644f5f --- /dev/null +++ b/MANIFEST @@ -0,0 +1,163 @@ +.licensizer.yml +Changes +eg/5005it.pl +eg/benchmarks/Makefile +eg/benchmarks/simple +eg/color +eg/dupe-warning.conf +eg/jabber.conf +eg/l4p-tmpl +eg/L4pResurrectable.pm +eg/log4j-file-append-java.conf +eg/log4j-file-append-perl.conf +eg/log4j-manual-1.conf +eg/log4j-manual-2.conf +eg/log4j-manual-3.conf +eg/log4j-utf8.conf +eg/newsyslog-test +eg/override_appender +eg/prototype +eg/syslog.pl +eg/yamlparser +ldap/log4perl-2.ldif +ldap/log4perl-unittest.ldif +ldap/testload.ldif +lib/Log/Log4perl.pm +lib/Log/Log4perl/Appender.pm +lib/Log/Log4perl/Appender/Buffer.pm +lib/Log/Log4perl/Appender/DBI.pm +lib/Log/Log4perl/Appender/File.pm +lib/Log/Log4perl/Appender/Limit.pm +lib/Log/Log4perl/Appender/RRDs.pm +lib/Log/Log4perl/Appender/Screen.pm +lib/Log/Log4perl/Appender/ScreenColoredLevels.pm +lib/Log/Log4perl/Appender/Socket.pm +lib/Log/Log4perl/Appender/String.pm +lib/Log/Log4perl/Appender/Synchronized.pm +lib/Log/Log4perl/Appender/TestArrayBuffer.pm +lib/Log/Log4perl/Appender/TestBuffer.pm +lib/Log/Log4perl/Appender/TestFileCreeper.pm +lib/Log/Log4perl/Catalyst.pm +lib/Log/Log4perl/Config.pm +lib/Log/Log4perl/Config/BaseConfigurator.pm +lib/Log/Log4perl/Config/DOMConfigurator.pm +lib/Log/Log4perl/Config/PropertyConfigurator.pm +lib/Log/Log4perl/Config/Watch.pm +lib/Log/Log4perl/DateFormat.pm +lib/Log/Log4perl/FAQ.pm +lib/Log/Log4perl/Filter.pm +lib/Log/Log4perl/Filter/Boolean.pm +lib/Log/Log4perl/Filter/LevelMatch.pm +lib/Log/Log4perl/Filter/LevelRange.pm +lib/Log/Log4perl/Filter/MDC.pm +lib/Log/Log4perl/Filter/StringMatch.pm +lib/Log/Log4perl/InternalDebug.pm +lib/Log/Log4perl/JavaMap.pm +lib/Log/Log4perl/JavaMap/ConsoleAppender.pm +lib/Log/Log4perl/JavaMap/FileAppender.pm +lib/Log/Log4perl/JavaMap/JDBCAppender.pm +lib/Log/Log4perl/JavaMap/NTEventLogAppender.pm +lib/Log/Log4perl/JavaMap/RollingFileAppender.pm +lib/Log/Log4perl/JavaMap/SyslogAppender.pm +lib/Log/Log4perl/JavaMap/TestBuffer.pm +lib/Log/Log4perl/Layout.pm +lib/Log/Log4perl/Layout/NoopLayout.pm +lib/Log/Log4perl/Layout/PatternLayout.pm +lib/Log/Log4perl/Layout/PatternLayout/Multiline.pm +lib/Log/Log4perl/Layout/SimpleLayout.pm +lib/Log/Log4perl/Level.pm +lib/Log/Log4perl/Logger.pm +lib/Log/Log4perl/MDC.pm +lib/Log/Log4perl/NDC.pm +lib/Log/Log4perl/Resurrector.pm +lib/Log/Log4perl/Util.pm +lib/Log/Log4perl/Util/Semaphore.pm +lib/Log/Log4perl/Util/TimeTracker.pm +LICENSE +Makefile.PL +MANIFEST +MANIFEST.SKIP +README +t/001Level.t +t/002Logger.t +t/003Layout-Rr.t +t/003Layout.t +t/004Config.t +t/005Config-Perl.t +t/006Config-Java.t +t/007LogPrio.t +t/008ConfCat.t +t/009Deuce.t +t/010JConsole.t +t/011JFile.t +t/012Deeper.t +t/013Bench.t +t/014ConfErrs.t +t/015fltmsg.t +t/016Export.t +t/017Watch.t +t/018Init.t +t/019Warn.t +t/020Easy.t +t/020Easy2.t +t/021AppThres.t +t/022Wrap.t +t/023Date.t +t/024WarnDieCarp.t +t/025CustLevels.t +t/026FileApp.t +t/027Watch2.t +t/027Watch3.t +t/027Watch4.t +t/028Additivity.t +t/029SysWide.t +t/030LDLevel.t +t/031NDC.t +t/032JRollFile.t +t/033UsrCspec.t +t/034DBI.t +t/035JDBCAppender.t +t/036JSyslog.t +t/037JWin32Event.t +t/038XML-DOM1.t +t/039XML-DOM2.t +t/040Filter.t +t/041SafeEval.t +t/042SyncApp.t +t/043VarSubst.t +t/044XML-Filter.t +t/045Composite.t +t/046RRDs.t +t/048lwp.t +t/049Unhide.t +t/050Buffer.t +t/051Extra.t +t/052Utf8.t +t/053Resurrect.t +t/054Subclass.t +t/055AppDestroy.t +t/056SyncApp2.t +t/057MsgChomp.t +t/058Warnings.t +t/059Wrapper.t +t/060Initialized.t +t/061Multiline.t +t/062InitHash.t +t/063LoggerRemove.t +t/064RealClass.t +t/065Undef.t +t/066SQLite.t +t/067Exception.t +t/068MultilineIndented.t +t/069MoreMultiline.t +t/070UTCDate.t +t/compare.pl +t/deeper1.expected +t/deeper6.expected +t/deeper7.expected +t/lib/Log4perlInternalTest.pm +t/testdisp.pl +xml/log4j-1.2.dtd +xml/log4perl.dtd +META.yml Module YAML meta-data (added by MakeMaker) +META.json Module JSON meta-data (added by MakeMaker) diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP new file mode 100644 index 0000000..33c3890 --- /dev/null +++ b/MANIFEST.SKIP @@ -0,0 +1,24 @@ +.gz$ +.travis.yml +blib +^Makefile$ +^Makefile.old$ +^modules +^Log4perl.pm +CVS +^t/bak +^t/tmp/ +.cvsignore +docs +lib/Log/Dispatch +MANIFEST.bak +MANIFEST.old +adm +ldap/log4perl.schema +ldap/migrate.pl +lib/Log/Log4perl/Config/LDAPConfigurator.pm +t/047-ldap.t +.git +test.log +MYMETA.json +MYMETA.yml diff --git a/META.json b/META.json new file mode 100644 index 0000000..0980ea1 --- /dev/null +++ b/META.json @@ -0,0 +1,49 @@ +{ + "abstract" : "Log4j implementation for Perl", + "author" : [ + "Mike Schilli <m@perlmeister.com>" + ], + "dynamic_config" : 1, + "generated_by" : "ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.142690", + "license" : [ + "unknown" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : "2" + }, + "name" : "Log-Log4perl", + "no_index" : { + "directory" : [ + "t", + "inc" + ] + }, + "prereqs" : { + "build" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "configure" : { + "requires" : { + "ExtUtils::MakeMaker" : "0" + } + }, + "runtime" : { + "requires" : { + "File::Path" : "2.0606", + "File::Spec" : "0.82", + "Test::More" : "0.45" + } + } + }, + "release_status" : "stable", + "resources" : { + "repository" : { + "url" : "http://github.com/mschilli/log4perl" + }, + "x_MailingList" : "mailto:log4perl-devel@lists.sourceforge.net" + }, + "version" : "1.46" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..3315ab9 --- /dev/null +++ b/META.yml @@ -0,0 +1,27 @@ +--- +abstract: 'Log4j implementation for Perl' +author: + - 'Mike Schilli <m@perlmeister.com>' +build_requires: + ExtUtils::MakeMaker: '0' +configure_requires: + ExtUtils::MakeMaker: '0' +dynamic_config: 1 +generated_by: 'ExtUtils::MakeMaker version 6.66, CPAN::Meta::Converter version 2.142690' +license: unknown +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Log-Log4perl +no_index: + directory: + - t + - inc +requires: + File::Path: '2.0606' + File::Spec: '0.82' + Test::More: '0.45' +resources: + MailingList: mailto:log4perl-devel@lists.sourceforge.net + repository: http://github.com/mschilli/log4perl +version: '1.46' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..04e8793 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,93 @@ +use ExtUtils::MakeMaker; +# See lib/ExtUtils/MakeMaker.pm for details of how to influence +# the contents of the Makefile that is written. + + # That's the minimum. +use 5.00503; + + # If we're not 5.6.0, there's some corrections we need to make: Use + # 'use vars' instead of 'our' variables, get rid of 'use warnings' + # and other stuff. The eg/5005it.pl script takes care of it. +if($] < 5.006) { + require "eg/5005it.pl"; + + print <<EOT; +######################################################## +# Hm, you're still using perl 5.005. Although I don't # +# condone that, I'll let it slip this time: # +# Changing distribution to be backwards compatible ... # +EOT + mk5005("t", "lib"); + print <<EOT; +# Done. But do me a favour and upgrade soon. # +######################################################## +EOT +} + +# Check for Time::HiRes; +eval { require Time::HiRes; }; +if($@) { + print "Warning: Time::HiRes not installed, but that's ok, " . + "%r will use full seconds\n"; +} + +my $meta_merge = { + META_MERGE => { + resources => { + repository => 'http://github.com/mschilli/log4perl', + MailingList => 'mailto:log4perl-devel@lists.sourceforge.net', + }, + } +}; + +WriteMakefile( + 'NAME' => 'Log::Log4perl', + 'VERSION_FROM' => 'lib/Log/Log4perl.pm', # finds $VERSION + 'PREREQ_PM' => { Test::More => 0.45, + File::Spec => 0.82, + File::Path => 2.06_06, + }, # e.g., Module::Name => 1.1 + ($] >= 5.005 ? ## Add these new keywords supported since 5.005 + (ABSTRACT_FROM => 'lib/Log/Log4perl.pm', # retrieve abstract from module + AUTHOR => 'Mike Schilli <m@perlmeister.com>') : ()), + 'LIBS' => [''], # e.g., '-lm' + 'DEFINE' => '', # e.g., '-DHAVE_SOMETHING' + # Insert -I. if you add *.h files later: + 'INC' => '', # e.g., '-I/usr/include/other' + # Un-comment this if you add C files to link with later: + # 'OBJECT' => '$(O_FILES)', # link all the C files too + 'clean' => {FILES => "*.tar.gz *.ppd pod2htm*"}, + EXE_FILES => ["eg/l4p-tmpl"], + $ExtUtils::MakeMaker::VERSION >= 6.50 ? (%$meta_merge) : (), + get_man3pods(), +); + +########################################## +sub get_man3pods { +########################################## + # Only done for versions < 5.8.0 + return () if $] >= 5.008; + + print <<EOT; +################################################## +# Detected buggy MakeMaker version, creating man # +# pages manually # +################################################## +EOT + require File::Find; + + my @pms = (); + + File::Find::find(sub { + push @pms, $File::Find::name if /\.pm$/ + }, "lib"); + + return('MAN3PODS', { + map { my @comps = split /\//, $_; + shift @comps; + my $csep = join '::', @comps; + $csep =~ s/\.pm$//; + ($_, "\$(INST_MAN3DIR)/$csep.\$(MAN3EXT)"); + } @pms + }); +} @@ -0,0 +1,2183 @@ +###################################################################### + Log::Log4perl 1.46 +###################################################################### + +NAME + Log::Log4perl - Log4j implementation for Perl + +SYNOPSIS + # Easy mode if you like it simple ... + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init($ERROR); + + DEBUG "This doesn't go anywhere"; + ERROR "This gets logged"; + + # ... or standard mode for more features: + + Log::Log4perl::init('/etc/log4perl.conf'); + + --or-- + + # Check config every 10 secs + Log::Log4perl::init_and_watch('/etc/log4perl.conf',10); + + --then-- + + $logger = Log::Log4perl->get_logger('house.bedrm.desk.topdrwr'); + + $logger->debug('this is a debug message'); + $logger->info('this is an info message'); + $logger->warn('etc'); + $logger->error('..'); + $logger->fatal('..'); + + #####/etc/log4perl.conf############################### + log4perl.logger.house = WARN, FileAppndr1 + log4perl.logger.house.bedroom.desk = DEBUG, FileAppndr1 + + log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File + log4perl.appender.FileAppndr1.filename = desk.log + log4perl.appender.FileAppndr1.layout = \ + Log::Log4perl::Layout::SimpleLayout + ###################################################### + +ABSTRACT + Log::Log4perl provides a powerful logging API for your application + +DESCRIPTION + Log::Log4perl lets you remote-control and fine-tune the logging + behaviour of your system from the outside. It implements the widely + popular (Java-based) Log4j logging package in pure Perl. + + For a detailed tutorial on Log::Log4perl usage, please read + + <http://www.perl.com/pub/a/2002/09/11/log4perl.html> + + Logging beats a debugger if you want to know what's going on in your + code during runtime. However, traditional logging packages are too + static and generate a flood of log messages in your log files that won't + help you. + + "Log::Log4perl" is different. It allows you to control the number of + logging messages generated at three different levels: + + * At a central location in your system (either in a configuration file + or in the startup code) you specify *which components* (classes, + functions) of your system should generate logs. + + * You specify how detailed the logging of these components should be + by specifying logging *levels*. + + * You also specify which so-called *appenders* you want to feed your + log messages to ("Print it to the screen and also append it to + /tmp/my.log") and which format ("Write the date first, then the file + name and line number, and then the log message") they should be in. + + This is a very powerful and flexible mechanism. You can turn on and off + your logs at any time, specify the level of detail and make that + dependent on the subsystem that's currently executed. + + Let me give you an example: You might find out that your system has a + problem in the "MySystem::Helpers::ScanDir" component. Turning on + detailed debugging logs all over the system would generate a flood of + useless log messages and bog your system down beyond recognition. With + "Log::Log4perl", however, you can tell the system: "Continue to log only + severe errors to the log file. Open a second log file, turn on full + debug logs in the "MySystem::Helpers::ScanDir" component and dump all + messages originating from there into the new log file". And all this is + possible by just changing the parameters in a configuration file, which + your system can re-read even while it's running! + +How to use it + The "Log::Log4perl" package can be initialized in two ways: Either via + Perl commands or via a "log4j"-style configuration file. + + Initialize via a configuration file + This is the easiest way to prepare your system for using + "Log::Log4perl". Use a configuration file like this: + + ############################################################ + # A simple root logger with a Log::Log4perl::Appender::File + # file appender in Perl. + ############################################################ + log4perl.rootLogger=ERROR, LOGFILE + + log4perl.appender.LOGFILE=Log::Log4perl::Appender::File + log4perl.appender.LOGFILE.filename=/var/log/myerrs.log + log4perl.appender.LOGFILE.mode=append + + log4perl.appender.LOGFILE.layout=PatternLayout + log4perl.appender.LOGFILE.layout.ConversionPattern=[%r] %F %L %c - %m%n + + These lines define your standard logger that's appending severe errors + to "/var/log/myerrs.log", using the format + + [millisecs] source-filename line-number class - message newline + + Assuming that this configuration file is saved as "log.conf", you need + to read it in the startup section of your code, using the following + commands: + + use Log::Log4perl; + Log::Log4perl->init("log.conf"); + + After that's done *somewhere* in the code, you can retrieve logger + objects *anywhere* in the code. Note that there's no need to carry any + logger references around with your functions and methods. You can get a + logger anytime via a singleton mechanism: + + package My::MegaPackage; + use Log::Log4perl; + + sub some_method { + my($param) = @_; + + my $log = Log::Log4perl->get_logger("My::MegaPackage"); + + $log->debug("Debug message"); + $log->info("Info message"); + $log->error("Error message"); + + ... + } + + With the configuration file above, "Log::Log4perl" will write "Error + message" to the specified log file, but won't do anything for the + "debug()" and "info()" calls, because the log level has been set to + "ERROR" for all components in the first line of configuration file shown + above. + + Why "Log::Log4perl->get_logger" and not "Log::Log4perl->new"? We don't + want to create a new object every time. Usually in OO-Programming, you + create an object once and use the reference to it to call its methods. + However, this requires that you pass around the object to all functions + and the last thing we want is pollute each and every function/method + we're using with a handle to the "Logger": + + sub function { # Brrrr!! + my($logger, $some, $other, $parameters) = @_; + } + + Instead, if a function/method wants a reference to the logger, it just + calls the Logger's static "get_logger($category)" method to obtain a + reference to the *one and only* possible logger object of a certain + category. That's called a *singleton* if you're a Gamma fan. + + How does the logger know which messages it is supposed to log and which + ones to suppress? "Log::Log4perl" works with inheritance: The config + file above didn't specify anything about "My::MegaPackage". And yet, + we've defined a logger of the category "My::MegaPackage". In this case, + "Log::Log4perl" will walk up the namespace hierarchy ("My" and then + we're at the root) to figure out if a log level is defined somewhere. In + the case above, the log level at the root (root *always* defines a log + level, but not necessarily an appender) defines that the log level is + supposed to be "ERROR" -- meaning that *DEBUG* and *INFO* messages are + suppressed. Note that this 'inheritance' is unrelated to Perl's class + inheritance, it is merely related to the logger namespace. By the way, + if you're ever in doubt about what a logger's category is, use + "$logger->category()" to retrieve it. + + Log Levels + There are six predefined log levels: "FATAL", "ERROR", "WARN", "INFO", + "DEBUG", and "TRACE" (in descending priority). Your configured logging + level has to at least match the priority of the logging message. + + If your configured logging level is "WARN", then messages logged with + "info()", "debug()", and "trace()" will be suppressed. "fatal()", + "error()" and "warn()" will make their way through, because their + priority is higher or equal than the configured setting. + + Instead of calling the methods + + $logger->trace("..."); # Log a trace message + $logger->debug("..."); # Log a debug message + $logger->info("..."); # Log a info message + $logger->warn("..."); # Log a warn message + $logger->error("..."); # Log a error message + $logger->fatal("..."); # Log a fatal message + + you could also call the "log()" method with the appropriate level using + the constants defined in "Log::Log4perl::Level": + + use Log::Log4perl::Level; + + $logger->log($TRACE, "..."); + $logger->log($DEBUG, "..."); + $logger->log($INFO, "..."); + $logger->log($WARN, "..."); + $logger->log($ERROR, "..."); + $logger->log($FATAL, "..."); + + This form is rarely used, but it comes in handy if you want to log at + different levels depending on an exit code of a function: + + $logger->log( $exit_level{ $rc }, "..."); + + As for needing more logging levels than these predefined ones: It's + usually best to steer your logging behaviour via the category mechanism + instead. + + If you need to find out if the currently configured logging level would + allow a logger's logging statement to go through, use the logger's + "is_*level*()" methods: + + $logger->is_trace() # True if trace messages would go through + $logger->is_debug() # True if debug messages would go through + $logger->is_info() # True if info messages would go through + $logger->is_warn() # True if warn messages would go through + $logger->is_error() # True if error messages would go through + $logger->is_fatal() # True if fatal messages would go through + + Example: "$logger->is_warn()" returns true if the logger's current + level, as derived from either the logger's category (or, in absence of + that, one of the logger's parent's level setting) is $WARN, $ERROR or + $FATAL. + + Also available are a series of more Java-esque functions which return + the same values. These are of the format "is*Level*Enabled()", so + "$logger->isDebugEnabled()" is synonymous to "$logger->is_debug()". + + These level checking functions will come in handy later, when we want to + block unnecessary expensive parameter construction in case the logging + level is too low to log the statement anyway, like in: + + if($logger->is_error()) { + $logger->error("Erroneous array: @super_long_array"); + } + + If we had just written + + $logger->error("Erroneous array: @super_long_array"); + + then Perl would have interpolated @super_long_array into the string via + an expensive operation only to figure out shortly after that the string + can be ignored entirely because the configured logging level is lower + than $ERROR. + + The to-be-logged message passed to all of the functions described above + can consist of an arbitrary number of arguments, which the logging + functions just chain together to a single string. Therefore + + $logger->debug("Hello ", "World", "!"); # and + $logger->debug("Hello World!"); + + are identical. + + Note that even if one of the methods above returns true, it doesn't + necessarily mean that the message will actually get logged. What + is_debug() checks is that the logger used is configured to let a message + of the given priority (DEBUG) through. But after this check, Log4perl + will eventually apply custom filters and forward the message to one or + more appenders. None of this gets checked by is_xxx(), for the simple + reason that it's impossible to know what a custom filter does with a + message without having the actual message or what an appender does to a + message without actually having it log it. + + Log and die or warn + Often, when you croak / carp / warn / die, you want to log those + messages. Rather than doing the following: + + $logger->fatal($err) && die($err); + + you can use the following: + + $logger->logdie($err); + + And if instead of using + + warn($message); + $logger->warn($message); + + to both issue a warning via Perl's warn() mechanism and make sure you + have the same message in the log file as well, use: + + $logger->logwarn($message); + + Since there is an ERROR level between WARN and FATAL, there are two + additional helper functions in case you'd like to use ERROR for either + warn() or die(): + + $logger->error_warn(); + $logger->error_die(); + + Finally, there's the Carp functions that, in addition to logging, also + pass the stringified message to their companions in the Carp package: + + $logger->logcarp(); # warn w/ 1-level stack trace + $logger->logcluck(); # warn w/ full stack trace + $logger->logcroak(); # die w/ 1-level stack trace + $logger->logconfess(); # die w/ full stack trace + + Appenders + If you don't define any appenders, nothing will happen. Appenders will + be triggered whenever the configured logging level requires a message to + be logged and not suppressed. + + "Log::Log4perl" doesn't define any appenders by default, not even the + root logger has one. + + "Log::Log4perl" already comes with a standard set of appenders: + + Log::Log4perl::Appender::Screen + Log::Log4perl::Appender::ScreenColoredLevels + Log::Log4perl::Appender::File + Log::Log4perl::Appender::Socket + Log::Log4perl::Appender::DBI + Log::Log4perl::Appender::Synchronized + Log::Log4perl::Appender::RRDs + + to log to the screen, to files and to databases. + + On CPAN, you can find additional appenders like + + Log::Log4perl::Layout::XMLLayout + + by Guido Carls <gcarls@cpan.org>. It allows for hooking up Log::Log4perl + with the graphical Log Analyzer Chainsaw (see "Can I use Log::Log4perl + with log4j's Chainsaw?" in Log::Log4perl::FAQ). + + Additional Appenders via Log::Dispatch + "Log::Log4perl" also supports *Dave Rolskys* excellent "Log::Dispatch" + framework which implements a wide variety of different appenders. + + Here's the list of appender modules currently available via + "Log::Dispatch": + + Log::Dispatch::ApacheLog + Log::Dispatch::DBI (by Tatsuhiko Miyagawa) + Log::Dispatch::Email, + Log::Dispatch::Email::MailSend, + Log::Dispatch::Email::MailSendmail, + Log::Dispatch::Email::MIMELite + Log::Dispatch::File + Log::Dispatch::FileRotate (by Mark Pfeiffer) + Log::Dispatch::Handle + Log::Dispatch::Screen + Log::Dispatch::Syslog + Log::Dispatch::Tk (by Dominique Dumont) + + Please note that in order to use any of these additional appenders, you + have to fetch Log::Dispatch from CPAN and install it. Also the + particular appender you're using might require installing the particular + module. + + For additional information on appenders, please check the + Log::Log4perl::Appender manual page. + + Appender Example + Now let's assume that we want to log "info()" or higher prioritized + messages in the "Foo::Bar" category to both STDOUT and to a log file, + say "test.log". In the initialization section of your system, just + define two appenders using the readily available + "Log::Log4perl::Appender::File" and "Log::Log4perl::Appender::Screen" + modules: + + use Log::Log4perl; + + # Configuration in a string ... + my $conf = q( + log4perl.category.Foo.Bar = INFO, Logfile, Screen + + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Logfile.layout.ConversionPattern = [%r] %F %L %m%n + + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.stderr = 0 + log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout + ); + + # ... passed as a reference to init() + Log::Log4perl::init( \$conf ); + + Once the initialization shown above has happened once, typically in the + startup code of your system, just use the defined logger anywhere in + your system: + + ########################## + # ... in some function ... + ########################## + my $log = Log::Log4perl::get_logger("Foo::Bar"); + + # Logs both to STDOUT and to the file test.log + $log->info("Important Info!"); + + The "layout" settings specified in the configuration section define the + format in which the message is going to be logged by the specified + appender. The format shown for the file appender is logging not only the + message but also the number of milliseconds since the program has + started (%r), the name of the file the call to the logger has happened + and the line number there (%F and %L), the message itself (%m) and a + OS-specific newline character (%n): + + [187] ./myscript.pl 27 Important Info! + + The screen appender above, on the other hand, uses a "SimpleLayout", + which logs the debug level, a hyphen (-) and the log message: + + INFO - Important Info! + + For more detailed info on layout formats, see "Log Layouts". + + In the configuration sample above, we chose to define a *category* + logger ("Foo::Bar"). This will cause only messages originating from this + specific category logger to be logged in the defined format and + locations. + + Logging newlines + There's some controversy between different logging systems as to when + and where newlines are supposed to be added to logged messages. + + The Log4perl way is that a logging statement *should not* contain a + newline: + + $logger->info("Some message"); + $logger->info("Another message"); + + If this is supposed to end up in a log file like + + Some message + Another message + + then an appropriate appender layout like "%m%n" will take care of adding + a newline at the end of each message to make sure every message is + printed on its own line. + + Other logging systems, Log::Dispatch in particular, recommend adding the + newline to the log statement. This doesn't work well, however, if you, + say, replace your file appender by a database appender, and all of a + sudden those newlines scattered around the code don't make sense + anymore. + + Assigning matching layouts to different appenders and leaving newlines + out of the code solves this problem. If you inherited code that has + logging statements with newlines and want to make it work with Log4perl, + read the Log::Log4perl::Layout::PatternLayout documentation on how to + accomplish that. + + Configuration files + As shown above, you can define "Log::Log4perl" loggers both from within + your Perl code or from configuration files. The latter have the + unbeatable advantage that you can modify your system's logging behaviour + without interfering with the code at all. So even if your code is being + run by somebody who's totally oblivious to Perl, they still can adapt + the module's logging behaviour to their needs. + + "Log::Log4perl" has been designed to understand "Log4j" configuration + files -- as used by the original Java implementation. Instead of + reiterating the format description in [2], let me just list three + examples (also derived from [2]), which should also illustrate how it + works: + + log4j.rootLogger=DEBUG, A1 + log4j.appender.A1=org.apache.log4j.ConsoleAppender + log4j.appender.A1.layout=org.apache.log4j.PatternLayout + log4j.appender.A1.layout.ConversionPattern=%-4r %-5p %c %x - %m%n + + This enables messages of priority "DEBUG" or higher in the root + hierarchy and has the system write them to the console. + "ConsoleAppender" is a Java appender, but "Log::Log4perl" jumps through + a significant number of hoops internally to map these to their + corresponding Perl classes, "Log::Log4perl::Appender::Screen" in this + case. + + Second example: + + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::Screen + log4perl.appender.A1.layout=PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%d %-5p %c - %m%n + log4perl.logger.com.foo=WARN + + This defines two loggers: The root logger and the "com.foo" logger. The + root logger is easily triggered by debug-messages, but the "com.foo" + logger makes sure that messages issued within the "Com::Foo" component + and below are only forwarded to the appender if they're of priority + *warning* or higher. + + Note that the "com.foo" logger doesn't define an appender. Therefore, it + will just propagate the message up the hierarchy until the root logger + picks it up and forwards it to the one and only appender of the root + category, using the format defined for it. + + Third example: + + log4j.rootLogger=DEBUG, stdout, R + log4j.appender.stdout=org.apache.log4j.ConsoleAppender + log4j.appender.stdout.layout=org.apache.log4j.PatternLayout + log4j.appender.stdout.layout.ConversionPattern=%5p (%F:%L) - %m%n + log4j.appender.R=org.apache.log4j.RollingFileAppender + log4j.appender.R.File=example.log + log4j.appender.R.layout=org.apache.log4j.PatternLayout + log4j.appender.R.layout.ConversionPattern=%p %c - %m%n + + The root logger defines two appenders here: "stdout", which uses + "org.apache.log4j.ConsoleAppender" (ultimately mapped by "Log::Log4perl" + to Log::Log4perl::Appender::Screen) to write to the screen. And "R", a + "org.apache.log4j.RollingFileAppender" (mapped by "Log::Log4perl" to + Log::Dispatch::FileRotate with the "File" attribute specifying the log + file. + + See Log::Log4perl::Config for more examples and syntax explanations. + + Log Layouts + If the logging engine passes a message to an appender, because it thinks + it should be logged, the appender doesn't just write it out haphazardly. + There's ways to tell the appender how to format the message and add all + sorts of interesting data to it: The date and time when the event + happened, the file, the line number, the debug level of the logger and + others. + + There's currently two layouts defined in "Log::Log4perl": + "Log::Log4perl::Layout::SimpleLayout" and + "Log::Log4perl::Layout::PatternLayout": + + "Log::Log4perl::SimpleLayout" + formats a message in a simple way and just prepends it by the debug + level and a hyphen: ""$level - $message", for example "FATAL - Can't + open password file". + + "Log::Log4perl::Layout::PatternLayout" + on the other hand is very powerful and allows for a very flexible + format in "printf"-style. The format string can contain a number of + placeholders which will be replaced by the logging engine when it's + time to log the message: + + %c Category of the logging event. + %C Fully qualified package (or class) name of the caller + %d Current date in yyyy/MM/dd hh:mm:ss format + %F File where the logging event occurred + %H Hostname (if Sys::Hostname is available) + %l Fully qualified name of the calling method followed by the + callers source the file name and line number between + parentheses. + %L Line number within the file where the log statement was issued + %m The message to be logged + %m{chomp} The message to be logged, stripped off a trailing newline + %M Method or function where the logging request was issued + %n Newline (OS-independent) + %p Priority of the logging event + %P pid of the current process + %r Number of milliseconds elapsed from program start to logging + event + %R Number of milliseconds elapsed from last logging event to + current logging event + %T A stack trace of functions called + %x The topmost NDC (see below) + %X{key} The entry 'key' of the MDC (see below) + %% A literal percent (%) sign + + NDC and MDC are explained in "Nested Diagnostic Context (NDC)" and + "Mapped Diagnostic Context (MDC)". + + Also, %d can be fine-tuned to display only certain characteristics + of a date, according to the SimpleDateFormat in the Java World + (<http://java.sun.com/j2se/1.3/docs/api/java/text/SimpleDateFormat.h + tml>) + + In this way, %d{HH:mm} displays only hours and minutes of the + current date, while %d{yy, EEEE} displays a two-digit year, followed + by a spelled-out (like "Wednesday"). + + Similar options are available for shrinking the displayed category + or limit file/path components, %F{1} only displays the source file + *name* without any path components while %F logs the full path. + %c{2} only logs the last two components of the current category, + "Foo::Bar::Baz" becomes "Bar::Baz" and saves space. + + If those placeholders aren't enough, then you can define your own + right in the config file like this: + + log4perl.PatternLayout.cspec.U = sub { return "UID $<" } + + See Log::Log4perl::Layout::PatternLayout for further details on + customized specifiers. + + Please note that the subroutines you're defining in this way are + going to be run in the "main" namespace, so be sure to fully qualify + functions and variables if they're located in different packages. + + SECURITY NOTE: this feature means arbitrary perl code can be + embedded in the config file. In the rare case where the people who + have access to your config file are different from the people who + write your code and shouldn't have execute rights, you might want to + call + + Log::Log4perl::Config->allow_code(0); + + before you call init(). Alternatively you can supply a restricted + set of Perl opcodes that can be embedded in the config file as + described in "Restricting what Opcodes can be in a Perl Hook". + + All placeholders are quantifiable, just like in *printf*. Following this + tradition, "%-20c" will reserve 20 chars for the category and + left-justify it. + + For more details on logging and how to use the flexible and the simple + format, check out the original "log4j" website under + + SimpleLayout + <http://logging.apache.org/log4j/1.2/apidocs/org/apache/log4j/SimpleLayo + ut.html> and PatternLayout + <http://logging.apache.org/log4j/1.2/apidocs/org/apache/log4j/PatternLay + out.html> + + Penalties + Logging comes with a price tag. "Log::Log4perl" has been optimized to + allow for maximum performance, both with logging enabled and disabled. + + But you need to be aware that there's a small hit every time your code + encounters a log statement -- no matter if logging is enabled or not. + "Log::Log4perl" has been designed to keep this so low that it will be + unnoticeable to most applications. + + Here's a couple of tricks which help "Log::Log4perl" to avoid + unnecessary delays: + + You can save serious time if you're logging something like + + # Expensive in non-debug mode! + for (@super_long_array) { + $logger->debug("Element: $_"); + } + + and @super_long_array is fairly big, so looping through it is pretty + expensive. Only you, the programmer, knows that going through that "for" + loop can be skipped entirely if the current logging level for the actual + component is higher than "debug". In this case, use this instead: + + # Cheap in non-debug mode! + if($logger->is_debug()) { + for (@super_long_array) { + $logger->debug("Element: $_"); + } + } + + If you're afraid that generating the parameters to the logging function + is fairly expensive, use closures: + + # Passed as subroutine ref + use Data::Dumper; + $logger->debug(sub { Dumper($data) } ); + + This won't unravel $data via Dumper() unless it's actually needed + because it's logged. + + Also, Log::Log4perl lets you specify arguments to logger functions in + *message output filter syntax*: + + $logger->debug("Structure: ", + { filter => \&Dumper, + value => $someref }); + + In this way, shortly before Log::Log4perl sending the message out to any + appenders, it will be searching all arguments for hash references and + treat them in a special way: + + It will invoke the function given as a reference with the "filter" key + ("Data::Dumper::Dumper()") and pass it the value that came with the key + named "value" as an argument. The anonymous hash in the call above will + be replaced by the return value of the filter function. + +Categories + Categories are also called "Loggers" in Log4perl, both refer to the same + thing and these terms are used interchangeably. "Log::Log4perl" uses + *categories* to determine if a log statement in a component should be + executed or suppressed at the current logging level. Most of the time, + these categories are just the classes the log statements are located in: + + package Candy::Twix; + + sub new { + my $logger = Log::Log4perl->get_logger("Candy::Twix"); + $logger->debug("Creating a new Twix bar"); + bless {}, shift; + } + + # ... + + package Candy::Snickers; + + sub new { + my $logger = Log::Log4perl->get_logger("Candy.Snickers"); + $logger->debug("Creating a new Snickers bar"); + bless {}, shift; + } + + # ... + + package main; + Log::Log4perl->init("mylogdefs.conf"); + + # => "LOG> Creating a new Snickers bar" + my $first = Candy::Snickers->new(); + # => "LOG> Creating a new Twix bar" + my $second = Candy::Twix->new(); + + Note that you can separate your category hierarchy levels using either + dots like in Java (.) or double-colons (::) like in Perl. Both notations + are equivalent and are handled the same way internally. + + However, categories are just there to make use of inheritance: if you + invoke a logger in a sub-category, it will bubble up the hierarchy and + call the appropriate appenders. Internally, categories are not related + to the class hierarchy of the program at all -- they're purely virtual. + You can use arbitrary categories -- for example in the following + program, which isn't oo-style, but procedural: + + sub print_portfolio { + + my $log = Log::Log4perl->get_logger("user.portfolio"); + $log->debug("Quotes requested: @_"); + + for(@_) { + print "$_: ", get_quote($_), "\n"; + } + } + + sub get_quote { + + my $log = Log::Log4perl->get_logger("internet.quotesystem"); + $log->debug("Fetching quote: $_[0]"); + + return yahoo_quote($_[0]); + } + + The logger in first function, "print_portfolio", is assigned the + (virtual) "user.portfolio" category. Depending on the "Log4perl" + configuration, this will either call a "user.portfolio" appender, a + "user" appender, or an appender assigned to root -- without + "user.portfolio" having any relevance to the class system used in the + program. The logger in the second function adheres to the + "internet.quotesystem" category -- again, maybe because it's bundled + with other Internet functions, but not because there would be a class of + this name somewhere. + + However, be careful, don't go overboard: if you're developing a system + in object-oriented style, using the class hierarchy is usually your best + choice. Think about the people taking over your code one day: The class + hierarchy is probably what they know right up front, so it's easy for + them to tune the logging to their needs. + + Turn off a component + "Log4perl" doesn't only allow you to selectively switch *on* a category + of log messages, you can also use the mechanism to selectively *disable* + logging in certain components whereas logging is kept turned on in + higher-level categories. This mechanism comes in handy if you find that + while bumping up the logging level of a high-level (i. e. close to root) + category, that one component logs more than it should, + + Here's how it works: + + ############################################################ + # Turn off logging in a lower-level category while keeping + # it active in higher-level categories. + ############################################################ + log4perl.rootLogger=DEBUG, LOGFILE + log4perl.logger.deep.down.the.hierarchy = ERROR, LOGFILE + + # ... Define appenders ... + + This way, log messages issued from within "Deep::Down::The::Hierarchy" + and below will be logged only if they're "ERROR" or worse, while in all + other system components even "DEBUG" messages will be logged. + + Return Values + All logging methods return values indicating if their message actually + reached one or more appenders. If the message has been suppressed + because of level constraints, "undef" is returned. + + For example, + + my $ret = $logger->info("Message"); + + will return "undef" if the system debug level for the current category + is not "INFO" or more permissive. If Log::Log4perl forwarded the message + to one or more appenders, the number of appenders is returned. + + If appenders decide to veto on the message with an appender threshold, + the log method's return value will have them excluded. This means that + if you've got one appender holding an appender threshold and you're + logging a message which passes the system's log level hurdle but not the + appender threshold, 0 will be returned by the log function. + + The bottom line is: Logging functions will return a *true* value if the + message made it through to one or more appenders and a *false* value if + it didn't. This allows for constructs like + + $logger->fatal("@_") or print STDERR "@_\n"; + + which will ensure that the fatal message isn't lost if the current level + is lower than FATAL or printed twice if the level is acceptable but an + appender already points to STDERR. + + Pitfalls with Categories + Be careful with just blindly reusing the system's packages as + categories. If you do, you'll get into trouble with inherited methods. + Imagine the following class setup: + + use Log::Log4perl; + + ########################################### + package Bar; + ########################################### + sub new { + my($class) = @_; + my $logger = Log::Log4perl::get_logger(__PACKAGE__); + $logger->debug("Creating instance"); + bless {}, $class; + } + ########################################### + package Bar::Twix; + ########################################### + our @ISA = qw(Bar); + + ########################################### + package main; + ########################################### + Log::Log4perl->init(\ qq{ + log4perl.category.Bar.Twix = DEBUG, Screen + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = SimpleLayout + }); + + my $bar = Bar::Twix->new(); + + "Bar::Twix" just inherits everything from "Bar", including the + constructor "new()". Contrary to what you might be thinking at first, + this won't log anything. Reason for this is the "get_logger()" call in + package "Bar", which will always get a logger of the "Bar" category, + even if we call "new()" via the "Bar::Twix" package, which will make + perl go up the inheritance tree to actually execute "Bar::new()". Since + we've only defined logging behaviour for "Bar::Twix" in the + configuration file, nothing will happen. + + This can be fixed by changing the "get_logger()" method in "Bar::new()" + to obtain a logger of the category matching the *actual* class of the + object, like in + + # ... in Bar::new() ... + my $logger = Log::Log4perl::get_logger( $class ); + + In a method other than the constructor, the class name of the actual + object can be obtained by calling "ref()" on the object reference, so + + package BaseClass; + use Log::Log4perl qw( get_logger ); + + sub new { + bless {}, shift; + } + + sub method { + my( $self ) = @_; + + get_logger( ref $self )->debug( "message" ); + } + + package SubClass; + our @ISA = qw(BaseClass); + + is the recommended pattern to make sure that + + my $sub = SubClass->new(); + $sub->meth(); + + starts logging if the "SubClass" category (and not the "BaseClass" + category has logging enabled at the DEBUG level. + + Initialize once and only once + It's important to realize that Log::Log4perl gets initialized once and + only once, typically at the start of a program or system. Calling + "init()" more than once will cause it to clobber the existing + configuration and *replace* it by the new one. + + If you're in a traditional CGI environment, where every request is + handled by a new process, calling "init()" every time is fine. In + persistent environments like "mod_perl", however, Log::Log4perl should + be initialized either at system startup time (Apache offers startup + handlers for that) or via + + # Init or skip if already done + Log::Log4perl->init_once($conf_file); + + "init_once()" is identical to "init()", just with the exception that it + will leave a potentially existing configuration alone and will only call + "init()" if Log::Log4perl hasn't been initialized yet. + + If you're just curious if Log::Log4perl has been initialized yet, the + check + + if(Log::Log4perl->initialized()) { + # Yes, Log::Log4perl has already been initialized + } else { + # No, not initialized yet ... + } + + can be used. + + If you're afraid that the components of your system are stepping on each + other's toes or if you are thinking that different components should + initialize Log::Log4perl separately, try to consolidate your system to + use a centralized Log4perl configuration file and use Log4perl's + *categories* to separate your components. + + Custom Filters + Log4perl allows the use of customized filters in its appenders to + control the output of messages. These filters might grep for certain + text chunks in a message, verify that its priority matches or exceeds a + certain level or that this is the 10th time the same message has been + submitted -- and come to a log/no log decision based upon these + circumstantial facts. + + Check out Log::Log4perl::Filter for detailed instructions on how to use + them. + + Performance + The performance of Log::Log4perl calls obviously depends on a lot of + things. But to give you a general idea, here's some rough numbers: + + On a Pentium 4 Linux box at 2.4 GHz, you'll get through + + * 500,000 suppressed log statements per second + + * 30,000 logged messages per second (using an in-memory appender) + + * init_and_watch delay mode: 300,000 suppressed, 30,000 logged. + init_and_watch signal mode: 450,000 suppressed, 30,000 logged. + + Numbers depend on the complexity of the Log::Log4perl configuration. For + a more detailed benchmark test, check the "docs/benchmark.results.txt" + document in the Log::Log4perl distribution. + +Cool Tricks + Here's a collection of useful tricks for the advanced "Log::Log4perl" + user. For more, check the FAQ, either in the distribution + (Log::Log4perl::FAQ) or on <http://log4perl.sourceforge.net>. + + Shortcuts + When getting an instance of a logger, instead of saying + + use Log::Log4perl; + my $logger = Log::Log4perl->get_logger(); + + it's often more convenient to import the "get_logger" method from + "Log::Log4perl" into the current namespace: + + use Log::Log4perl qw(get_logger); + my $logger = get_logger(); + + Please note this difference: To obtain the root logger, please use + "get_logger("")", call it without parameters ("get_logger()"), you'll + get the logger of a category named after the current package. + "get_logger()" is equivalent to "get_logger(__PACKAGE__)". + + Alternative initialization + Instead of having "init()" read in a configuration file by specifying a + file name or passing it a reference to an open filehandle + ("Log::Log4perl->init( \*FILE )"), you can also pass in a reference to a + string, containing the content of the file: + + Log::Log4perl->init( \$config_text ); + + Also, if you've got the "name=value" pairs of the configuration in a + hash, you can just as well initialize "Log::Log4perl" with a reference + to it: + + my %key_value_pairs = ( + "log4perl.rootLogger" => "ERROR, LOGFILE", + "log4perl.appender.LOGFILE" => "Log::Log4perl::Appender::File", + ... + ); + + Log::Log4perl->init( \%key_value_pairs ); + + Or also you can use a URL, see below: + + Using LWP to parse URLs + (This section borrowed from XML::DOM::Parser by T.J. Mather). + + The init() function now also supports URLs, e.g. + *http://www.erols.com/enno/xsa.xml*. It uses LWP to download the file + and then calls parse() on the resulting string. By default it will use a + LWP::UserAgent that is created as follows: + + use LWP::UserAgent; + $LWP_USER_AGENT = LWP::UserAgent->new; + $LWP_USER_AGENT->env_proxy; + + Note that env_proxy reads proxy settings from environment variables, + which is what I need to do to get thru our firewall. If you want to use + a different LWP::UserAgent, you can set it with + + Log::Log4perl::Config::set_LWP_UserAgent($my_agent); + + Currently, LWP is used when the filename (passed to parsefile) starts + with one of the following URL schemes: http, https, ftp, wais, gopher, + or file (followed by a colon.) + + Don't use this feature with init_and_watch(). + + Automatic reloading of changed configuration files + Instead of just statically initializing Log::Log4perl via + + Log::Log4perl->init($conf_file); + + there's a way to have Log::Log4perl periodically check for changes in + the configuration and reload it if necessary: + + Log::Log4perl->init_and_watch($conf_file, $delay); + + In this mode, Log::Log4perl will examine the configuration file + $conf_file every $delay seconds for changes via the file's last + modification timestamp. If the file has been updated, it will be + reloaded and replace the current Log::Log4perl configuration. + + The way this works is that with every logger function called (debug(), + is_debug(), etc.), Log::Log4perl will check if the delay interval has + expired. If so, it will run a -M file check on the configuration file. + If its timestamp has been modified, the current configuration will be + dumped and new content of the file will be loaded. + + This convenience comes at a price, though: Calling time() with every + logging function call, especially the ones that are "suppressed" (!), + will slow down these Log4perl calls by about 40%. + + To alleviate this performance hit a bit, "init_and_watch()" can be + configured to listen for a Unix signal to reload the configuration + instead: + + Log::Log4perl->init_and_watch($conf_file, 'HUP'); + + This will set up a signal handler for SIGHUP and reload the + configuration if the application receives this signal, e.g. via the + "kill" command: + + kill -HUP pid + + where "pid" is the process ID of the application. This will bring you + back to about 85% of Log::Log4perl's normal execution speed for + suppressed statements. For details, check out "Performance". For more + info on the signal handler, look for "SIGNAL MODE" in + Log::Log4perl::Config::Watch. + + If you have a somewhat long delay set between physical config file + checks or don't want to use the signal associated with the config file + watcher, you can trigger a configuration reload at the next possible + time by calling "Log::Log4perl::Config->watcher->force_next_check()". + + One thing to watch out for: If the configuration file contains a syntax + or other fatal error, a running application will stop with "die" if this + damaged configuration will be loaded during runtime, triggered either by + a signal or if the delay period expired and the change is detected. This + behaviour might change in the future. + + To allow the application to intercept and control a configuration reload + in init_and_watch mode, a callback can be specified: + + Log::Log4perl->init_and_watch($conf_file, 10, { + preinit_callback => \&callback }); + + If Log4perl determines that the configuration needs to be reloaded, it + will call the "preinit_callback" function without parameters. If the + callback returns a true value, Log4perl will proceed and reload the + configuration. If the callback returns a false value, Log4perl will keep + the old configuration and skip reloading it until the next time around. + Inside the callback, an application can run all kinds of checks, + including accessing the configuration file, which is available via + "Log::Log4perl::Config->watcher()->file()". + + Variable Substitution + To avoid having to retype the same expressions over and over again, + Log::Log4perl's configuration files support simple variable + substitution. New variables are defined simply by adding + + varname = value + + lines to the configuration file before using + + ${varname} + + afterwards to recall the assigned values. Here's an example: + + layout_class = Log::Log4perl::Layout::PatternLayout + layout_pattern = %d %F{1} %L> %m %n + + log4perl.category.Bar.Twix = WARN, Logfile, Screen + + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = ${layout_class} + log4perl.appender.Logfile.layout.ConversionPattern = ${layout_pattern} + + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = ${layout_class} + log4perl.appender.Screen.layout.ConversionPattern = ${layout_pattern} + + This is a convenient way to define two appenders with the same layout + without having to retype the pattern definitions. + + Variable substitution via "${varname}" will first try to find an + explicitly defined variable. If that fails, it will check your shell's + environment for a variable of that name. If that also fails, the program + will "die()". + + Perl Hooks in the Configuration File + If some of the values used in the Log4perl configuration file need to be + dynamically modified by the program, use Perl hooks: + + log4perl.appender.File.filename = \ + sub { return getLogfileName(); } + + Each value starting with the string "sub {..." is interpreted as Perl + code to be executed at the time the application parses the configuration + via "Log::Log4perl::init()". The return value of the subroutine is used + by Log::Log4perl as the configuration value. + + The Perl code is executed in the "main" package, functions in other + packages have to be called in fully-qualified notation. + + Here's another example, utilizing an environment variable as a username + for a DBI appender: + + log4perl.appender.DB.username = \ + sub { $ENV{DB_USER_NAME } } + + However, please note the difference between these code snippets and + those used for user-defined conversion specifiers as discussed in + Log::Log4perl::Layout::PatternLayout: While the snippets above are run + *once* when "Log::Log4perl::init()" is called, the conversion specifier + snippets are executed *each time* a message is rendered according to the + PatternLayout. + + SECURITY NOTE: this feature means arbitrary perl code can be embedded in + the config file. In the rare case where the people who have access to + your config file are different from the people who write your code and + shouldn't have execute rights, you might want to set + + Log::Log4perl::Config->allow_code(0); + + before you call init(). Alternatively you can supply a restricted set of + Perl opcodes that can be embedded in the config file as described in + "Restricting what Opcodes can be in a Perl Hook". + + Restricting what Opcodes can be in a Perl Hook + The value you pass to Log::Log4perl::Config->allow_code() determines + whether the code that is embedded in the config file is eval'd + unrestricted, or eval'd in a Safe compartment. By default, a value of + '1' is assumed, which does a normal 'eval' without any restrictions. A + value of '0' however prevents any embedded code from being evaluated. + + If you would like fine-grained control over what can and cannot be + included in embedded code, then please utilize the following methods: + + Log::Log4perl::Config->allow_code( $allow ); + Log::Log4perl::Config->allowed_code_ops($op1, $op2, ... ); + Log::Log4perl::Config->vars_shared_with_safe_compartment( [ \%vars | $package, \@vars ] ); + Log::Log4perl::Config->allowed_code_ops_convenience_map( [ \%map | $name, \@mask ] ); + + Log::Log4perl::Config->allowed_code_ops() takes a list of opcode masks + that are allowed to run in the compartment. The opcode masks must be + specified as described in Opcode: + + Log::Log4perl::Config->allowed_code_ops(':subprocess'); + + This example would allow Perl operations like backticks, system, fork, + and waitpid to be executed in the compartment. Of course, you probably + don't want to use this mask -- it would allow exactly what the Safe + compartment is designed to prevent. + + Log::Log4perl::Config->vars_shared_with_safe_compartment() takes the + symbols which should be exported into the Safe compartment before the + code is evaluated. The keys of this hash are the package names that the + symbols are in, and the values are array references to the literal + symbol names. For convenience, the default settings export the '%ENV' + hash from the 'main' package into the compartment: + + Log::Log4perl::Config->vars_shared_with_safe_compartment( + main => [ '%ENV' ], + ); + + Log::Log4perl::Config->allowed_code_ops_convenience_map() is an accessor + method to a map of convenience names to opcode masks. At present, the + following convenience names are defined: + + safe = [ ':browse' ] + restrictive = [ ':default' ] + + For convenience, if Log::Log4perl::Config->allow_code() is called with a + value which is a key of the map previously defined with + Log::Log4perl::Config->allowed_code_ops_convenience_map(), then the + allowed opcodes are set according to the value defined in the map. If + this is confusing, consider the following: + + use Log::Log4perl; + + my $config = <<'END'; + log4perl.logger = INFO, Main + log4perl.appender.Main = Log::Log4perl::Appender::File + log4perl.appender.Main.filename = \ + sub { "example" . getpwuid($<) . ".log" } + log4perl.appender.Main.layout = Log::Log4perl::Layout::SimpleLayout + END + + $Log::Log4perl::Config->allow_code('restrictive'); + Log::Log4perl->init( \$config ); # will fail + $Log::Log4perl::Config->allow_code('safe'); + Log::Log4perl->init( \$config ); # will succeed + + The reason that the first call to ->init() fails is because the + 'restrictive' name maps to an opcode mask of ':default'. getpwuid() is + not part of ':default', so ->init() fails. The 'safe' name maps to an + opcode mask of ':browse', which allows getpwuid() to run, so ->init() + succeeds. + + allowed_code_ops_convenience_map() can be invoked in several ways: + + allowed_code_ops_convenience_map() + Returns the entire convenience name map as a hash reference in + scalar context or a hash in list context. + + allowed_code_ops_convenience_map( \%map ) + Replaces the entire convenience name map with the supplied hash + reference. + + allowed_code_ops_convenience_map( $name ) + Returns the opcode mask for the given convenience name, or undef if + no such name is defined in the map. + + allowed_code_ops_convenience_map( $name, \@mask ) + Adds the given name/mask pair to the convenience name map. If the + name already exists in the map, it's value is replaced with the new + mask. + + as can vars_shared_with_safe_compartment(): + + vars_shared_with_safe_compartment() + Return the entire map of packages to variables as a hash reference + in scalar context or a hash in list context. + + vars_shared_with_safe_compartment( \%packages ) + Replaces the entire map of packages to variables with the supplied + hash reference. + + vars_shared_with_safe_compartment( $package ) + Returns the arrayref of variables to be shared for a specific + package. + + vars_shared_with_safe_compartment( $package, \@vars ) + Adds the given package / varlist pair to the map. If the package + already exists in the map, it's value is replaced with the new + arrayref of variable names. + + For more information on opcodes and Safe Compartments, see Opcode and + Safe. + + Changing the Log Level on a Logger + Log4perl provides some internal functions for quickly adjusting the log + level from within a running Perl program. + + Now, some people might argue that you should adjust your levels from + within an external Log4perl configuration file, but Log4perl is + everybody's darling. + + Typically run-time adjusting of levels is done at the beginning, or in + response to some external input (like a "more logging" runtime command + for diagnostics). + + You get the log level from a logger object with: + + $current_level = $logger->level(); + + and you may set it with the same method, provided you first imported the + log level constants, with: + + use Log::Log4perl::Level; + + Then you can set the level on a logger to one of the constants, + + $logger->level($ERROR); # one of DEBUG, INFO, WARN, ERROR, FATAL + + To increase the level of logging currently being done, use: + + $logger->more_logging($delta); + + and to decrease it, use: + + $logger->less_logging($delta); + + $delta must be a positive integer (for now, we may fix this later ;). + + There are also two equivalent functions: + + $logger->inc_level($delta); + $logger->dec_level($delta); + + They're included to allow you a choice in readability. Some folks will + prefer more/less_logging, as they're fairly clear in what they do, and + allow the programmer not to worry too much about what a Level is and + whether a higher Level means more or less logging. However, other folks + who do understand and have lots of code that deals with levels will + probably prefer the inc_level() and dec_level() methods as they want to + work with Levels and not worry about whether that means more or less + logging. :) + + That diatribe aside, typically you'll use more_logging() or inc_level() + as such: + + my $v = 0; # default level of verbosity. + + GetOptions("v+" => \$v, ...); + + if( $v ) { + $logger->more_logging($v); # inc logging level once for each -v in ARGV + } + + Custom Log Levels + First off, let me tell you that creating custom levels is heavily + deprecated by the log4j folks. Indeed, instead of creating additional + levels on top of the predefined DEBUG, INFO, WARN, ERROR and FATAL, you + should use categories to control the amount of logging smartly, based on + the location of the log-active code in the system. + + Nevertheless, Log4perl provides a nice way to create custom levels via + the create_custom_level() routine function. However, this must be done + before the first call to init() or get_logger(). Say you want to create + a NOTIFY logging level that comes after WARN (and thus before INFO). + You'd do such as follows: + + use Log::Log4perl; + use Log::Log4perl::Level; + + Log::Log4perl::Logger::create_custom_level("NOTIFY", "WARN"); + + And that's it! create_custom_level() creates the following functions / + variables for level FOO: + + $FOO_INT # integer to use in L4p::Level::to_level() + $logger->foo() # log function to log if level = FOO + $logger->is_foo() # true if current level is >= FOO + + These levels can also be used in your config file, but note that your + config file probably won't be portable to another log4perl or log4j + environment unless you've made the appropriate mods there too. + + Since Log4perl translates log levels to syslog and Log::Dispatch if + their appenders are used, you may add mappings for custom levels as + well: + + Log::Log4perl::Level::add_priority("NOTIFY", "WARN", + $syslog_equiv, $log_dispatch_level); + + For example, if your new custom "NOTIFY" level is supposed to map to + syslog level 2 ("LOG_NOTICE") and Log::Dispatch level 2 ("notice"), use: + + Log::Log4perl::Logger::create_custom_level("NOTIFY", "WARN", 2, 2); + + System-wide log levels + As a fairly drastic measure to decrease (or increase) the logging level + all over the system with one single configuration option, use the + "threshold" keyword in the Log4perl configuration file: + + log4perl.threshold = ERROR + + sets the system-wide (or hierarchy-wide according to the log4j + documentation) to ERROR and therefore deprives every logger in the + system of the right to log lower-prio messages. + + Easy Mode + For teaching purposes (especially for [1]), I've put ":easy" mode into + "Log::Log4perl", which just initializes a single root logger with a + defined priority and a screen appender including some nice standard + layout: + + ### Initialization Section + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init($ERROR); # Set priority of root logger to ERROR + + ### Application Section + my $logger = get_logger(); + $logger->fatal("This will get logged."); + $logger->debug("This won't."); + + This will dump something like + + 2002/08/04 11:43:09 ERROR> script.pl:16 main::function - This will get logged. + + to the screen. While this has been proven to work well familiarizing + people with "Log::Logperl" slowly, effectively avoiding to clobber them + over the head with a plethora of different knobs to fiddle with + (categories, appenders, levels, layout), the overall mission of + "Log::Log4perl" is to let people use categories right from the start to + get used to the concept. So, let's keep this one fairly hidden in the + man page (congrats on reading this far :). + + Stealth loggers + Sometimes, people are lazy. If you're whipping up a 50-line script and + want the comfort of Log::Log4perl without having the burden of carrying + a separate log4perl.conf file or a 5-liner defining that you want to + append your log statements to a file, you can use the following + features: + + use Log::Log4perl qw(:easy); + + Log::Log4perl->easy_init( { level => $DEBUG, + file => ">>test.log" } ); + + # Logs to test.log via stealth logger + DEBUG("Debug this!"); + INFO("Info this!"); + WARN("Warn this!"); + ERROR("Error this!"); + + some_function(); + + sub some_function { + # Same here + FATAL("Fatal this!"); + } + + In ":easy" mode, "Log::Log4perl" will instantiate a *stealth logger* and + introduce the convenience functions "TRACE", "DEBUG()", "INFO()", + "WARN()", "ERROR()", "FATAL()", and "ALWAYS" into the package namespace. + These functions simply take messages as arguments and forward them to + the stealth loggers methods ("debug()", "info()", and so on). + + If a message should never be blocked, regardless of the log level, use + the "ALWAYS" function which corresponds to a log level of "OFF": + + ALWAYS "This will be printed regardless of the log level"; + + The "easy_init" method can be called with a single level value to create + a STDERR appender and a root logger as in + + Log::Log4perl->easy_init($DEBUG); + + or, as shown below (and in the example above) with a reference to a + hash, specifying values for "level" (the logger's priority), "file" (the + appender's data sink), "category" (the logger's category and "layout" + for the appender's pattern layout specification. All key-value pairs are + optional, they default to $DEBUG for "level", "STDERR" for "file", "" + (root category) for "category" and "%d %m%n" for "layout": + + Log::Log4perl->easy_init( { level => $DEBUG, + file => ">test.log", + utf8 => 1, + category => "Bar::Twix", + layout => '%F{1}-%L-%M: %m%n' } ); + + The "file" parameter takes file names preceded by ">" (overwrite) and + ">>" (append) as arguments. This will cause + "Log::Log4perl::Appender::File" appenders to be created behind the + scenes. Also the keywords "STDOUT" and "STDERR" (no ">" or ">>") are + recognized, which will utilize and configure + "Log::Log4perl::Appender::Screen" appropriately. The "utf8" flag, if set + to a true value, runs a "binmode" command on the file handle to + establish a utf8 line discipline on the file, otherwise you'll get a + 'wide character in print' warning message and probably not what you'd + expect as output. + + The stealth loggers can be used in different packages, you just need to + make sure you're calling the "use" function in every package you're + using "Log::Log4perl"'s easy services: + + package Bar::Twix; + use Log::Log4perl qw(:easy); + sub eat { DEBUG("Twix mjam"); } + + package Bar::Mars; + use Log::Log4perl qw(:easy); + sub eat { INFO("Mars mjam"); } + + package main; + + use Log::Log4perl qw(:easy); + + Log::Log4perl->easy_init( { level => $DEBUG, + file => ">>test.log", + category => "Bar::Twix", + layout => '%F{1}-%L-%M: %m%n' }, + { level => $DEBUG, + file => "STDOUT", + category => "Bar::Mars", + layout => '%m%n' }, + ); + Bar::Twix::eat(); + Bar::Mars::eat(); + + As shown above, "easy_init()" will take any number of different logger + definitions as hash references. + + Also, stealth loggers feature the functions "LOGWARN()", "LOGDIE()", and + "LOGEXIT()", combining a logging request with a subsequent Perl warn() + or die() or exit() statement. So, for example + + if($all_is_lost) { + LOGDIE("Terrible Problem"); + } + + will log the message if the package's logger is at least "FATAL" but + "die()" (including the traditional output to STDERR) in any case + afterwards. + + See "Log and die or warn" for the similar "logdie()" and "logwarn()" + functions of regular (i.e non-stealth) loggers. + + Similarily, "LOGCARP()", "LOGCLUCK()", "LOGCROAK()", and "LOGCONFESS()" + are provided in ":easy" mode, facilitating the use of "logcarp()", + "logcluck()", "logcroak()", and "logconfess()" with stealth loggers. + + When using Log::Log4perl in easy mode, please make sure you understand + the implications of "Pitfalls with Categories". + + By the way, these convenience functions perform exactly as fast as the + standard Log::Log4perl logger methods, there's *no* performance penalty + whatsoever. + + Nested Diagnostic Context (NDC) + If you find that your application could use a global (thread-specific) + data stack which your loggers throughout the system have easy access to, + use Nested Diagnostic Contexts (NDCs). Also check out "Mapped Diagnostic + Context (MDC)", this might turn out to be even more useful. + + For example, when handling a request of a web client, it's probably + useful to have the user's IP address available in all log statements + within code dealing with this particular request. Instead of passing + this piece of data around between your application functions, you can + just use the global (but thread-specific) NDC mechanism. It allows you + to push data pieces (scalars usually) onto its stack via + + Log::Log4perl::NDC->push("San"); + Log::Log4perl::NDC->push("Francisco"); + + and have your loggers retrieve them again via the "%x" placeholder in + the PatternLayout. With the stack values above and a PatternLayout + format like "%x %m%n", the call + + $logger->debug("rocks"); + + will end up as + + San Francisco rocks + + in the log appender. + + The stack mechanism allows for nested structures. Just make sure that at + the end of the request, you either decrease the stack one by one by + calling + + Log::Log4perl::NDC->pop(); + Log::Log4perl::NDC->pop(); + + or clear out the entire NDC stack by calling + + Log::Log4perl::NDC->remove(); + + Even if you should forget to do that, "Log::Log4perl" won't grow the + stack indefinitely, but limit it to a maximum, defined in + "Log::Log4perl::NDC" (currently 5). A call to "push()" on a full stack + will just replace the topmost element by the new value. + + Again, the stack is always available via the "%x" placeholder in the + Log::Log4perl::Layout::PatternLayout class whenever a logger fires. It + will replace "%x" by the blank-separated list of the values on the + stack. It does that by just calling + + Log::Log4perl::NDC->get(); + + internally. See details on how this standard log4j feature is + implemented in Log::Log4perl::NDC. + + Mapped Diagnostic Context (MDC) + Just like the previously discussed NDC stores thread-specific + information in a stack structure, the MDC implements a hash table to + store key/value pairs in. + + The static method + + Log::Log4perl::MDC->put($key, $value); + + stores $value under a key $key, with which it can be retrieved later + (possibly in a totally different part of the system) by calling the + "get" method: + + my $value = Log::Log4perl::MDC->get($key); + + If no value has been stored previously under $key, the "get" method will + return "undef". + + Typically, MDC values are retrieved later on via the "%X{...}" + placeholder in "Log::Log4perl::Layout::PatternLayout". If the "get()" + method returns "undef", the placeholder will expand to the string + "[undef]". + + An application taking a web request might store the remote host like + + Log::Log4perl::MDC->put("remote_host", $r->headers("HOST")); + + at its beginning and if the appender's layout looks something like + + log4perl.appender.Logfile.layout.ConversionPattern = %X{remote_host}: %m%n + + then a log statement like + + DEBUG("Content delivered"); + + will log something like + + adsl-63.dsl.snf.pacbell.net: Content delivered + + later on in the program. + + For details, please check Log::Log4perl::MDC. + + Resurrecting hidden Log4perl Statements + Sometimes scripts need to be deployed in environments without having + Log::Log4perl installed yet. On the other hand, you don't want to live + without your Log4perl statements -- they're gonna come in handy later. + + So, just deploy your script with Log4perl statements commented out with + the pattern "###l4p", like in + + ###l4p DEBUG "It works!"; + # ... + ###l4p INFO "Really!"; + + If Log::Log4perl is available, use the ":resurrect" tag to have Log4perl + resurrect those buried statements before the script starts running: + + use Log::Log4perl qw(:resurrect :easy); + + ###l4p Log::Log4perl->easy_init($DEBUG); + ###l4p DEBUG "It works!"; + # ... + ###l4p INFO "Really!"; + + This will have a source filter kick in and indeed print + + 2004/11/18 22:08:46 It works! + 2004/11/18 22:08:46 Really! + + In environments lacking Log::Log4perl, just comment out the first line + and the script will run nevertheless (but of course without logging): + + # use Log::Log4perl qw(:resurrect :easy); + + ###l4p Log::Log4perl->easy_init($DEBUG); + ###l4p DEBUG "It works!"; + # ... + ###l4p INFO "Really!"; + + because everything's a regular comment now. Alternatively, put the magic + Log::Log4perl comment resurrection line into your shell's PERL5OPT + environment variable, e.g. for bash: + + set PERL5OPT=-MLog::Log4perl=:resurrect,:easy + export PERL5OPT + + This will awaken the giant within an otherwise silent script like the + following: + + #!/usr/bin/perl + + ###l4p Log::Log4perl->easy_init($DEBUG); + ###l4p DEBUG "It works!"; + + As of "Log::Log4perl" 1.12, you can even force *all* modules loaded by a + script to have their hidden Log4perl statements resurrected. For this to + happen, load "Log::Log4perl::Resurrector" *before* loading any modules: + + use Log::Log4perl qw(:easy); + use Log::Log4perl::Resurrector; + + use Foobar; # All hidden Log4perl statements in here will + # be uncommented before Foobar gets loaded. + + Log::Log4perl->easy_init($DEBUG); + ... + + Check the "Log::Log4perl::Resurrector" manpage for more details. + + Access defined appenders + All appenders defined in the configuration file or via Perl code can be + retrieved by the "appender_by_name()" class method. This comes in handy + if you want to manipulate or query appender properties after the + Log4perl configuration has been loaded via "init()". + + Note that internally, Log::Log4perl uses the "Log::Log4perl::Appender" + wrapper class to control the real appenders (like + "Log::Log4perl::Appender::File" or "Log::Dispatch::FileRotate"). The + "Log::Log4perl::Appender" class has an "appender" attribute, pointing to + the real appender. + + The reason for this is that external appenders like + "Log::Dispatch::FileRotate" don't support all of Log::Log4perl's + appender control mechanisms (like appender thresholds). + + The previously mentioned method "appender_by_name()" returns a reference + to the *real* appender object. If you want access to the wrapper class + (e.g. if you want to modify the appender's threshold), use the hash + $Log::Log4perl::Logger::APPENDER_BY_NAME{...} instead, which holds + references to all appender wrapper objects. + + Modify appender thresholds + To set an appender's threshold, use its "threshold()" method: + + $app->threshold( $FATAL ); + + To conveniently adjust *all* appender thresholds (e.g. because a script + uses more_logging()), use + + # decrease thresholds of all appenders + Log::Log4perl->appender_thresholds_adjust(-1); + + This will decrease the thresholds of all appenders in the system by one + level, i.e. WARN becomes INFO, INFO becomes DEBUG, etc. To only modify + selected ones, use + + # decrease thresholds of all appenders + Log::Log4perl->appender_thresholds_adjust(-1, ['AppName1', ...]); + + and pass the names of affected appenders in a ref to an array. + +Advanced configuration within Perl + Initializing Log::Log4perl can certainly also be done from within Perl. + At last, this is what "Log::Log4perl::Config" does behind the scenes. + Log::Log4perl's configuration file parsers are using a publically + available API to set up Log::Log4perl's categories, appenders and + layouts. + + Here's an example on how to configure two appenders with the same layout + in Perl, without using a configuration file at all: + + ######################## + # Initialization section + ######################## + use Log::Log4perl; + use Log::Log4perl::Layout; + use Log::Log4perl::Level; + + # Define a category logger + my $log = Log::Log4perl->get_logger("Foo::Bar"); + + # Define a layout + my $layout = Log::Log4perl::Layout::PatternLayout->new("[%r] %F %L %m%n"); + + # Define a file appender + my $file_appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::File", + name => "filelog", + filename => "/tmp/my.log"); + + # Define a stdout appender + my $stdout_appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::Screen", + name => "screenlog", + stderr => 0); + + # Have both appenders use the same layout (could be different) + $stdout_appender->layout($layout); + $file_appender->layout($layout); + + $log->add_appender($stdout_appender); + $log->add_appender($file_appender); + $log->level($INFO); + + Please note the class of the appender object is passed as a *string* to + "Log::Log4perl::Appender" in the *first* argument. Behind the scenes, + "Log::Log4perl::Appender" will create the necessary + "Log::Log4perl::Appender::*" (or "Log::Dispatch::*") object and pass + along the name value pairs we provided to + "Log::Log4perl::Appender->new()" after the first argument. + + The "name" value is optional and if you don't provide one, + "Log::Log4perl::Appender->new()" will create a unique one for you. The + names and values of additional parameters are dependent on the + requirements of the particular appender class and can be looked up in + their manual pages. + + A side note: In case you're wondering if + "Log::Log4perl::Appender->new()" will also take care of the "min_level" + argument to the "Log::Dispatch::*" constructors called behind the scenes + -- yes, it does. This is because we want the "Log::Dispatch" objects to + blindly log everything we send them ("debug" is their lowest setting) + because *we* in "Log::Log4perl" want to call the shots and decide on + when and what to log. + + The call to the appender's *layout()* method specifies the format (as a + previously created "Log::Log4perl::Layout::PatternLayout" object) in + which the message is being logged in the specified appender. If you + don't specify a layout, the logger will fall back to + "Log::Log4perl::SimpleLayout", which logs the debug level, a hyphen (-) + and the log message. + + Layouts are objects, here's how you create them: + + # Create a simple layout + my $simple = Log::Log4perl::SimpleLayout(); + + # create a flexible layout: + # ("yyyy/MM/dd hh:mm:ss (file:lineno)> message\n") + my $pattern = Log::Log4perl::Layout::PatternLayout("%d (%F:%L)> %m%n"); + + Every appender has exactly one layout assigned to it. You assign the + layout to the appender using the appender's "layout()" object: + + my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::Screen", + name => "screenlog", + stderr => 0); + + # Assign the previously defined flexible layout + $app->layout($pattern); + + # Add the appender to a previously defined logger + $logger->add_appender($app); + + # ... and you're good to go! + $logger->debug("Blah"); + # => "2002/07/10 23:55:35 (test.pl:207)> Blah\n" + + It's also possible to remove appenders from a logger: + + $logger->remove_appender($appender_name); + + will remove an appender, specified by name, from a given logger. Please + note that this does *not* remove an appender from the system. + + To eradicate an appender from the system, you need to call + "Log::Log4perl->eradicate_appender($appender_name)" which will first + remove the appender from every logger in the system and then will delete + all references Log4perl holds to it. + + To remove a logger from the system, use + "Log::Log4perl->remove_logger($logger)". After the remaining reference + $logger goes away, the logger will self-destruct. If the logger in + question is a stealth logger, all of its convenience shortcuts (DEBUG, + INFO, etc) will turn into no-ops. + +How about Log::Dispatch::Config? + Tatsuhiko Miyagawa's "Log::Dispatch::Config" is a very clever simplified + logger implementation, covering some of the *log4j* functionality. Among + the things that "Log::Log4perl" can but "Log::Dispatch::Config" can't + are: + + * You can't assign categories to loggers. For small systems that's + fine, but if you can't turn off and on detailed logging in only a + tiny subsystem of your environment, you're missing out on a majorly + useful log4j feature. + + * Defining appender thresholds. Important if you want to solve + problems like "log all messages of level FATAL to STDERR, plus log + all DEBUG messages in "Foo::Bar" to a log file". If you don't have + appenders thresholds, there's no way to prevent cluttering STDERR + with DEBUG messages. + + * PatternLayout specifications in accordance with the standard (e.g. + "%d{HH:mm}"). + + Bottom line: Log::Dispatch::Config is fine for small systems with simple + logging requirements. However, if you're designing a system with lots of + subsystems which you need to control independently, you'll love the + features of "Log::Log4perl", which is equally easy to use. + +Using Log::Log4perl with wrapper functions and classes + If you don't use "Log::Log4perl" as described above, but from a wrapper + function, the pattern layout will generate wrong data for %F, %C, %L, + and the like. Reason for this is that "Log::Log4perl"'s loggers assume a + static caller depth to the application that's using them. + + If you're using one (or more) wrapper functions, "Log::Log4perl" will + indicate where your logger function called the loggers, not where your + application called your wrapper: + + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init({ level => $DEBUG, + layout => "%M %m%n" }); + + sub mylog { + my($message) = @_; + + DEBUG $message; + } + + sub func { + mylog "Hello"; + } + + func(); + + prints + + main::mylog Hello + + but that's probably not what your application expects. Rather, you'd + want + + main::func Hello + + because the "func" function called your logging function. + + But don't despair, there's a solution: Just register your wrapper + package with Log4perl beforehand. If Log4perl then finds that it's being + called from a registered wrapper, it will automatically step up to the + next call frame. + + Log::Log4perl->wrapper_register(__PACKAGE__); + + sub mylog { + my($message) = @_; + + DEBUG $message; + } + + Alternatively, you can increase the value of the global variable + $Log::Log4perl::caller_depth (defaults to 0) by one for every wrapper + that's in between your application and "Log::Log4perl", then + "Log::Log4perl" will compensate for the difference: + + sub mylog { + my($message) = @_; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + DEBUG $message; + } + + Also, note that if you're writing a subclass of Log4perl, like + + package MyL4pWrapper; + use Log::Log4perl; + our @ISA = qw(Log::Log4perl); + + and you want to call get_logger() in your code, like + + use MyL4pWrapper; + + sub get_logger { + my $logger = Log::Log4perl->get_logger(); + } + + then the get_logger() call will get a logger for the "MyL4pWrapper" + category, not for the package calling the wrapper class as in + + package UserPackage; + my $logger = MyL4pWrapper->get_logger(); + + To have the above call to get_logger return a logger for the + "UserPackage" category, you need to tell Log4perl that "MyL4pWrapper" is + a Log4perl wrapper class: + + use MyL4pWrapper; + Log::Log4perl->wrapper_register(__PACKAGE__); + + sub get_logger { + # Now gets a logger for the category of the calling package + my $logger = Log::Log4perl->get_logger(); + } + + This feature works both for Log4perl-relaying classes like the wrapper + described above, and for wrappers that inherit from Log4perl use + Log4perl's get_logger function via inheritance, alike. + +Access to Internals + The following methods are only of use if you want to peek/poke in the + internals of Log::Log4perl. Be careful not to disrupt its inner + workings. + + "Log::Log4perl->appenders()" + To find out which appenders are currently defined (not only for a + particular logger, but overall), a "appenders()" method is available + to return a reference to a hash mapping appender names to their + Log::Log4perl::Appender object references. + +Dirty Tricks + infiltrate_lwp() + The famous LWP::UserAgent module isn't Log::Log4perl-enabled. Often, + though, especially when tracing Web-related problems, it would be + helpful to get some insight on what's happening inside + LWP::UserAgent. Ideally, LWP::UserAgent would even play along in the + Log::Log4perl framework. + + A call to "Log::Log4perl->infiltrate_lwp()" does exactly this. In a + very rude way, it pulls the rug from under LWP::UserAgent and + transforms its "debug/conn" messages into "debug()" calls of loggers + of the category "LWP::UserAgent". Similarily, "LWP::UserAgent"'s + "trace" messages are turned into "Log::Log4perl"'s "info()" method + calls. Note that this only works for LWP::UserAgent versions < + 5.822, because this (and probably later) versions miss debugging + functions entirely. + + Suppressing 'duplicate' LOGDIE messages + If a script with a simple Log4perl configuration uses logdie() to + catch errors and stop processing, as in + + use Log::Log4perl qw(:easy) ; + Log::Log4perl->easy_init($DEBUG); + + shaky_function() or LOGDIE "It failed!"; + + there's a cosmetic problem: The message gets printed twice: + + 2005/07/10 18:37:14 It failed! + It failed! at ./t line 12 + + The obvious solution is to use LOGEXIT() instead of LOGDIE(), but + there's also a special tag for Log4perl that suppresses the second + message: + + use Log::Log4perl qw(:no_extra_logdie_message); + + This causes logdie() and logcroak() to call exit() instead of die(). + To modify the script exit code in these occasions, set the variable + $Log::Log4perl::LOGEXIT_CODE to the desired value, the default is 1. + + Redefine values without causing errors + Log4perl's configuration file parser has a few basic safety + mechanisms to make sure configurations are more or less sane. + + One of these safety measures is catching redefined values. For + example, if you first write + + log4perl.category = WARN, Logfile + + and then a couple of lines later + + log4perl.category = TRACE, Logfile + + then you might have unintentionally overwritten the first value and + Log4perl will die on this with an error (suspicious configurations + always throw an error). Now, there's a chance that this is + intentional, for example when you're lumping together several + configuration files and actually *want* the first value to overwrite + the second. In this case use + + use Log::Log4perl qw(:nostrict); + + to put Log4perl in a more permissive mode. + + Prevent croak/confess from stringifying + The logcroak/logconfess functions stringify their arguments before + they pass them to Carp's croak/confess functions. This can get in + the way if you want to throw an object or a hashref as an exception, + in this case use: + + $Log::Log4perl::STRINGIFY_DIE_MESSAGE = 0; + + eval { + # throws { foo => "bar" } + # without stringification + $logger->logcroak( { foo => "bar" } ); + }; + +EXAMPLE + A simple example to cut-and-paste and get started: + + use Log::Log4perl qw(get_logger); + + my $conf = q( + log4perl.category.Bar.Twix = WARN, Logfile + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.Logfile.layout.ConversionPattern = %d %F{1} %L> %m %n + ); + + Log::Log4perl::init(\$conf); + + my $logger = get_logger("Bar::Twix"); + $logger->error("Blah"); + + This will log something like + + 2002/09/19 23:48:15 t1 25> Blah + + to the log file "test.log", which Log4perl will append to or create it + if it doesn't exist already. + +INSTALLATION + If you want to use external appenders provided with "Log::Dispatch", you + need to install "Log::Dispatch" (2.00 or better) from CPAN, which itself + depends on "Attribute-Handlers" and "Params-Validate". And a lot of + other modules, that's the reason why we're now shipping Log::Log4perl + with its own standard appenders and only if you wish to use additional + ones, you'll have to go through the "Log::Dispatch" installation + process. + + Log::Log4perl needs "Test::More", "Test::Harness" and "File::Spec", but + they already come with fairly recent versions of perl. If not, + everything's automatically fetched from CPAN if you're using the CPAN + shell (CPAN.pm), because they're listed as dependencies. + + "Time::HiRes" (1.20 or better) is required only if you need the + fine-grained time stamps of the %r parameter in + "Log::Log4perl::Layout::PatternLayout". + + Manual installation works as usual with + + perl Makefile.PL + make + make test + make install + +DEVELOPMENT + Log::Log4perl is still being actively developed. We will always make + sure the test suite (approx. 500 cases) will pass, but there might still + be bugs. please check <http://github.com/mschilli/log4perl> for the + latest release. The api has reached a mature state, we will not change + it unless for a good reason. + + Bug reports and feedback are always welcome, just email them to our + mailing list shown in the AUTHORS section. We're usually addressing them + immediately. + +REFERENCES + [1] Michael Schilli, "Retire your debugger, log smartly with + Log::Log4perl!", Tutorial on perl.com, 09/2002, + <http://www.perl.com/pub/a/2002/09/11/log4perl.html> + + [2] Ceki Gülcü, "Short introduction to log4j", + <http://logging.apache.org/log4j/1.2/manual.html> + + [3] Vipan Singla, "Don't Use System.out.println! Use Log4j.", + <http://www.vipan.com/htdocs/log4jhelp.html> + + [4] The Log::Log4perl project home page: <http://log4perl.com> + +SEE ALSO + Log::Log4perl::Config, Log::Log4perl::Appender, + Log::Log4perl::Layout::PatternLayout, + Log::Log4perl::Layout::SimpleLayout, Log::Log4perl::Level, + Log::Log4perl::JavaMap Log::Log4perl::NDC, + +AUTHORS + 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. + +LICENSE + Copyright 2002-2013 by Mike Schilli <m@perlmeister.com> and Kevin Goess + <cpan@goess.org>. + + This library is free software; you can redistribute it and/or modify it + under the same terms as Perl itself. + diff --git a/eg/5005it.pl b/eg/5005it.pl new file mode 100755 index 0000000..82545d2 --- /dev/null +++ b/eg/5005it.pl @@ -0,0 +1,84 @@ +#!/usr/bin/perl +########################################### +# 5005it -- make a PM file 5005-compatible +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### +use 5.00503; +use strict; + +use File::Find; + +my $USEVARS_DONE = 0; +my @OUR_VARS = (); + +########################################### +sub mk5005 { +########################################### + find(\&process_file, "lib", "t"); +} + +########################################### +sub process_file { +########################################### + my($file) = $_; + + return unless -f $file; + + $USEVARS_DONE = 0; + @OUR_VARS = (); + + open FILE, "<$file" or die "Cannot open $file"; + my $data = join '', <FILE>; + close FILE; + + while($data =~ /^our[\s(]+([\$%@][\w_]+).*[;=]/mg) { + push @OUR_VARS, $1; + } + + # Replace 'our' variables + $data =~ s/^our[\s(]+[\$%@][\w_]+.*/rep_our($&)/meg; + + # Replace 'use 5.006' lines + $data =~ s/^use\s+5\.006/\nuse 5.00503/mg; + + # Delete 'no/use warnings;': \s seems to eat newlines, so use [] + $data =~ s/^[ \t]*use warnings;//mg; + $data =~ s/^[ \t]*no warnings.*?;/\$\^W = undef;/mg; + + # 5.00503 can't handle constants that start with a _ + $data =~ s/_INTERNAL_DEBUG/INTERNAL_DEBUG/g; + + # Anything before 5.6.0 doesn't have the two argument binmode. + # Convert to one arg version by discarding second arg. + $data =~ s{ binmode \s* \(? (.*?) , .* \)? \s* ; }{ "binmode $1 ;" }gex; + + open FILE, ">$file" or die "Cannot open $file"; + print FILE $data; + close FILE; +} + +########################################### +sub rep_our { +########################################### + my($line) = @_; + + my $out = ""; + + if(!$USEVARS_DONE) { + $out = "use vars qw(" . join(" ", @OUR_VARS) . "); "; + $USEVARS_DONE = 1; + } + + if($line =~ /=/) { + # There's an assignment, just skip the 'our' + $line =~ s/^our\s+//; + } else { + # There's nothing, just get rid of the entire line + $line = "\n"; + } + + $out .= $line; + return $out; +} + +1; diff --git a/eg/L4pResurrectable.pm b/eg/L4pResurrectable.pm new file mode 100644 index 0000000..fd527ca --- /dev/null +++ b/eg/L4pResurrectable.pm @@ -0,0 +1,12 @@ +package L4pResurrectable; +use Log::Log4perl qw(:easy); +use vars qw($VERSION); + +$VERSION = "0.01"; + +sub foo { + ###l4p DEBUG "foo was here"; + ###l4p INFO "bar was here"; +} + +1; diff --git a/eg/benchmarks/Makefile b/eg/benchmarks/Makefile new file mode 100644 index 0000000..b07d17e --- /dev/null +++ b/eg/benchmarks/Makefile @@ -0,0 +1,10 @@ + +all: + perl -I../../blib/lib -MLog::Log4perl -le 'print $$Log::Log4perl::VERSION' + perl -I../../blib/lib ./simple + +master: + cd ../..; git checkout master; perl Makefile.PL >/dev/null; make >/dev/null + +eval_free: + cd ../..; git checkout eval_free; perl Makefile.PL >/dev/null; make >/dev/null diff --git a/eg/benchmarks/simple b/eg/benchmarks/simple new file mode 100755 index 0000000..9558efc --- /dev/null +++ b/eg/benchmarks/simple @@ -0,0 +1,79 @@ +#!/usr/local/bin/perl -w +########################################### +# Log4perl Benchmarks +# Mike Schilli, 2008 (m@perlmeister.com) +########################################### +use strict; +use Benchmark qw(timeit timestr); +use Log::Log4perl qw(:easy); +use Sysadm::Install qw(:all); +use Data::Dumper; +use File::Temp qw(tempfile); + +my($tmp_fh, $tmp_file) = tempfile( UNLINK => 1 ); + +my $nof_tests = 100000; + +print "sp=suppressed w=watch sc=subcategory\n\n"; + +for my $watch (0, 1) { + test_init({ level => "DEBUG", watch => $watch }); + run("sp0 sc0 w$watch", \&debug_logger); + + test_init({ level => "ERROR", watch => $watch }); + run("sp1 sc0 w$watch", \&debug_logger); + + test_init({ level => "DEBUG", watch => $watch }); + run("sp0 sc1 w$watch", \&subcat_logger); + + test_init({ level => "ERROR", watch => $watch }); + run("sp1 sc1 w$watch", \&subcat_logger); +} + +########################################### +sub run { +########################################### + my($name, $sub) = @_; + + my $t = timeit(1, $sub); + printf "$name: %8.0f per sec\n", $nof_tests/$t->[1]; +} + +########################################### +sub test_init { +########################################### + my($opts) = @_; + + my $conf = qq{ + log4perl.logger = $opts->{level}, testapp + log4perl.appender.testapp = Log::Log4perl::Appender::TestBuffer + log4perl.appender.testapp.layout= SimpleLayout + }; + + if($opts->{watch}) { + blurt $conf, $tmp_file; + Log::Log4perl->init_and_watch( $tmp_file ); + } else { + Log::Log4perl->init( \$conf ); + } +} + +########################################### +sub debug_logger { +########################################### + my $logger = get_logger(""); + + for(1..$nof_tests) { + $logger->debug( "message" ); + } +} + +########################################### +sub subcat_logger { +########################################### + my $logger = get_logger("a.b.c.d.e.f.g.h.i.j.k"); + + for(1..$nof_tests) { + $logger->debug( "message" ); + } +} diff --git a/eg/color b/eg/color new file mode 100755 index 0000000..ff9f52d --- /dev/null +++ b/eg/color @@ -0,0 +1,26 @@ +#!/usr/bin/perl +###################################################################### +# color - Print messages colored by level +###################################################################### +use strict; +use warnings; + +my $VERSION = "0.01"; +our $CVSVERSION = '$Revision: 1.1 $'; + +use Log::Log4perl qw(:easy); +Log::Log4perl->init(\ <<'EOT'); + log4perl.category = DEBUG, Screen + log4perl.appender.Screen = Log::Log4perl::Appender::ScreenColoredLevels + log4perl.appender.Screen.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.Screen.layout.ConversionPattern = %d %F{1} %L> %m %n +EOT + +for(1..3) { + DEBUG "Debug Message"; + INFO "Info Message"; + WARN "Warn Message"; + ERROR "Error Message"; + FATAL "Fatal Message"; +} diff --git a/eg/dupe-warning.conf b/eg/dupe-warning.conf new file mode 100644 index 0000000..9aac61e --- /dev/null +++ b/eg/dupe-warning.conf @@ -0,0 +1,7 @@ +log4perl.category = WARN, Logfile +log4perl.appender.Logfile = Log::Log4perl::Appender::File +log4perl.appender.Logfile.filename = test.log +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.Logfile.layout.ConversionPattern = %d %F{1} %L> %m %n + +log4perl.category = TRACE, Logfile diff --git a/eg/jabber.conf b/eg/jabber.conf new file mode 100644 index 0000000..dd7994d --- /dev/null +++ b/eg/jabber.conf @@ -0,0 +1,14 @@ +#here's an example of using Log::Dispatch::Jabber + +log4j.category.animal.dog = INFO, jabbender + +log4j.appender.jabbender = Log::Dispatch::Jabber +log4j.appender.jabbender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.jabbender.login.hostname = a.jabber.server +log4j.appender.jabbender.login.port = 5222 +log4j.appender.jabbender.login.username = ***** +log4j.appender.jabbender.login.password = ********** +log4j.appender.jabbender.login.resource = logger +log4j.appender.jabbender.to = *****@a.jabber.server +log4j.appender.jabbender.to = ******@another.jabber.server + diff --git a/eg/l4p-tmpl b/eg/l4p-tmpl new file mode 100755 index 0000000..bd0e382 --- /dev/null +++ b/eg/l4p-tmpl @@ -0,0 +1,63 @@ +#!/usr/bin/perl +########################################### +# l4p-tmpl +# 2009, Mike Schilli <m@perlmeister.com> +########################################### +use strict; +use warnings; + +print <<'EOT'; +log4perl.category = WARN, Logfile +log4perl.appender.Logfile = Log::Log4perl::Appender::File +log4perl.appender.Logfile.filename = test.log +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.Logfile.layout.ConversionPattern = %d %F{1} %L> %m %n +EOT + +__END__ + +=head1 NAME + + l4p-tmpl - Print out a Log4perl template configuration + +=head1 SYNOPSIS + + l4p-tmpl >l4p.conf + +=head1 DESCRIPTION + +l4p-tmpl prints out the text of a template Log4perl configuration for +starting a new Log4perl configuration file. + +=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. + diff --git a/eg/log4j-file-append-java.conf b/eg/log4j-file-append-java.conf new file mode 100644 index 0000000..efdd695 --- /dev/null +++ b/eg/log4j-file-append-java.conf @@ -0,0 +1,12 @@ +############################################################ +# A simple root logger with a FileAppender file appender +# in Java (ultimately maps to Log::Dispatch::File). +# Mike Schilli 2002 m@perlmeister.com +############################################################ +log4j.rootLogger=DEBUG, LOGFILE + +log4j.appender.LOGFILE=org.apache.log4j.FileAppender +log4j.appender.LOGFILE.File=example-java.log + +log4j.appender.LOGFILE.layout=org.apache.log4j.PatternLayout +log4j.appender.LOGFILE.layout.ConversionPattern=%F %L %p %t %c - %m%n diff --git a/eg/log4j-file-append-perl.conf b/eg/log4j-file-append-perl.conf new file mode 100644 index 0000000..b587136 --- /dev/null +++ b/eg/log4j-file-append-perl.conf @@ -0,0 +1,13 @@ +############################################################ +# A simple root logger with a Log::Dispatch file appender +# in Perl. +# Mike Schilli 2002 m@perlmeister.com +############################################################ +log4j.rootLogger=DEBUG, LOGFILE + +log4j.appender.LOGFILE=Log::Log4perl::Appender::File +log4j.appender.LOGFILE.filename=example-perl.log +log4j.appender.LOGFILE.mode=append + +log4j.appender.LOGFILE.layout=org.apache.log4j.PatternLayout +log4j.appender.LOGFILE.layout.ConversionPattern=%F{1} %L %p %t %c - %m%n diff --git a/eg/log4j-manual-1.conf b/eg/log4j-manual-1.conf new file mode 100644 index 0000000..4eadd3b --- /dev/null +++ b/eg/log4j-manual-1.conf @@ -0,0 +1,13 @@ +# From the Log4j manual at +# http://jakarta.apache.org/log4j/docs/manual.html +# (Just replaced ConsoleAppender by BufferAppender for testing) + +# Set root logger level to DEBUG and its only appender to A1. +log4j.rootLogger=DEBUG, A1 + +# A1 is set to be a BufferAppender (a ConsoleAppender for testing). +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer + +# A1 uses PatternLayout. +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%-4r [%t] %-5p %c %t - %m%n diff --git a/eg/log4j-manual-2.conf b/eg/log4j-manual-2.conf new file mode 100644 index 0000000..8bab5c0 --- /dev/null +++ b/eg/log4j-manual-2.conf @@ -0,0 +1,13 @@ +# From the Log4j manual at +# http://jakarta.apache.org/log4j/docs/manual.html +# (Just replaced ConsoleAppender by BufferAppender for testing) + +log4j.rootLogger=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout + +# Print the date in ISO 8601 format +log4j.appender.A1.layout.ConversionPattern=%d [%t] %-5p %c - %m%n + +# Print only messages of level WARN or above in the package com.foo. +log4j.logger.com.foo=WARN diff --git a/eg/log4j-manual-3.conf b/eg/log4j-manual-3.conf new file mode 100644 index 0000000..12556d0 --- /dev/null +++ b/eg/log4j-manual-3.conf @@ -0,0 +1,14 @@ +# Derived from the Log4j manual at +# http://jakarta.apache.org/log4j/docs/manual.html + +log4j.rootLogger=DEBUG, stdout, R + +log4j.appender.stdout=Log::Log4perl::Appender::TestBuffer +log4j.appender.stdout.layout=org.apache.log4j.PatternLayout + +# Pattern to output the caller's file name and line number. +log4j.appender.stdout.layout.ConversionPattern=%5p [%t] (%F:%L) - %m%n + +log4j.appender.R=Log::Log4perl::Appender::TestBuffer +log4j.appender.R.layout=org.apache.log4j.PatternLayout +log4j.appender.R.layout.ConversionPattern=%p %t '%c' - %m%n diff --git a/eg/log4j-utf8.conf b/eg/log4j-utf8.conf new file mode 100644 index 0000000..24d8131 --- /dev/null +++ b/eg/log4j-utf8.conf @@ -0,0 +1,5 @@ +# Config file with utf8 characters +log4perl.rootLogger=DEBUG, Ä1 +log4perl.appender.Ä1=Log::Log4perl::Appender::TestBuffer +log4perl.appender.Ä1.layout=PatternLayout +log4perl.appender.Ä1.layout.ConversionPattern=%m%n diff --git a/eg/newsyslog-test b/eg/newsyslog-test new file mode 100755 index 0000000..466c897 --- /dev/null +++ b/eg/newsyslog-test @@ -0,0 +1,30 @@ +#!/usr/local/bin/perl -w +########################################### +# newsyslog-test +# Mike Schilli, 200t (m@perlmeister.com) +########################################### +use strict; +use Log::Log4perl qw(:easy); + +# newsyslog configuration: +# /tmp/test.log 666 12 1 * B /tmp/test.pid 30 + +my $conf = q{ +log4perl.category = DEBUG, Logfile +log4perl.appender.Logfile = Log::Log4perl::Appender::File +log4perl.appender.Logfile.recreate = 1 +log4perl.appender.Logfile.recreate_check_signal = USR1 +log4perl.appender.Logfile.recreate_pid_write = /tmp/test.pid +log4perl.appender.Logfile.mode = append +log4perl.appender.Logfile.filename = /tmp/test.log +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.Logfile.layout.ConversionPattern = %d %F{1} %L> %m%n +}; + +Log::Log4perl->init(\$conf); + +while(1) { + DEBUG "test" x 1000; + system("ls -l /tmp/test.log* | head -2; echo"); + sleep(1); +} diff --git a/eg/override_appender b/eg/override_appender new file mode 100755 index 0000000..7867fc1 --- /dev/null +++ b/eg/override_appender @@ -0,0 +1,73 @@ +#!/usr/bin/perl +###################################################################### +# override_appender -- 2003, Mike Schilli <m@perlmeister.com> +###################################################################### +# Overrided the appender layout after defining it in the conf file. +###################################################################### +use strict; +use warnings; + +my $VERSION = "0.01"; +our $CVSVERSION = '$Revision: 1.1 $'; + +use Log::Log4perl qw(:easy); +Log::Log4perl->init(\ <<'EOT'); + log4perl.category = WARN, Screen + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.Screen.layout.ConversionPattern = %d %F{1} %L> %m %n +EOT + +my $appenders = Log::Log4perl->appenders(); +my $layout = Log::Log4perl::Layout::PatternLayout->new("%m %m%n"); +$appenders->{Screen}->layout($layout); +WARN("test message"); + +__END__ + +=head1 NAME + + override_appender - Try to change an appender's layout + +=head1 SYNOPSIS + + override_appender + +=head1 DESCRIPTION + +Change an appender's layout after it has been defined in the configuration +file. + +=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. + diff --git a/eg/prototype b/eg/prototype new file mode 100755 index 0000000..f0b0bc5 --- /dev/null +++ b/eg/prototype @@ -0,0 +1,34 @@ +#!/usr/bin/perl +########################################### +# prototype -- use a Class::Prototyped appender +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### +use warnings; +use strict; + +use Class::Prototyped; + +my $class = Class::Prototyped->newPackage( + "MyAppenders::Bulletizer", + bullets => 1, + log => sub { + my($self, %params) = @_; + print "*" x $self->bullets(), + $params{message}; + }, +); + +use Log::Log4perl qw(:easy); + +Log::Log4perl->init(\ q{ + log4perl.logger = INFO, Bully + + log4perl.appender.Bully=MyAppenders::Bulletizer + log4perl.appender.Bully.bullets=3 + + log4perl.appender.Bully.layout = PatternLayout + log4perl.appender.Bully.layout.ConversionPattern=%m %n +}); + + # ... prints: "***Boo!\n"; +INFO "Boo!"; diff --git a/eg/syslog.pl b/eg/syslog.pl new file mode 100755 index 0000000..978017b --- /dev/null +++ b/eg/syslog.pl @@ -0,0 +1,86 @@ +#!/usr/bin/perl +########################################### +# Syslog test cases +# Kevin Goess, cpan@goess.org 2002 +########################################### +use warnings; +use strict; + +use Log::Log4perl; +use Test; + +our $RESULT_BUFFER; + +package Log::MyOwnAppender; + +our $IS_LOADED = 1; + +use base qw(Log::Dispatch::Output); + +sub new { + my($proto, %params) = @_; + my $class = ref $proto || $proto; + + my $self = bless {}, $class; + + $self->_basic_init(%params); + + return $self; +} + + +sub log_message { + my $self = shift; + my %params = @_; + + #params is { name => \$appender_name, + # level => 0, + # message => \$message, + + $main::RESULT_BUFFER = $params{level}; +} + + +package main; + + +my $config = <<EOL; +log4j.category.plant = DEBUG, tappndr,syslogappndr + +log4j.appender.tappndr = Log::MyOwnAppender +log4j.appender.tappndr.layout = org.apache.log4j.SimpleLayout + +log4j.appender.syslogappndr = Log::Dispatch::Syslog +log4j.appender.syslogappndr.layout = org.apache.log4j.SimpleLayout + + +EOL + + +Log::Log4perl::init(\$config); + +my $logger = Log::Log4perl::get_logger('plant'); + +$logger->fatal('foo'); +ok($RESULT_BUFFER, 7); +$RESULT_BUFFER = undef; + +$logger->error('foo'); +ok($RESULT_BUFFER, 4); +$RESULT_BUFFER = undef; + +$logger->warn('foo'); +ok($RESULT_BUFFER, 3); +$RESULT_BUFFER = undef; + +$logger->info('foo'); +ok($RESULT_BUFFER, 1); +$RESULT_BUFFER = undef; + +$logger->debug('foo'); +ok($RESULT_BUFFER, 0); +$RESULT_BUFFER = undef; + + + +BEGIN { plan tests => 5, } diff --git a/eg/yamlparser b/eg/yamlparser new file mode 100755 index 0000000..3c0a5d2 --- /dev/null +++ b/eg/yamlparser @@ -0,0 +1,93 @@ +#!/usr/bin/perl +########################################### +# yamlparser +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### +use warnings; +use strict; + +package MyYAMLParser; +use base qw(Log::Log4perl::Config::BaseConfigurator); +use YAML qw(LoadFile Load); +use Data::Dumper; + +########################################### +sub new { +########################################### + my($class, %options) = @_; + + my $self = {}; + + bless $self, $class; + + $self->{text} = $options{text} if exists $options{text}; + $self->{file} = $options{file} if exists $options{file}; + + if(! exists $self->{text} and + ! exists $self->{file}) { + die "usage: ", __PACKAGE__, "->new(file => \$filename) or ", + __PACKAGE__, "->new(text => \$text)"; + } + + return $self; +} + +########################################### +sub parse { +########################################### + my($self) = @_; + + my $data = {}; + + if(exists $self->{text}) { + $self->{data} = Load($self->{text}); + } + + # Move all non-hash values under {...}->{value} + my @todo = ($self->{data}); + + while (@todo) { + my $ref = shift @todo; + for (keys %$ref) { + if(ref($ref->{$_}) eq "HASH") { + push @todo, $ref->{$_}; + } elsif($_ eq "name") { + # Appender 'name' entries are + # converted to ->{value} entries + $ref->{value} = $ref->{$_}; + delete $ref->{$_}; + } else { + my $tmp = $ref->{$_}; + $ref->{$_} = {}; + $ref->{$_}->{value} = $tmp; + } + } + } + + return $self->{data}; +} + +package main; + +use Log::Log4perl; + +my $p = MyYAMLParser->new(text => <<EOT); + category: + Bar: + Twix: WARN, Screen, Screen2 + appender: + Screen: + name: Log::Log4perl::Appender::Screen + layout: Log::Log4perl::Layout::SimpleLayout + Screen2: + name: Log::Log4perl::Appender::Screen + layout: Log::Log4perl::Layout::SimpleLayout +EOT + +# use Data::Dump qw(dump); +# print dump($p->parse()); + +Log::Log4perl->init($p); + +my $log = Log::Log4perl->get_logger("Bar::Twix"); +$log->warn('foo'); diff --git a/ldap/log4perl-2.ldif b/ldap/log4perl-2.ldif new file mode 100644 index 0000000..fb3a92a --- /dev/null +++ b/ldap/log4perl-2.ldif @@ -0,0 +1,70 @@ +# objectclass ( myobjs:3 +# NAME 'log4perlAppender' +# SUP top +# STRUCTURAL +# DESC 'A log4perl Appender' +# MUST ( name $ log4perlClass $ log4perlLayout) +# MAY ( log4perlParam ) +# ) +# +# objectclass ( myobjs:6 +# NAME 'log4perlFileAppender' +# SUP top +# AUXILIARY +# DESC 'appends to a file' +# MUST ( log4perlfilename $ log4perlmode +# $log4perlautoflush) +# +# ) +# +# +# objectclass ( myobjs:7 +# NAME 'log4perlParam' +# SUP top +# AUXILIARY +# DESC 'a name/value tuple' +# MUST ( name $ log4perlvalue ) +# +# ) + + +#Method 1 +#using auxiliary classes +dn: name=FileAppender1,dc=testsystem,dc=log4perl,dc=goess,dc=org +objectclass: log4perlAppender +objectclass: log4perlFileAppender +name:FileAppender1 +log4perlClass:Log::Log4perl::Appender::File +log4perlLayout:name=Layout1,dc=testsystem,dc=log4perl,dc=goess,dc=org +log4perlfilename:/var/log/testfile +log4perlmode:append +log4perlautoflush:1 + +#Method 2 +#using log4perlParam classes +dn: name=OtherFileAppndr, dc=testsystem,dc=log4perl,dc=goess,dc=org +objectclass: log4perlAppender +name:OtherFileAppndr +log4perlClass:Log::Log4perl::Appender::File +log4perlLayout:name=Layout1,dc=testsystem,dc=log4perl,dc=goess,dc=org +log4perlParam:name=filename,name=OtherFileAppndr,dc=testsystem,dc=log4perl,dc=goess,dc=org +log4perlParam:name=mode,name=OtherFileAppndr,dc=testsystem,dc=log4perl,dc=goess,dc=org +log4perlParam:name=autoflush,name=OtherFileAppndr,dc=testsystem,dc=log4perl,dc=goess,dc=org + +dn: name=filename,name=OtherFileAppndr,dc=testsystem,dc=log4perl,dc=goess,dc=org +objectclass: log4perlParam +name:filename +log4perlvalue:/var/log/testfile + +dn: name=mode,name=OtherFileAppndr,dc=testsystem,dc=log4perl,dc=goess,dc=org +objectclass: log4perlParam +name:mode +log4perlvalue:append + +dn: name=autoflush,name=OtherFileAppndr,dc=testsystem,dc=log4perl,dc=goess,dc=org +objectclass: log4perlParam +name:autoflush +log4perlvalue:1 + + + diff --git a/ldap/log4perl-unittest.ldif b/ldap/log4perl-unittest.ldif new file mode 100644 index 0000000..7bd5579 --- /dev/null +++ b/ldap/log4perl-unittest.ldif @@ -0,0 +1,42 @@ +# objectclass ( myobjs:3 +# NAME 'log4perlAppender' +# SUP top +# STRUCTURAL +# DESC 'A log4perl Appender' +# MUST ( name $ log4perlClass $ log4perlLayout) +# MAY ( log4perlParam ) +# ) +# +# objectclass ( myobjs:6 +# NAME 'log4perlFileAppender' +# SUP top +# AUXILIARY +# DESC 'appends to a file' +# MUST ( log4perlfilename $ log4perlmode +# $log4perlautoflush) +# +# ) +# +# +# objectclass ( myobjs:7 +# NAME 'log4perlParam' +# SUP top +# AUXILIARY +# DESC 'a name/value tuple' +# MUST ( name $ log4perlvalue ) +# +# ) + + +dn: name=A1,dc=testsystem,dc=log4perl,dc=goess,dc=org +objectclass: log4perlAppender +name:A1 +log4perlClass: Log::Log4perl::Appender::TestBuffer +log4perlLayoutClass: Log::Log4perl::Layout::SimpleLayout + +dn: name=A2,dc=testsystem,dc=log4perl,dc=goess,dc=org +objectclass: log4perlAppender +name:A2 +log4perlClass: Log::Log4perl::Appender::TestBuffer +log4perlLayoutClass: Log::Log4perl::Layout::SimpleLayout + diff --git a/ldap/testload.ldif b/ldap/testload.ldif new file mode 100644 index 0000000..c57fdf8 --- /dev/null +++ b/ldap/testload.ldif @@ -0,0 +1,139 @@ +#this loads up the equivalent of t/038XML-DOM1.t + +#ldapadd -x -D 'uid=admin,ou=Administrators,ou=TopologyManagement,o=NetscapeRoot' -W -f testload.ldif + + +dn: dc=l4ptest,dc=system,dc=goess,dc=org +dc: l4ptest +objectClass: dcObject + + +#log4j.appender.A1 = Log::Log4perl::Appender::TestBuffer +dn:name=A1,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlAppender +objectclass: log4perlTestBufferAppender +name:A1 +log4perlClass:Log::Log4perl::Appender::TestBuffer +#log4j.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +dn:name=layout,name=A1,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlLayout +name: layout +log4perlLayoutClass:Log::Log4perl::Layout::SimpleLayout + +# +#log4j.appender.A2 = Log::Log4perl::Appender::TestBuffer +dn:name=A2,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlAppender +objectclass: log4perlTestBufferAppender +name:A2 +log4perlClass:Log::Log4perl::Appender::TestBuffer +#log4j.appender.A2.layout = Log::Log4perl::Layout::SimpleLayout +dn:name=layout,name=A2,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlLayout +name: layout +log4perlLayoutClass:Log::Log4perl::Layout::SimpleLayout + + +#log4j.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +#log4j.appender.BUF0.Threshold = ERROR +dn:name=BUF0,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlTestBufferAppender +name:BUF0 +log4perlClass:Log::Log4perl::Appender::TestBuffer +log4perlThreshold:ERROR +#log4j.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +dn:name=layout,name=BUF0,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlLayout +name: layout +log4perlLayoutClass:Log::Log4perl::Layout::SimpleLayout + +dn:name=layout,name=BUF0,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlLayout +name=layout +log4perlLayoutClass:Log::Log4perl::Layout::SimpleLayout + +# +#log4j.appender.FileAppndr1 = org.apache.log4j.FileAppender +#log4j.appender.FileAppndr1.layout = Log::Log4perl::Layout::PatternLayout +#log4j.appender.FileAppndr1.layout.ConversionPattern = %d %4r [%t] %-5p %c %t - %m%n +#log4j.appender.FileAppndr1.File = t/tmp/DOMtest +#log4j.appender.FileAppndr1.Append = false +dn:name=FileAppndr1,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlFileAppender +name:FileAppndr1 +log4perlClass:Log::Log4perl::Appender::FileAppender +log4perlfilename:t/tmp/DOMtest +log4perlmode:append +log4perlautoflush:true +#log4perlumask:0222 DEBUG + +dn:name=layout,name=FileAppndr1,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlPatternLayout +name:layout +log4perlLayoutClass:Log::Log4perl::Layout::PatternLayout +log4perlConversionPattern:%d %4r [%t] %-5p %c %t - %m%n + + + +# +#log4j.category.a.b.c.d = WARN, A1 +dn:log4perlCategoryName=a.b.c.d,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlLogger +log4perlCategoryName:a.b.c.d +log4perlLevel: WARN +log4perlAppenderName: A1 + +#log4j.category.a.b = INFO, A1 +dn:log4perlCategoryName=a.b,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlLogger +log4perlCategoryName:a.b +log4perlLevel: INFO +log4perlAppenderName: A1 + +# +#log4j.category.xa.b.c.d = INFO, A2 +dn:log4perlCategoryName=xa.b.c.d,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlLogger +log4perlCategoryName:xa.b.c.d +log4perlLevel: INFO +log4perlAppenderName: A2 +log4perlAppenderName: BUF0 + + +#log4j.category.xa.b = WARN, A2 +dn:log4perlCategoryName=xa.b,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlLogger +log4perlCategoryName:xa.b +log4perlLevel: WARN +log4perlAppenderName: A2 + +# +#log4j.category.animal = INFO, FileAppndr1 +dn:log4perlCategoryName=animal,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlLogger +log4perlCategoryName:animal +log4perlLevel: INFO +log4perlAppenderName: FileAppndr1 + +#log4j.category.animal.dog = INFO, FileAppndr1,A2 +dn:log4perlCategoryName=animal.dog,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlLogger +log4perlCategoryName:animal.dog +log4perlLevel: INFO +log4perlAppenderName: FileAppndr1 +log4perlAppenderName: A2 + +# +#log4j.category = WARN, FileAppndr1 +dn:log4perlCategoryName=rootLogger,dc=l4ptest,dc=system,dc=goess,dc=org +objectclass: log4perlRootLogger +log4perlCategoryName:rootLogger +log4perlLevel: WARN +log4perlAppenderName: FileAppndr1 + +# +#log4j.threshold = DEBUG +# +#log4j.additivity.a.b.c.d = 0 + + diff --git a/lib/Log/Log4perl.pm b/lib/Log/Log4perl.pm new file mode 100644 index 0000000..6568184 --- /dev/null +++ b/lib/Log/Log4perl.pm @@ -0,0 +1,2956 @@ +################################################## +package Log::Log4perl; +################################################## + +END { local($?); Log::Log4perl::Logger::cleanup(); } + +use 5.006; +use strict; +use warnings; + +use Log::Log4perl::Util; +use Log::Log4perl::Logger; +use Log::Log4perl::Level; +use Log::Log4perl::Config; +use Log::Log4perl::Appender; + +our $VERSION = '1.46'; + + # set this to '1' if you're using a wrapper + # around Log::Log4perl +our $caller_depth = 0; + + #this is a mapping of convenience names to opcode masks used in + #$ALLOWED_CODE_OPS_IN_CONFIG_FILE below +our %ALLOWED_CODE_OPS = ( + 'safe' => [ ':browse' ], + 'restrictive' => [ ':default' ], +); + +our %WRAPPERS_REGISTERED = map { $_ => 1 } qw(Log::Log4perl); + + #set this to the opcodes which are allowed when + #$ALLOW_CODE_IN_CONFIG_FILE is set to a true value + #if undefined, there are no restrictions on code that can be + #excuted +our @ALLOWED_CODE_OPS_IN_CONFIG_FILE; + + #this hash lists things that should be exported into the Safe + #compartment. The keys are the package the symbol should be + #exported from and the values are array references to the names + #of the symbols (including the leading type specifier) +our %VARS_SHARED_WITH_SAFE_COMPARTMENT = ( + main => [ '%ENV' ], +); + + #setting this to a true value will allow Perl code to be executed + #within the config file. It works in conjunction with + #$ALLOWED_CODE_OPS_IN_CONFIG_FILE, which if defined restricts the + #opcodes which can be executed using the 'Safe' module. + #setting this to a false value disables code execution in the + #config file +our $ALLOW_CODE_IN_CONFIG_FILE = 1; + + #arrays in a log message will be joined using this character, + #see Log::Log4perl::Appender::DBI +our $JOIN_MSG_ARRAY_CHAR = ''; + + #version required for XML::DOM, to enable XML Config parsing + #and XML Config unit tests +our $DOM_VERSION_REQUIRED = '1.29'; + +our $CHATTY_DESTROY_METHODS = 0; + +our $LOGDIE_MESSAGE_ON_STDERR = 1; +our $LOGEXIT_CODE = 1; +our %IMPORT_CALLED; + +our $EASY_CLOSURES = {}; + + # to throw refs as exceptions via logcarp/confess, turn this off +our $STRINGIFY_DIE_MESSAGE = 1; + +use constant _INTERNAL_DEBUG => 0; + +################################################## +sub import { +################################################## + my($class) = shift; + + my $caller_pkg = caller(); + + return 1 if $IMPORT_CALLED{$caller_pkg}++; + + my(%tags) = map { $_ => 1 } @_; + + # Lazy man's logger + if(exists $tags{':easy'}) { + $tags{':levels'} = 1; + $tags{':nowarn'} = 1; + $tags{'get_logger'} = 1; + } + + if(exists $tags{':no_extra_logdie_message'}) { + $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR = 0; + delete $tags{':no_extra_logdie_message'}; + } + + if(exists $tags{get_logger}) { + # Export get_logger into the calling module's + no strict qw(refs); + *{"$caller_pkg\::get_logger"} = *get_logger; + + delete $tags{get_logger}; + } + + if(exists $tags{':levels'}) { + # Export log levels ($DEBUG, $INFO etc.) from Log4perl::Level + for my $key (keys %Log::Log4perl::Level::PRIORITY) { + my $name = "$caller_pkg\::$key"; + # Need to split this up in two lines, or CVS will + # mess it up. + my $value = $ + Log::Log4perl::Level::PRIORITY{$key}; + no strict qw(refs); + *{"$name"} = \$value; + } + + delete $tags{':levels'}; + } + + # Lazy man's logger + if(exists $tags{':easy'}) { + delete $tags{':easy'}; + + # Define default logger object in caller's package + my $logger = get_logger("$caller_pkg"); + + # Define DEBUG, INFO, etc. routines in caller's package + for(qw(TRACE DEBUG INFO WARN ERROR FATAL ALWAYS)) { + my $level = $_; + $level = "OFF" if $level eq "ALWAYS"; + my $lclevel = lc($_); + easy_closure_create($caller_pkg, $_, sub { + Log::Log4perl::Logger::init_warn() unless + $Log::Log4perl::Logger::INITIALIZED or + $Log::Log4perl::Logger::NON_INIT_WARNED; + $logger->{$level}->($logger, @_, $level); + }, $logger); + } + + # Define LOGCROAK, LOGCLUCK, etc. routines in caller's package + for(qw(LOGCROAK LOGCLUCK LOGCARP LOGCONFESS)) { + my $method = "Log::Log4perl::Logger::" . lc($_); + + easy_closure_create($caller_pkg, $_, sub { + unshift @_, $logger; + goto &$method; + }, $logger); + } + + # Define LOGDIE, LOGWARN + easy_closure_create($caller_pkg, "LOGDIE", sub { + Log::Log4perl::Logger::init_warn() unless + $Log::Log4perl::Logger::INITIALIZED or + $Log::Log4perl::Logger::NON_INIT_WARNED; + $logger->{FATAL}->($logger, @_, "FATAL"); + $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? + CORE::die(Log::Log4perl::Logger::callerline(join '', @_)) : + exit $Log::Log4perl::LOGEXIT_CODE; + }, $logger); + + easy_closure_create($caller_pkg, "LOGEXIT", sub { + Log::Log4perl::Logger::init_warn() unless + $Log::Log4perl::Logger::INITIALIZED or + $Log::Log4perl::Logger::NON_INIT_WARNED; + $logger->{FATAL}->($logger, @_, "FATAL"); + exit $Log::Log4perl::LOGEXIT_CODE; + }, $logger); + + easy_closure_create($caller_pkg, "LOGWARN", sub { + Log::Log4perl::Logger::init_warn() unless + $Log::Log4perl::Logger::INITIALIZED or + $Log::Log4perl::Logger::NON_INIT_WARNED; + $logger->{WARN}->($logger, @_, "WARN"); + CORE::warn(Log::Log4perl::Logger::callerline(join '', @_)) + if $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR; + }, $logger); + } + + if(exists $tags{':nowarn'}) { + $Log::Log4perl::Logger::NON_INIT_WARNED = 1; + delete $tags{':nowarn'}; + } + + if(exists $tags{':nostrict'}) { + $Log::Log4perl::Logger::NO_STRICT = 1; + delete $tags{':nostrict'}; + } + + if(exists $tags{':resurrect'}) { + my $FILTER_MODULE = "Filter::Util::Call"; + if(! Log::Log4perl::Util::module_available($FILTER_MODULE)) { + die "$FILTER_MODULE required with :resurrect" . + "(install from CPAN)"; + } + eval "require $FILTER_MODULE" or die "Cannot pull in $FILTER_MODULE"; + Filter::Util::Call::filter_add( + sub { + my($status); + s/^\s*###l4p// if + ($status = Filter::Util::Call::filter_read()) > 0; + $status; + }); + delete $tags{':resurrect'}; + } + + if(keys %tags) { + # We received an Option we couldn't understand. + die "Unknown Option(s): @{[keys %tags]}"; + } +} + +################################################## +sub initialized { +################################################## + return $Log::Log4perl::Logger::INITIALIZED; +} + +################################################## +sub new { +################################################## + die "THIS CLASS ISN'T FOR DIRECT USE. " . + "PLEASE CHECK 'perldoc " . __PACKAGE__ . "'."; +} + +################################################## +sub reset { # Mainly for debugging/testing +################################################## + # Delegate this to the logger ... + return Log::Log4perl::Logger->reset(); +} + +################################################## +sub init_once { # Call init only if it hasn't been + # called yet. +################################################## + init(@_) unless $Log::Log4perl::Logger::INITIALIZED; +} + +################################################## +sub init { # Read the config file +################################################## + my($class, @args) = @_; + + #woops, they called ::init instead of ->init, let's be forgiving + if ($class ne __PACKAGE__) { + unshift(@args, $class); + } + + # Delegate this to the config module + return Log::Log4perl::Config->init(@args); +} + +################################################## +sub init_and_watch { +################################################## + my($class, @args) = @_; + + #woops, they called ::init instead of ->init, let's be forgiving + if ($class ne __PACKAGE__) { + unshift(@args, $class); + } + + # Delegate this to the config module + return Log::Log4perl::Config->init_and_watch(@args); +} + + +################################################## +sub easy_init { # Initialize the root logger with a screen appender +################################################## + my($class, @args) = @_; + + # Did somebody call us with Log::Log4perl::easy_init()? + if(ref($class) or $class =~ /^\d+$/) { + unshift @args, $class; + } + + # Reset everything first + Log::Log4perl->reset(); + + my @loggers = (); + + my %default = ( level => $DEBUG, + file => "STDERR", + utf8 => undef, + category => "", + layout => "%d %m%n", + ); + + if(!@args) { + push @loggers, \%default; + } else { + for my $arg (@args) { + if($arg =~ /^\d+$/) { + my %logger = (%default, level => $arg); + push @loggers, \%logger; + } elsif(ref($arg) eq "HASH") { + my %logger = (%default, %$arg); + push @loggers, \%logger; + } + } + } + + for my $logger (@loggers) { + + my $app; + + if($logger->{file} =~ /^stderr$/i) { + $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::Screen", + utf8 => $logger->{utf8}); + } elsif($logger->{file} =~ /^stdout$/i) { + $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::Screen", + stderr => 0, + utf8 => $logger->{utf8}); + } else { + my $binmode; + if($logger->{file} =~ s/^(:.*?)>/>/) { + $binmode = $1; + } + $logger->{file} =~ /^(>)?(>)?/; + my $mode = ($2 ? "append" : "write"); + $logger->{file} =~ s/.*>+\s*//g; + $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::File", + filename => $logger->{file}, + mode => $mode, + utf8 => $logger->{utf8}, + binmode => $binmode, + ); + } + + my $layout = Log::Log4perl::Layout::PatternLayout->new( + $logger->{layout}); + $app->layout($layout); + + my $log = Log::Log4perl->get_logger($logger->{category}); + $log->level($logger->{level}); + $log->add_appender($app); + } + + $Log::Log4perl::Logger::INITIALIZED = 1; +} + +################################################## +sub wrapper_register { +################################################## + my $wrapper = $_[-1]; + + $WRAPPERS_REGISTERED{ $wrapper } = 1; +} + +################################################## +sub get_logger { # Get an instance (shortcut) +################################################## + # get_logger() can be called in the following ways: + # + # (1) Log::Log4perl::get_logger() => () + # (2) Log::Log4perl->get_logger() => ("Log::Log4perl") + # (3) Log::Log4perl::get_logger($cat) => ($cat) + # + # (5) Log::Log4perl->get_logger($cat) => ("Log::Log4perl", $cat) + # (6) L4pSubclass->get_logger($cat) => ("L4pSubclass", $cat) + + # Note that (4) L4pSubclass->get_logger() => ("L4pSubclass") + # is indistinguishable from (3) and therefore can't be allowed. + # Wrapper classes always have to specify the category explicitly. + + my $category; + + if(@_ == 0) { + # 1 + my $level = 0; + do { $category = scalar caller($level++); + } while exists $WRAPPERS_REGISTERED{ $category }; + + } elsif(@_ == 1) { + # 2, 3 + $category = $_[0]; + + my $level = 0; + while(exists $WRAPPERS_REGISTERED{ $category }) { + $category = scalar caller($level++); + } + + } else { + # 5, 6 + $category = $_[1]; + } + + # Delegate this to the logger module + return Log::Log4perl::Logger->get_logger($category); +} + +########################################### +sub caller_depth_offset { +########################################### + my( $level ) = @_; + + my $category; + + { + my $category = scalar caller($level + 1); + + if(defined $category and + exists $WRAPPERS_REGISTERED{ $category }) { + $level++; + redo; + } + } + + return $level; +} + +################################################## +sub appenders { # Get a hashref of all defined appender wrappers +################################################## + return \%Log::Log4perl::Logger::APPENDER_BY_NAME; +} + +################################################## +sub add_appender { # Add an appender to the system, but don't assign + # it to a logger yet +################################################## + my($class, $appender) = @_; + + my $name = $appender->name(); + die "Mandatory parameter 'name' missing in appender" unless defined $name; + + # Make it known by name in the Log4perl universe + # (so that composite appenders can find it) + Log::Log4perl->appenders()->{ $name } = $appender; +} + +################################################## +# Return number of appenders changed +sub appender_thresholds_adjust { # Readjust appender thresholds +################################################## + # If someone calls L4p-> and not L4p:: + shift if $_[0] eq __PACKAGE__; + my($delta, $appenders) = @_; + my $retval = 0; + + if($delta == 0) { + # Nothing to do, no delta given. + return; + } + + if(defined $appenders) { + # Map names to objects + $appenders = [map { + die "Unkown appender: '$_'" unless exists + $Log::Log4perl::Logger::APPENDER_BY_NAME{ + $_}; + $Log::Log4perl::Logger::APPENDER_BY_NAME{ + $_} + } @$appenders]; + } else { + # Just hand over all known appenders + $appenders = [values %{Log::Log4perl::appenders()}] unless + defined $appenders; + } + + # Change all appender thresholds; + foreach my $app (@$appenders) { + my $old_thres = $app->threshold(); + my $new_thres; + if($delta > 0) { + $new_thres = Log::Log4perl::Level::get_higher_level( + $old_thres, $delta); + } else { + $new_thres = Log::Log4perl::Level::get_lower_level( + $old_thres, -$delta); + } + + ++$retval if ($app->threshold($new_thres) == $new_thres); + } + return $retval; +} + +################################################## +sub appender_by_name { # Get a (real) appender by name +################################################## + # If someone calls L4p->appender_by_name and not L4p::appender_by_name + shift if $_[0] eq __PACKAGE__; + + my($name) = @_; + + if(defined $name and + exists $Log::Log4perl::Logger::APPENDER_BY_NAME{ + $name}) { + return $Log::Log4perl::Logger::APPENDER_BY_NAME{ + $name}->{appender}; + } else { + return undef; + } +} + +################################################## +sub eradicate_appender { # Remove an appender from the system +################################################## + # If someone calls L4p->... and not L4p::... + shift if $_[0] eq __PACKAGE__; + Log::Log4perl::Logger->eradicate_appender(@_); +} + +################################################## +sub infiltrate_lwp { # +################################################## + no warnings qw(redefine); + + my $l4p_wrapper = sub { + my($prio, @message) = @_; + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 2; + get_logger(scalar caller(1))->log($prio, @message); + }; + + *LWP::Debug::trace = sub { + $l4p_wrapper->($INFO, @_); + }; + *LWP::Debug::conns = + *LWP::Debug::debug = sub { + $l4p_wrapper->($DEBUG, @_); + }; +} + +################################################## +sub easy_closure_create { +################################################## + my($caller_pkg, $entry, $code, $logger) = @_; + + no strict 'refs'; + + print("easy_closure: Setting shortcut $caller_pkg\::$entry ", + "(logger=$logger\n") if _INTERNAL_DEBUG; + + $EASY_CLOSURES->{ $caller_pkg }->{ $entry } = $logger; + *{"$caller_pkg\::$entry"} = $code; +} + +########################################### +sub easy_closure_cleanup { +########################################### + my($caller_pkg, $entry) = @_; + + no warnings 'redefine'; + no strict 'refs'; + + my $logger = $EASY_CLOSURES->{ $caller_pkg }->{ $entry }; + + print("easy_closure: Nuking easy shortcut $caller_pkg\::$entry ", + "(logger=$logger\n") if _INTERNAL_DEBUG; + + *{"$caller_pkg\::$entry"} = sub { }; + delete $EASY_CLOSURES->{ $caller_pkg }->{ $entry }; +} + +################################################## +sub easy_closure_category_cleanup { +################################################## + my($caller_pkg) = @_; + + if(! exists $EASY_CLOSURES->{ $caller_pkg } ) { + return 1; + } + + for my $entry ( keys %{ $EASY_CLOSURES->{ $caller_pkg } } ) { + easy_closure_cleanup( $caller_pkg, $entry ); + } + + delete $EASY_CLOSURES->{ $caller_pkg }; +} + +########################################### +sub easy_closure_global_cleanup { +########################################### + + for my $caller_pkg ( keys %$EASY_CLOSURES ) { + easy_closure_category_cleanup( $caller_pkg ); + } +} + +########################################### +sub easy_closure_logger_remove { +########################################### + my($class, $logger) = @_; + + PKG: for my $caller_pkg ( keys %$EASY_CLOSURES ) { + for my $entry ( keys %{ $EASY_CLOSURES->{ $caller_pkg } } ) { + if( $logger == $EASY_CLOSURES->{ $caller_pkg }->{ $entry } ) { + easy_closure_category_cleanup( $caller_pkg ); + next PKG; + } + } + } +} + +################################################## +sub remove_logger { +################################################## + my ($class, $logger) = @_; + + # Any stealth logger convenience function still using it will + # now become a no-op. + Log::Log4perl->easy_closure_logger_remove( $logger ); + + # Remove the logger from the system + delete $Log::Log4perl::Logger::LOGGERS_BY_NAME->{ $logger->{category} }; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl - Log4j implementation for Perl + +=head1 SYNOPSIS + # Easy mode if you like it simple ... + + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init($ERROR); + + DEBUG "This doesn't go anywhere"; + ERROR "This gets logged"; + + # ... or standard mode for more features: + + Log::Log4perl::init('/etc/log4perl.conf'); + + --or-- + + # Check config every 10 secs + Log::Log4perl::init_and_watch('/etc/log4perl.conf',10); + + --then-- + + $logger = Log::Log4perl->get_logger('house.bedrm.desk.topdrwr'); + + $logger->debug('this is a debug message'); + $logger->info('this is an info message'); + $logger->warn('etc'); + $logger->error('..'); + $logger->fatal('..'); + + #####/etc/log4perl.conf############################### + log4perl.logger.house = WARN, FileAppndr1 + log4perl.logger.house.bedroom.desk = DEBUG, FileAppndr1 + + log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File + log4perl.appender.FileAppndr1.filename = desk.log + log4perl.appender.FileAppndr1.layout = \ + Log::Log4perl::Layout::SimpleLayout + ###################################################### + +=head1 ABSTRACT + +Log::Log4perl provides a powerful logging API for your application + +=head1 DESCRIPTION + +Log::Log4perl lets you remote-control and fine-tune the logging behaviour +of your system from the outside. It implements the widely popular +(Java-based) Log4j logging package in pure Perl. + +B<For a detailed tutorial on Log::Log4perl usage, please read> + +L<http://www.perl.com/pub/a/2002/09/11/log4perl.html> + +Logging beats a debugger if you want to know what's going on +in your code during runtime. However, traditional logging packages +are too static and generate a flood of log messages in your log files +that won't help you. + +C<Log::Log4perl> is different. It allows you to control the number of +logging messages generated at three different levels: + +=over 4 + +=item * + +At a central location in your system (either in a configuration file or +in the startup code) you specify I<which components> (classes, functions) +of your system should generate logs. + +=item * + +You specify how detailed the logging of these components should be by +specifying logging I<levels>. + +=item * + +You also specify which so-called I<appenders> you want to feed your +log messages to ("Print it to the screen and also append it to /tmp/my.log") +and which format ("Write the date first, then the file name and line +number, and then the log message") they should be in. + +=back + +This is a very powerful and flexible mechanism. You can turn on and off +your logs at any time, specify the level of detail and make that +dependent on the subsystem that's currently executed. + +Let me give you an example: You might +find out that your system has a problem in the +C<MySystem::Helpers::ScanDir> +component. Turning on detailed debugging logs all over the system would +generate a flood of useless log messages and bog your system down beyond +recognition. With C<Log::Log4perl>, however, you can tell the system: +"Continue to log only severe errors to the log file. Open a second +log file, turn on full debug logs in the C<MySystem::Helpers::ScanDir> +component and dump all messages originating from there into the new +log file". And all this is possible by just changing the parameters +in a configuration file, which your system can re-read even +while it's running! + +=head1 How to use it + +The C<Log::Log4perl> package can be initialized in two ways: Either +via Perl commands or via a C<log4j>-style configuration file. + +=head2 Initialize via a configuration file + +This is the easiest way to prepare your system for using +C<Log::Log4perl>. Use a configuration file like this: + + ############################################################ + # A simple root logger with a Log::Log4perl::Appender::File + # file appender in Perl. + ############################################################ + log4perl.rootLogger=ERROR, LOGFILE + + log4perl.appender.LOGFILE=Log::Log4perl::Appender::File + log4perl.appender.LOGFILE.filename=/var/log/myerrs.log + log4perl.appender.LOGFILE.mode=append + + log4perl.appender.LOGFILE.layout=PatternLayout + log4perl.appender.LOGFILE.layout.ConversionPattern=[%r] %F %L %c - %m%n + +These lines define your standard logger that's appending severe +errors to C</var/log/myerrs.log>, using the format + + [millisecs] source-filename line-number class - message newline + +Assuming that this configuration file is saved as C<log.conf>, you need to +read it in the startup section of your code, using the following +commands: + + use Log::Log4perl; + Log::Log4perl->init("log.conf"); + +After that's done I<somewhere> in the code, you can retrieve +logger objects I<anywhere> in the code. Note that +there's no need to carry any logger references around with your +functions and methods. You can get a logger anytime via a singleton +mechanism: + + package My::MegaPackage; + use Log::Log4perl; + + sub some_method { + my($param) = @_; + + my $log = Log::Log4perl->get_logger("My::MegaPackage"); + + $log->debug("Debug message"); + $log->info("Info message"); + $log->error("Error message"); + + ... + } + +With the configuration file above, C<Log::Log4perl> will write +"Error message" to the specified log file, but won't do anything for +the C<debug()> and C<info()> calls, because the log level has been set +to C<ERROR> for all components in the first line of +configuration file shown above. + +Why C<Log::Log4perl-E<gt>get_logger> and +not C<Log::Log4perl-E<gt>new>? We don't want to create a new +object every time. Usually in OO-Programming, you create an object +once and use the reference to it to call its methods. However, +this requires that you pass around the object to all functions +and the last thing we want is pollute each and every function/method +we're using with a handle to the C<Logger>: + + sub function { # Brrrr!! + my($logger, $some, $other, $parameters) = @_; + } + +Instead, if a function/method wants a reference to the logger, it +just calls the Logger's static C<get_logger($category)> method to obtain +a reference to the I<one and only> possible logger object of +a certain category. +That's called a I<singleton> if you're a Gamma fan. + +How does the logger know +which messages it is supposed to log and which ones to suppress? +C<Log::Log4perl> works with inheritance: The config file above didn't +specify anything about C<My::MegaPackage>. +And yet, we've defined a logger of the category +C<My::MegaPackage>. +In this case, C<Log::Log4perl> will walk up the namespace hierarchy +(C<My> and then we're at the root) to figure out if a log level is +defined somewhere. In the case above, the log level at the root +(root I<always> defines a log level, but not necessarily an appender) +defines that +the log level is supposed to be C<ERROR> -- meaning that I<DEBUG> +and I<INFO> messages are suppressed. Note that this 'inheritance' is +unrelated to Perl's class inheritance, it is merely related to the +logger namespace. +By the way, if you're ever in doubt about what a logger's category is, +use C<$logger-E<gt>category()> to retrieve it. + +=head2 Log Levels + +There are six predefined log levels: C<FATAL>, C<ERROR>, C<WARN>, C<INFO>, +C<DEBUG>, and C<TRACE> (in descending priority). Your configured logging level +has to at least match the priority of the logging message. + +If your configured logging level is C<WARN>, then messages logged +with C<info()>, C<debug()>, and C<trace()> will be suppressed. +C<fatal()>, C<error()> and C<warn()> will make their way through, +because their priority is higher or equal than the configured setting. + +Instead of calling the methods + + $logger->trace("..."); # Log a trace message + $logger->debug("..."); # Log a debug message + $logger->info("..."); # Log a info message + $logger->warn("..."); # Log a warn message + $logger->error("..."); # Log a error message + $logger->fatal("..."); # Log a fatal message + +you could also call the C<log()> method with the appropriate level +using the constants defined in C<Log::Log4perl::Level>: + + use Log::Log4perl::Level; + + $logger->log($TRACE, "..."); + $logger->log($DEBUG, "..."); + $logger->log($INFO, "..."); + $logger->log($WARN, "..."); + $logger->log($ERROR, "..."); + $logger->log($FATAL, "..."); + +This form is rarely used, but it comes in handy if you want to log +at different levels depending on an exit code of a function: + + $logger->log( $exit_level{ $rc }, "..."); + +As for needing more logging levels than these predefined ones: It's +usually best to steer your logging behaviour via the category +mechanism instead. + +If you need to find out if the currently configured logging +level would allow a logger's logging statement to go through, use the +logger's C<is_I<level>()> methods: + + $logger->is_trace() # True if trace messages would go through + $logger->is_debug() # True if debug messages would go through + $logger->is_info() # True if info messages would go through + $logger->is_warn() # True if warn messages would go through + $logger->is_error() # True if error messages would go through + $logger->is_fatal() # True if fatal messages would go through + +Example: C<$logger-E<gt>is_warn()> returns true if the logger's current +level, as derived from either the logger's category (or, in absence of +that, one of the logger's parent's level setting) is +C<$WARN>, C<$ERROR> or C<$FATAL>. + +Also available are a series of more Java-esque functions which return +the same values. These are of the format C<isI<Level>Enabled()>, +so C<$logger-E<gt>isDebugEnabled()> is synonymous to +C<$logger-E<gt>is_debug()>. + + +These level checking functions +will come in handy later, when we want to block unnecessary +expensive parameter construction in case the logging level is too +low to log the statement anyway, like in: + + if($logger->is_error()) { + $logger->error("Erroneous array: @super_long_array"); + } + +If we had just written + + $logger->error("Erroneous array: @super_long_array"); + +then Perl would have interpolated +C<@super_long_array> into the string via an expensive operation +only to figure out shortly after that the string can be ignored +entirely because the configured logging level is lower than C<$ERROR>. + +The to-be-logged +message passed to all of the functions described above can +consist of an arbitrary number of arguments, which the logging functions +just chain together to a single string. Therefore + + $logger->debug("Hello ", "World", "!"); # and + $logger->debug("Hello World!"); + +are identical. + +Note that even if one of the methods above returns true, it doesn't +necessarily mean that the message will actually get logged. +What is_debug() checks is that +the logger used is configured to let a message of the given priority +(DEBUG) through. But after this check, Log4perl will eventually apply custom +filters and forward the message to one or more appenders. None of this +gets checked by is_xxx(), for the simple reason that it's +impossible to know what a custom filter does with a message without +having the actual message or what an appender does to a message without +actually having it log it. + +=head2 Log and die or warn + +Often, when you croak / carp / warn / die, you want to log those messages. +Rather than doing the following: + + $logger->fatal($err) && die($err); + +you can use the following: + + $logger->logdie($err); + +And if instead of using + + warn($message); + $logger->warn($message); + +to both issue a warning via Perl's warn() mechanism and make sure you have +the same message in the log file as well, use: + + $logger->logwarn($message); + +Since there is +an ERROR level between WARN and FATAL, there are two additional helper +functions in case you'd like to use ERROR for either warn() or die(): + + $logger->error_warn(); + $logger->error_die(); + +Finally, there's the Carp functions that, in addition to logging, +also pass the stringified message to their companions in the Carp package: + + $logger->logcarp(); # warn w/ 1-level stack trace + $logger->logcluck(); # warn w/ full stack trace + $logger->logcroak(); # die w/ 1-level stack trace + $logger->logconfess(); # die w/ full stack trace + +=head2 Appenders + +If you don't define any appenders, nothing will happen. Appenders will +be triggered whenever the configured logging level requires a message +to be logged and not suppressed. + +C<Log::Log4perl> doesn't define any appenders by default, not even the root +logger has one. + +C<Log::Log4perl> already comes with a standard set of appenders: + + Log::Log4perl::Appender::Screen + Log::Log4perl::Appender::ScreenColoredLevels + Log::Log4perl::Appender::File + Log::Log4perl::Appender::Socket + Log::Log4perl::Appender::DBI + Log::Log4perl::Appender::Synchronized + Log::Log4perl::Appender::RRDs + +to log to the screen, to files and to databases. + +On CPAN, you can find additional appenders like + + Log::Log4perl::Layout::XMLLayout + +by Guido Carls E<lt>gcarls@cpan.orgE<gt>. +It allows for hooking up Log::Log4perl with the graphical Log Analyzer +Chainsaw (see +L<Log::Log4perl::FAQ/"Can I use Log::Log4perl with log4j's Chainsaw?">). + +=head2 Additional Appenders via Log::Dispatch + +C<Log::Log4perl> also supports I<Dave Rolskys> excellent C<Log::Dispatch> +framework which implements a wide variety of different appenders. + +Here's the list of appender modules currently available via C<Log::Dispatch>: + + Log::Dispatch::ApacheLog + Log::Dispatch::DBI (by Tatsuhiko Miyagawa) + Log::Dispatch::Email, + Log::Dispatch::Email::MailSend, + Log::Dispatch::Email::MailSendmail, + Log::Dispatch::Email::MIMELite + Log::Dispatch::File + Log::Dispatch::FileRotate (by Mark Pfeiffer) + Log::Dispatch::Handle + Log::Dispatch::Screen + Log::Dispatch::Syslog + Log::Dispatch::Tk (by Dominique Dumont) + +Please note that in order to use any of these additional appenders, you +have to fetch Log::Dispatch from CPAN and install it. Also the particular +appender you're using might require installing the particular module. + +For additional information on appenders, please check the +L<Log::Log4perl::Appender> manual page. + +=head2 Appender Example + +Now let's assume that we want to log C<info()> or +higher prioritized messages in the C<Foo::Bar> category +to both STDOUT and to a log file, say C<test.log>. +In the initialization section of your system, +just define two appenders using the readily available +C<Log::Log4perl::Appender::File> and C<Log::Log4perl::Appender::Screen> +modules: + + use Log::Log4perl; + + # Configuration in a string ... + my $conf = q( + log4perl.category.Foo.Bar = INFO, Logfile, Screen + + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Logfile.layout.ConversionPattern = [%r] %F %L %m%n + + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.stderr = 0 + log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout + ); + + # ... passed as a reference to init() + Log::Log4perl::init( \$conf ); + +Once the initialization shown above has happened once, typically in +the startup code of your system, just use the defined logger anywhere in +your system: + + ########################## + # ... in some function ... + ########################## + my $log = Log::Log4perl::get_logger("Foo::Bar"); + + # Logs both to STDOUT and to the file test.log + $log->info("Important Info!"); + +The C<layout> settings specified in the configuration section define the +format in which the +message is going to be logged by the specified appender. The format shown +for the file appender is logging not only the message but also the number of +milliseconds since the program has started (%r), the name of the file +the call to the logger has happened and the line number there (%F and +%L), the message itself (%m) and a OS-specific newline character (%n): + + [187] ./myscript.pl 27 Important Info! + +The +screen appender above, on the other hand, +uses a C<SimpleLayout>, which logs the +debug level, a hyphen (-) and the log message: + + INFO - Important Info! + +For more detailed info on layout formats, see L<Log Layouts>. + +In the configuration sample above, we chose to define a I<category> +logger (C<Foo::Bar>). +This will cause only messages originating from +this specific category logger to be logged in the defined format +and locations. + +=head2 Logging newlines + +There's some controversy between different logging systems as to when and +where newlines are supposed to be added to logged messages. + +The Log4perl way is that a logging statement I<should not> +contain a newline: + + $logger->info("Some message"); + $logger->info("Another message"); + +If this is supposed to end up in a log file like + + Some message + Another message + +then an appropriate appender layout like "%m%n" will take care of adding +a newline at the end of each message to make sure every message is +printed on its own line. + +Other logging systems, Log::Dispatch in particular, recommend adding the +newline to the log statement. This doesn't work well, however, if you, say, +replace your file appender by a database appender, and all of a sudden +those newlines scattered around the code don't make sense anymore. + +Assigning matching layouts to different appenders and leaving newlines +out of the code solves this problem. If you inherited code that has logging +statements with newlines and want to make it work with Log4perl, read +the L<Log::Log4perl::Layout::PatternLayout> documentation on how to +accomplish that. + +=head2 Configuration files + +As shown above, you can define C<Log::Log4perl> loggers both from within +your Perl code or from configuration files. The latter have the unbeatable +advantage that you can modify your system's logging behaviour without +interfering with the code at all. So even if your code is being run by +somebody who's totally oblivious to Perl, they still can adapt the +module's logging behaviour to their needs. + +C<Log::Log4perl> has been designed to understand C<Log4j> configuration +files -- as used by the original Java implementation. Instead of +reiterating the format description in [2], let me just list three +examples (also derived from [2]), which should also illustrate +how it works: + + log4j.rootLogger=DEBUG, A1 + log4j.appender.A1=org.apache.log4j.ConsoleAppender + log4j.appender.A1.layout=org.apache.log4j.PatternLayout + log4j.appender.A1.layout.ConversionPattern=%-4r %-5p %c %x - %m%n + +This enables messages of priority C<DEBUG> or higher in the root +hierarchy and has the system write them to the console. +C<ConsoleAppender> is a Java appender, but C<Log::Log4perl> jumps +through a significant number of hoops internally to map these to their +corresponding Perl classes, C<Log::Log4perl::Appender::Screen> in this case. + +Second example: + + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::Screen + log4perl.appender.A1.layout=PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%d %-5p %c - %m%n + log4perl.logger.com.foo=WARN + +This defines two loggers: The root logger and the C<com.foo> logger. +The root logger is easily triggered by debug-messages, +but the C<com.foo> logger makes sure that messages issued within +the C<Com::Foo> component and below are only forwarded to the appender +if they're of priority I<warning> or higher. + +Note that the C<com.foo> logger doesn't define an appender. Therefore, +it will just propagate the message up the hierarchy until the root logger +picks it up and forwards it to the one and only appender of the root +category, using the format defined for it. + +Third example: + + log4j.rootLogger=DEBUG, stdout, R + log4j.appender.stdout=org.apache.log4j.ConsoleAppender + log4j.appender.stdout.layout=org.apache.log4j.PatternLayout + log4j.appender.stdout.layout.ConversionPattern=%5p (%F:%L) - %m%n + log4j.appender.R=org.apache.log4j.RollingFileAppender + log4j.appender.R.File=example.log + log4j.appender.R.layout=org.apache.log4j.PatternLayout + log4j.appender.R.layout.ConversionPattern=%p %c - %m%n + +The root logger defines two appenders here: C<stdout>, which uses +C<org.apache.log4j.ConsoleAppender> (ultimately mapped by C<Log::Log4perl> +to L<Log::Log4perl::Appender::Screen>) to write to the screen. And +C<R>, a C<org.apache.log4j.RollingFileAppender> +(mapped by C<Log::Log4perl> to +L<Log::Dispatch::FileRotate> with the C<File> attribute specifying the +log file. + +See L<Log::Log4perl::Config> for more examples and syntax explanations. + +=head2 Log Layouts + +If the logging engine passes a message to an appender, because it thinks +it should be logged, the appender doesn't just +write it out haphazardly. There's ways to tell the appender how to format +the message and add all sorts of interesting data to it: The date and +time when the event happened, the file, the line number, the +debug level of the logger and others. + +There's currently two layouts defined in C<Log::Log4perl>: +C<Log::Log4perl::Layout::SimpleLayout> and +C<Log::Log4perl::Layout::PatternLayout>: + +=over 4 + +=item C<Log::Log4perl::SimpleLayout> + +formats a message in a simple +way and just prepends it by the debug level and a hyphen: +C<"$level - $message>, for example C<"FATAL - Can't open password file">. + +=item C<Log::Log4perl::Layout::PatternLayout> + +on the other hand is very powerful and +allows for a very flexible format in C<printf>-style. The format +string can contain a number of placeholders which will be +replaced by the logging engine when it's time to log the message: + + %c Category of the logging event. + %C Fully qualified package (or class) name of the caller + %d Current date in yyyy/MM/dd hh:mm:ss format + %F File where the logging event occurred + %H Hostname (if Sys::Hostname is available) + %l Fully qualified name of the calling method followed by the + callers source the file name and line number between + parentheses. + %L Line number within the file where the log statement was issued + %m The message to be logged + %m{chomp} The message to be logged, stripped off a trailing newline + %M Method or function where the logging request was issued + %n Newline (OS-independent) + %p Priority of the logging event + %P pid of the current process + %r Number of milliseconds elapsed from program start to logging + event + %R Number of milliseconds elapsed from last logging event to + current logging event + %T A stack trace of functions called + %x The topmost NDC (see below) + %X{key} The entry 'key' of the MDC (see below) + %% A literal percent (%) sign + +NDC and MDC are explained in L<"Nested Diagnostic Context (NDC)"> +and L<"Mapped Diagnostic Context (MDC)">. + +Also, C<%d> can be fine-tuned to display only certain characteristics +of a date, according to the SimpleDateFormat in the Java World +(L<http://java.sun.com/j2se/1.3/docs/api/java/text/SimpleDateFormat.html>) + +In this way, C<%d{HH:mm}> displays only hours and minutes of the current date, +while C<%d{yy, EEEE}> displays a two-digit year, followed by a spelled-out +(like C<Wednesday>). + +Similar options are available for shrinking the displayed category or +limit file/path components, C<%F{1}> only displays the source file I<name> +without any path components while C<%F> logs the full path. %c{2} only +logs the last two components of the current category, C<Foo::Bar::Baz> +becomes C<Bar::Baz> and saves space. + +If those placeholders aren't enough, then you can define your own right in +the config file like this: + + log4perl.PatternLayout.cspec.U = sub { return "UID $<" } + +See L<Log::Log4perl::Layout::PatternLayout> for further details on +customized specifiers. + +Please note that the subroutines you're defining in this way are going +to be run in the C<main> namespace, so be sure to fully qualify functions +and variables if they're located in different packages. + +SECURITY NOTE: this feature means arbitrary perl code can be embedded in the +config file. In the rare case where the people who have access to your config +file are different from the people who write your code and shouldn't have +execute rights, you might want to call + + Log::Log4perl::Config->allow_code(0); + +before you call init(). Alternatively you can supply a restricted set of +Perl opcodes that can be embedded in the config file as described in +L<"Restricting what Opcodes can be in a Perl Hook">. + +=back + +All placeholders are quantifiable, just like in I<printf>. Following this +tradition, C<%-20c> will reserve 20 chars for the category and left-justify it. + +For more details on logging and how to use the flexible and the simple +format, check out the original C<log4j> website under + +L<SimpleLayout|http://logging.apache.org/log4j/1.2/apidocs/org/apache/log4j/SimpleLayout.html> +and +L<PatternLayout|http://logging.apache.org/log4j/1.2/apidocs/org/apache/log4j/PatternLayout.html> + +=head2 Penalties + +Logging comes with a price tag. C<Log::Log4perl> has been optimized +to allow for maximum performance, both with logging enabled and disabled. + +But you need to be aware that there's a small hit every time your code +encounters a log statement -- no matter if logging is enabled or not. +C<Log::Log4perl> has been designed to keep this so low that it will +be unnoticeable to most applications. + +Here's a couple of tricks which help C<Log::Log4perl> to avoid +unnecessary delays: + +You can save serious time if you're logging something like + + # Expensive in non-debug mode! + for (@super_long_array) { + $logger->debug("Element: $_"); + } + +and C<@super_long_array> is fairly big, so looping through it is pretty +expensive. Only you, the programmer, knows that going through that C<for> +loop can be skipped entirely if the current logging level for the +actual component is higher than C<debug>. +In this case, use this instead: + + # Cheap in non-debug mode! + if($logger->is_debug()) { + for (@super_long_array) { + $logger->debug("Element: $_"); + } + } + +If you're afraid that generating the parameters to the +logging function is fairly expensive, use closures: + + # Passed as subroutine ref + use Data::Dumper; + $logger->debug(sub { Dumper($data) } ); + +This won't unravel C<$data> via Dumper() unless it's actually needed +because it's logged. + +Also, Log::Log4perl lets you specify arguments +to logger functions in I<message output filter syntax>: + + $logger->debug("Structure: ", + { filter => \&Dumper, + value => $someref }); + +In this way, shortly before Log::Log4perl sending the +message out to any appenders, it will be searching all arguments for +hash references and treat them in a special way: + +It will invoke the function given as a reference with the C<filter> key +(C<Data::Dumper::Dumper()>) and pass it the value that came with +the key named C<value> as an argument. +The anonymous hash in the call above will be replaced by the return +value of the filter function. + +=head1 Categories + +B<Categories are also called "Loggers" in Log4perl, both refer +to the same thing and these terms are used interchangeably.> +C<Log::Log4perl> uses I<categories> to determine if a log statement in +a component should be executed or suppressed at the current logging level. +Most of the time, these categories are just the classes the log statements +are located in: + + package Candy::Twix; + + sub new { + my $logger = Log::Log4perl->get_logger("Candy::Twix"); + $logger->debug("Creating a new Twix bar"); + bless {}, shift; + } + + # ... + + package Candy::Snickers; + + sub new { + my $logger = Log::Log4perl->get_logger("Candy.Snickers"); + $logger->debug("Creating a new Snickers bar"); + bless {}, shift; + } + + # ... + + package main; + Log::Log4perl->init("mylogdefs.conf"); + + # => "LOG> Creating a new Snickers bar" + my $first = Candy::Snickers->new(); + # => "LOG> Creating a new Twix bar" + my $second = Candy::Twix->new(); + +Note that you can separate your category hierarchy levels +using either dots like +in Java (.) or double-colons (::) like in Perl. Both notations +are equivalent and are handled the same way internally. + +However, categories are just there to make +use of inheritance: if you invoke a logger in a sub-category, +it will bubble up the hierarchy and call the appropriate appenders. +Internally, categories are not related to the class hierarchy of the program +at all -- they're purely virtual. You can use arbitrary categories -- +for example in the following program, which isn't oo-style, but +procedural: + + sub print_portfolio { + + my $log = Log::Log4perl->get_logger("user.portfolio"); + $log->debug("Quotes requested: @_"); + + for(@_) { + print "$_: ", get_quote($_), "\n"; + } + } + + sub get_quote { + + my $log = Log::Log4perl->get_logger("internet.quotesystem"); + $log->debug("Fetching quote: $_[0]"); + + return yahoo_quote($_[0]); + } + +The logger in first function, C<print_portfolio>, is assigned the +(virtual) C<user.portfolio> category. Depending on the C<Log4perl> +configuration, this will either call a C<user.portfolio> appender, +a C<user> appender, or an appender assigned to root -- without +C<user.portfolio> having any relevance to the class system used in +the program. +The logger in the second function adheres to the +C<internet.quotesystem> category -- again, maybe because it's bundled +with other Internet functions, but not because there would be +a class of this name somewhere. + +However, be careful, don't go overboard: if you're developing a system +in object-oriented style, using the class hierarchy is usually your best +choice. Think about the people taking over your code one day: The +class hierarchy is probably what they know right up front, so it's easy +for them to tune the logging to their needs. + +=head2 Turn off a component + +C<Log4perl> doesn't only allow you to selectively switch I<on> a category +of log messages, you can also use the mechanism to selectively I<disable> +logging in certain components whereas logging is kept turned on in higher-level +categories. This mechanism comes in handy if you find that while bumping +up the logging level of a high-level (i. e. close to root) category, +that one component logs more than it should, + +Here's how it works: + + ############################################################ + # Turn off logging in a lower-level category while keeping + # it active in higher-level categories. + ############################################################ + log4perl.rootLogger=DEBUG, LOGFILE + log4perl.logger.deep.down.the.hierarchy = ERROR, LOGFILE + + # ... Define appenders ... + +This way, log messages issued from within +C<Deep::Down::The::Hierarchy> and below will be +logged only if they're C<ERROR> or worse, while in all other system components +even C<DEBUG> messages will be logged. + +=head2 Return Values + +All logging methods return values indicating if their message +actually reached one or more appenders. If the message has been +suppressed because of level constraints, C<undef> is returned. + +For example, + + my $ret = $logger->info("Message"); + +will return C<undef> if the system debug level for the current category +is not C<INFO> or more permissive. +If Log::Log4perl +forwarded the message to one or more appenders, the number of appenders +is returned. + +If appenders decide to veto on the message with an appender threshold, +the log method's return value will have them excluded. This means that if +you've got one appender holding an appender threshold and you're +logging a message +which passes the system's log level hurdle but not the appender threshold, +C<0> will be returned by the log function. + +The bottom line is: Logging functions will return a I<true> value if the message +made it through to one or more appenders and a I<false> value if it didn't. +This allows for constructs like + + $logger->fatal("@_") or print STDERR "@_\n"; + +which will ensure that the fatal message isn't lost +if the current level is lower than FATAL or printed twice if +the level is acceptable but an appender already points to STDERR. + +=head2 Pitfalls with Categories + +Be careful with just blindly reusing the system's packages as +categories. If you do, you'll get into trouble with inherited methods. +Imagine the following class setup: + + use Log::Log4perl; + + ########################################### + package Bar; + ########################################### + sub new { + my($class) = @_; + my $logger = Log::Log4perl::get_logger(__PACKAGE__); + $logger->debug("Creating instance"); + bless {}, $class; + } + ########################################### + package Bar::Twix; + ########################################### + our @ISA = qw(Bar); + + ########################################### + package main; + ########################################### + Log::Log4perl->init(\ qq{ + log4perl.category.Bar.Twix = DEBUG, Screen + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = SimpleLayout + }); + + my $bar = Bar::Twix->new(); + +C<Bar::Twix> just inherits everything from C<Bar>, including the constructor +C<new()>. +Contrary to what you might be thinking at first, this won't log anything. +Reason for this is the C<get_logger()> call in package C<Bar>, which +will always get a logger of the C<Bar> category, even if we call C<new()> via +the C<Bar::Twix> package, which will make perl go up the inheritance +tree to actually execute C<Bar::new()>. Since we've only defined logging +behaviour for C<Bar::Twix> in the configuration file, nothing will happen. + +This can be fixed by changing the C<get_logger()> method in C<Bar::new()> +to obtain a logger of the category matching the +I<actual> class of the object, like in + + # ... in Bar::new() ... + my $logger = Log::Log4perl::get_logger( $class ); + +In a method other than the constructor, the class name of the actual +object can be obtained by calling C<ref()> on the object reference, so + + package BaseClass; + use Log::Log4perl qw( get_logger ); + + sub new { + bless {}, shift; + } + + sub method { + my( $self ) = @_; + + get_logger( ref $self )->debug( "message" ); + } + + package SubClass; + our @ISA = qw(BaseClass); + +is the recommended pattern to make sure that + + my $sub = SubClass->new(); + $sub->meth(); + +starts logging if the C<"SubClass"> category +(and not the C<"BaseClass"> category has logging enabled at the DEBUG level. + +=head2 Initialize once and only once + +It's important to realize that Log::Log4perl gets initialized once and only +once, typically at the start of a program or system. Calling C<init()> +more than once will cause it to clobber the existing configuration and +I<replace> it by the new one. + +If you're in a traditional CGI environment, where every request is +handled by a new process, calling C<init()> every time is fine. In +persistent environments like C<mod_perl>, however, Log::Log4perl +should be initialized either at system startup time (Apache offers +startup handlers for that) or via + + # Init or skip if already done + Log::Log4perl->init_once($conf_file); + +C<init_once()> is identical to C<init()>, just with the exception +that it will leave a potentially existing configuration alone and +will only call C<init()> if Log::Log4perl hasn't been initialized yet. + +If you're just curious if Log::Log4perl has been initialized yet, the +check + + if(Log::Log4perl->initialized()) { + # Yes, Log::Log4perl has already been initialized + } else { + # No, not initialized yet ... + } + +can be used. + +If you're afraid that the components of your system are stepping on +each other's toes or if you are thinking that different components should +initialize Log::Log4perl separately, try to consolidate your system +to use a centralized Log4perl configuration file and use +Log4perl's I<categories> to separate your components. + +=head2 Custom Filters + +Log4perl allows the use of customized filters in its appenders +to control the output of messages. These filters might grep for +certain text chunks in a message, verify that its priority +matches or exceeds a certain level or that this is the 10th +time the same message has been submitted -- and come to a log/no log +decision based upon these circumstantial facts. + +Check out L<Log::Log4perl::Filter> for detailed instructions +on how to use them. + +=head2 Performance + +The performance of Log::Log4perl calls obviously depends on a lot of things. +But to give you a general idea, here's some rough numbers: + +On a Pentium 4 Linux box at 2.4 GHz, you'll get through + +=over 4 + +=item * + +500,000 suppressed log statements per second + +=item * + +30,000 logged messages per second (using an in-memory appender) + +=item * + +init_and_watch delay mode: 300,000 suppressed, 30,000 logged. +init_and_watch signal mode: 450,000 suppressed, 30,000 logged. + +=back + +Numbers depend on the complexity of the Log::Log4perl configuration. +For a more detailed benchmark test, check the C<docs/benchmark.results.txt> +document in the Log::Log4perl distribution. + +=head1 Cool Tricks + +Here's a collection of useful tricks for the advanced C<Log::Log4perl> user. +For more, check the FAQ, either in the distribution +(L<Log::Log4perl::FAQ>) or on L<http://log4perl.sourceforge.net>. + +=head2 Shortcuts + +When getting an instance of a logger, instead of saying + + use Log::Log4perl; + my $logger = Log::Log4perl->get_logger(); + +it's often more convenient to import the C<get_logger> method from +C<Log::Log4perl> into the current namespace: + + use Log::Log4perl qw(get_logger); + my $logger = get_logger(); + +Please note this difference: To obtain the root logger, please use +C<get_logger("")>, call it without parameters (C<get_logger()>), you'll +get the logger of a category named after the current package. +C<get_logger()> is equivalent to C<get_logger(__PACKAGE__)>. + +=head2 Alternative initialization + +Instead of having C<init()> read in a configuration file by specifying +a file name or passing it a reference to an open filehandle +(C<Log::Log4perl-E<gt>init( \*FILE )>), +you can +also pass in a reference to a string, containing the content of +the file: + + Log::Log4perl->init( \$config_text ); + +Also, if you've got the C<name=value> pairs of the configuration in +a hash, you can just as well initialize C<Log::Log4perl> with +a reference to it: + + my %key_value_pairs = ( + "log4perl.rootLogger" => "ERROR, LOGFILE", + "log4perl.appender.LOGFILE" => "Log::Log4perl::Appender::File", + ... + ); + + Log::Log4perl->init( \%key_value_pairs ); + +Or also you can use a URL, see below: + +=head2 Using LWP to parse URLs + +(This section borrowed from XML::DOM::Parser by T.J. Mather). + +The init() function now also supports URLs, e.g. I<http://www.erols.com/enno/xsa.xml>. +It uses LWP to download the file and then calls parse() on the resulting string. +By default it will use a L<LWP::UserAgent> that is created as follows: + + use LWP::UserAgent; + $LWP_USER_AGENT = LWP::UserAgent->new; + $LWP_USER_AGENT->env_proxy; + +Note that env_proxy reads proxy settings from environment variables, which is what I need to +do to get thru our firewall. If you want to use a different LWP::UserAgent, you can +set it with + + Log::Log4perl::Config::set_LWP_UserAgent($my_agent); + +Currently, LWP is used when the filename (passed to parsefile) starts with one of +the following URL schemes: http, https, ftp, wais, gopher, or file (followed by a colon.) + +Don't use this feature with init_and_watch(). + +=head2 Automatic reloading of changed configuration files + +Instead of just statically initializing Log::Log4perl via + + Log::Log4perl->init($conf_file); + +there's a way to have Log::Log4perl periodically check for changes +in the configuration and reload it if necessary: + + Log::Log4perl->init_and_watch($conf_file, $delay); + +In this mode, Log::Log4perl will examine the configuration file +C<$conf_file> every C<$delay> seconds for changes via the file's +last modification timestamp. If the file has been updated, it will +be reloaded and replace the current Log::Log4perl configuration. + +The way this works is that with every logger function called +(debug(), is_debug(), etc.), Log::Log4perl will check if the delay +interval has expired. If so, it will run a -M file check on the +configuration file. If its timestamp has been modified, the current +configuration will be dumped and new content of the file will be +loaded. + +This convenience comes at a price, though: Calling time() with every +logging function call, especially the ones that are "suppressed" (!), +will slow down these Log4perl calls by about 40%. + +To alleviate this performance hit a bit, C<init_and_watch()> +can be configured to listen for a Unix signal to reload the +configuration instead: + + Log::Log4perl->init_and_watch($conf_file, 'HUP'); + +This will set up a signal handler for SIGHUP and reload the configuration +if the application receives this signal, e.g. via the C<kill> command: + + kill -HUP pid + +where C<pid> is the process ID of the application. This will bring you back +to about 85% of Log::Log4perl's normal execution speed for suppressed +statements. For details, check out L<"Performance">. For more info +on the signal handler, look for L<Log::Log4perl::Config::Watch/"SIGNAL MODE">. + +If you have a somewhat long delay set between physical config file checks +or don't want to use the signal associated with the config file watcher, +you can trigger a configuration reload at the next possible time by +calling C<Log::Log4perl::Config-E<gt>watcher-E<gt>force_next_check()>. + +One thing to watch out for: If the configuration file contains a syntax +or other fatal error, a running application will stop with C<die> if +this damaged configuration will be loaded during runtime, triggered +either by a signal or if the delay period expired and the change is +detected. This behaviour might change in the future. + +To allow the application to intercept and control a configuration reload +in init_and_watch mode, a callback can be specified: + + Log::Log4perl->init_and_watch($conf_file, 10, { + preinit_callback => \&callback }); + +If Log4perl determines that the configuration needs to be reloaded, it will +call the C<preinit_callback> function without parameters. If the callback +returns a true value, Log4perl will proceed and reload the configuration. If +the callback returns a false value, Log4perl will keep the old configuration +and skip reloading it until the next time around. Inside the callback, an +application can run all kinds of checks, including accessing the configuration +file, which is available via +C<Log::Log4perl::Config-E<gt>watcher()-E<gt>file()>. + +=head2 Variable Substitution + +To avoid having to retype the same expressions over and over again, +Log::Log4perl's configuration files support simple variable substitution. +New variables are defined simply by adding + + varname = value + +lines to the configuration file before using + + ${varname} + +afterwards to recall the assigned values. Here's an example: + + layout_class = Log::Log4perl::Layout::PatternLayout + layout_pattern = %d %F{1} %L> %m %n + + log4perl.category.Bar.Twix = WARN, Logfile, Screen + + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = ${layout_class} + log4perl.appender.Logfile.layout.ConversionPattern = ${layout_pattern} + + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = ${layout_class} + log4perl.appender.Screen.layout.ConversionPattern = ${layout_pattern} + +This is a convenient way to define two appenders with the same layout +without having to retype the pattern definitions. + +Variable substitution via C<${varname}> +will first try to find an explicitly defined +variable. If that fails, it will check your shell's environment +for a variable of that name. If that also fails, the program will C<die()>. + +=head2 Perl Hooks in the Configuration File + +If some of the values used in the Log4perl configuration file +need to be dynamically modified by the program, use Perl hooks: + + log4perl.appender.File.filename = \ + sub { return getLogfileName(); } + +Each value starting with the string C<sub {...> is interpreted as Perl code to +be executed at the time the application parses the configuration +via C<Log::Log4perl::init()>. The return value of the subroutine +is used by Log::Log4perl as the configuration value. + +The Perl code is executed in the C<main> package, functions in +other packages have to be called in fully-qualified notation. + +Here's another example, utilizing an environment variable as a +username for a DBI appender: + + log4perl.appender.DB.username = \ + sub { $ENV{DB_USER_NAME } } + +However, please note the difference between these code snippets and those +used for user-defined conversion specifiers as discussed in +L<Log::Log4perl::Layout::PatternLayout>: +While the snippets above are run I<once> +when C<Log::Log4perl::init()> is called, the conversion specifier +snippets are executed I<each time> a message is rendered according to +the PatternLayout. + +SECURITY NOTE: this feature means arbitrary perl code can be embedded in the +config file. In the rare case where the people who have access to your config +file are different from the people who write your code and shouldn't have +execute rights, you might want to set + + Log::Log4perl::Config->allow_code(0); + +before you call init(). Alternatively you can supply a restricted set of +Perl opcodes that can be embedded in the config file as described in +L<"Restricting what Opcodes can be in a Perl Hook">. + +=head2 Restricting what Opcodes can be in a Perl Hook + +The value you pass to Log::Log4perl::Config->allow_code() determines whether +the code that is embedded in the config file is eval'd unrestricted, or +eval'd in a Safe compartment. By default, a value of '1' is assumed, +which does a normal 'eval' without any restrictions. A value of '0' +however prevents any embedded code from being evaluated. + +If you would like fine-grained control over what can and cannot be included +in embedded code, then please utilize the following methods: + + Log::Log4perl::Config->allow_code( $allow ); + Log::Log4perl::Config->allowed_code_ops($op1, $op2, ... ); + Log::Log4perl::Config->vars_shared_with_safe_compartment( [ \%vars | $package, \@vars ] ); + Log::Log4perl::Config->allowed_code_ops_convenience_map( [ \%map | $name, \@mask ] ); + +Log::Log4perl::Config-E<gt>allowed_code_ops() takes a list of opcode masks +that are allowed to run in the compartment. The opcode masks must be +specified as described in L<Opcode>: + + Log::Log4perl::Config->allowed_code_ops(':subprocess'); + +This example would allow Perl operations like backticks, system, fork, and +waitpid to be executed in the compartment. Of course, you probably don't +want to use this mask -- it would allow exactly what the Safe compartment is +designed to prevent. + +Log::Log4perl::Config-E<gt>vars_shared_with_safe_compartment() +takes the symbols which +should be exported into the Safe compartment before the code is evaluated. +The keys of this hash are the package names that the symbols are in, and the +values are array references to the literal symbol names. For convenience, +the default settings export the '%ENV' hash from the 'main' package into the +compartment: + + Log::Log4perl::Config->vars_shared_with_safe_compartment( + main => [ '%ENV' ], + ); + +Log::Log4perl::Config-E<gt>allowed_code_ops_convenience_map() is an accessor +method to a map of convenience names to opcode masks. At present, the +following convenience names are defined: + + safe = [ ':browse' ] + restrictive = [ ':default' ] + +For convenience, if Log::Log4perl::Config-E<gt>allow_code() is called with a +value which is a key of the map previously defined with +Log::Log4perl::Config-E<gt>allowed_code_ops_convenience_map(), then the +allowed opcodes are set according to the value defined in the map. If this +is confusing, consider the following: + + use Log::Log4perl; + + my $config = <<'END'; + log4perl.logger = INFO, Main + log4perl.appender.Main = Log::Log4perl::Appender::File + log4perl.appender.Main.filename = \ + sub { "example" . getpwuid($<) . ".log" } + log4perl.appender.Main.layout = Log::Log4perl::Layout::SimpleLayout + END + + $Log::Log4perl::Config->allow_code('restrictive'); + Log::Log4perl->init( \$config ); # will fail + $Log::Log4perl::Config->allow_code('safe'); + Log::Log4perl->init( \$config ); # will succeed + +The reason that the first call to -E<gt>init() fails is because the +'restrictive' name maps to an opcode mask of ':default'. getpwuid() is not +part of ':default', so -E<gt>init() fails. The 'safe' name maps to an opcode +mask of ':browse', which allows getpwuid() to run, so -E<gt>init() succeeds. + +allowed_code_ops_convenience_map() can be invoked in several ways: + +=over 4 + +=item allowed_code_ops_convenience_map() + +Returns the entire convenience name map as a hash reference in scalar +context or a hash in list context. + +=item allowed_code_ops_convenience_map( \%map ) + +Replaces the entire convenience name map with the supplied hash reference. + +=item allowed_code_ops_convenience_map( $name ) + +Returns the opcode mask for the given convenience name, or undef if no such +name is defined in the map. + +=item allowed_code_ops_convenience_map( $name, \@mask ) + +Adds the given name/mask pair to the convenience name map. If the name +already exists in the map, it's value is replaced with the new mask. + +=back + +as can vars_shared_with_safe_compartment(): + +=over 4 + +=item vars_shared_with_safe_compartment() + +Return the entire map of packages to variables as a hash reference in scalar +context or a hash in list context. + +=item vars_shared_with_safe_compartment( \%packages ) + +Replaces the entire map of packages to variables with the supplied hash +reference. + +=item vars_shared_with_safe_compartment( $package ) + +Returns the arrayref of variables to be shared for a specific package. + +=item vars_shared_with_safe_compartment( $package, \@vars ) + +Adds the given package / varlist pair to the map. If the package already +exists in the map, it's value is replaced with the new arrayref of variable +names. + +=back + +For more information on opcodes and Safe Compartments, see L<Opcode> and +L<Safe>. + +=head2 Changing the Log Level on a Logger + +Log4perl provides some internal functions for quickly adjusting the +log level from within a running Perl program. + +Now, some people might +argue that you should adjust your levels from within an external +Log4perl configuration file, but Log4perl is everybody's darling. + +Typically run-time adjusting of levels is done +at the beginning, or in response to some external input (like a +"more logging" runtime command for diagnostics). + +You get the log level from a logger object with: + + $current_level = $logger->level(); + +and you may set it with the same method, provided you first +imported the log level constants, with: + + use Log::Log4perl::Level; + +Then you can set the level on a logger to one of the constants, + + $logger->level($ERROR); # one of DEBUG, INFO, WARN, ERROR, FATAL + +To B<increase> the level of logging currently being done, use: + + $logger->more_logging($delta); + +and to B<decrease> it, use: + + $logger->less_logging($delta); + +$delta must be a positive integer (for now, we may fix this later ;). + +There are also two equivalent functions: + + $logger->inc_level($delta); + $logger->dec_level($delta); + +They're included to allow you a choice in readability. Some folks +will prefer more/less_logging, as they're fairly clear in what they +do, and allow the programmer not to worry too much about what a Level +is and whether a higher Level means more or less logging. However, +other folks who do understand and have lots of code that deals with +levels will probably prefer the inc_level() and dec_level() methods as +they want to work with Levels and not worry about whether that means +more or less logging. :) + +That diatribe aside, typically you'll use more_logging() or inc_level() +as such: + + my $v = 0; # default level of verbosity. + + GetOptions("v+" => \$v, ...); + + if( $v ) { + $logger->more_logging($v); # inc logging level once for each -v in ARGV + } + +=head2 Custom Log Levels + +First off, let me tell you that creating custom levels is heavily +deprecated by the log4j folks. Indeed, instead of creating additional +levels on top of the predefined DEBUG, INFO, WARN, ERROR and FATAL, +you should use categories to control the amount of logging smartly, +based on the location of the log-active code in the system. + +Nevertheless, +Log4perl provides a nice way to create custom levels via the +create_custom_level() routine function. However, this must be done +before the first call to init() or get_logger(). Say you want to create +a NOTIFY logging level that comes after WARN (and thus before INFO). +You'd do such as follows: + + use Log::Log4perl; + use Log::Log4perl::Level; + + Log::Log4perl::Logger::create_custom_level("NOTIFY", "WARN"); + +And that's it! create_custom_level() creates the following functions / +variables for level FOO: + + $FOO_INT # integer to use in L4p::Level::to_level() + $logger->foo() # log function to log if level = FOO + $logger->is_foo() # true if current level is >= FOO + +These levels can also be used in your +config file, but note that your config file probably won't be +portable to another log4perl or log4j environment unless you've +made the appropriate mods there too. + +Since Log4perl translates log levels to syslog and Log::Dispatch if +their appenders are used, you may add mappings for custom levels as well: + + Log::Log4perl::Level::add_priority("NOTIFY", "WARN", + $syslog_equiv, $log_dispatch_level); + +For example, if your new custom "NOTIFY" level is supposed to map +to syslog level 2 ("LOG_NOTICE") and Log::Dispatch level 2 ("notice"), use: + + Log::Log4perl::Logger::create_custom_level("NOTIFY", "WARN", 2, 2); + +=head2 System-wide log levels + +As a fairly drastic measure to decrease (or increase) the logging level +all over the system with one single configuration option, use the C<threshold> +keyword in the Log4perl configuration file: + + log4perl.threshold = ERROR + +sets the system-wide (or hierarchy-wide according to the log4j documentation) +to ERROR and therefore deprives every logger in the system of the right +to log lower-prio messages. + +=head2 Easy Mode + +For teaching purposes (especially for [1]), I've put C<:easy> mode into +C<Log::Log4perl>, which just initializes a single root logger with a +defined priority and a screen appender including some nice standard layout: + + ### Initialization Section + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init($ERROR); # Set priority of root logger to ERROR + + ### Application Section + my $logger = get_logger(); + $logger->fatal("This will get logged."); + $logger->debug("This won't."); + +This will dump something like + + 2002/08/04 11:43:09 ERROR> script.pl:16 main::function - This will get logged. + +to the screen. While this has been proven to work well familiarizing people +with C<Log::Logperl> slowly, effectively avoiding to clobber them over the +head with a +plethora of different knobs to fiddle with (categories, appenders, levels, +layout), the overall mission of C<Log::Log4perl> is to let people use +categories right from the start to get used to the concept. So, let's keep +this one fairly hidden in the man page (congrats on reading this far :). + +=head2 Stealth loggers + +Sometimes, people are lazy. If you're whipping up a 50-line script and want +the comfort of Log::Log4perl without having the burden of carrying a +separate log4perl.conf file or a 5-liner defining that you want to append +your log statements to a file, you can use the following features: + + use Log::Log4perl qw(:easy); + + Log::Log4perl->easy_init( { level => $DEBUG, + file => ">>test.log" } ); + + # Logs to test.log via stealth logger + DEBUG("Debug this!"); + INFO("Info this!"); + WARN("Warn this!"); + ERROR("Error this!"); + + some_function(); + + sub some_function { + # Same here + FATAL("Fatal this!"); + } + +In C<:easy> mode, C<Log::Log4perl> will instantiate a I<stealth logger> +and introduce the +convenience functions C<TRACE>, C<DEBUG()>, C<INFO()>, C<WARN()>, +C<ERROR()>, C<FATAL()>, and C<ALWAYS> into the package namespace. +These functions simply take messages as +arguments and forward them to the stealth loggers methods (C<debug()>, +C<info()>, and so on). + +If a message should never be blocked, regardless of the log level, +use the C<ALWAYS> function which corresponds to a log level of C<OFF>: + + ALWAYS "This will be printed regardless of the log level"; + +The C<easy_init> method can be called with a single level value to +create a STDERR appender and a root logger as in + + Log::Log4perl->easy_init($DEBUG); + +or, as shown below (and in the example above) +with a reference to a hash, specifying values +for C<level> (the logger's priority), C<file> (the appender's data sink), +C<category> (the logger's category and C<layout> for the appender's +pattern layout specification. +All key-value pairs are optional, they +default to C<$DEBUG> for C<level>, C<STDERR> for C<file>, +C<""> (root category) for C<category> and +C<%d %m%n> for C<layout>: + + Log::Log4perl->easy_init( { level => $DEBUG, + file => ">test.log", + utf8 => 1, + category => "Bar::Twix", + layout => '%F{1}-%L-%M: %m%n' } ); + +The C<file> parameter takes file names preceded by C<"E<gt>"> +(overwrite) and C<"E<gt>E<gt>"> (append) as arguments. This will +cause C<Log::Log4perl::Appender::File> appenders to be created behind +the scenes. Also the keywords C<STDOUT> and C<STDERR> (no C<E<gt>> or +C<E<gt>E<gt>>) are recognized, which will utilize and configure +C<Log::Log4perl::Appender::Screen> appropriately. The C<utf8> flag, +if set to a true value, runs a C<binmode> command on the file handle +to establish a utf8 line discipline on the file, otherwise you'll get a +'wide character in print' warning message and probably not what you'd +expect as output. + +The stealth loggers can be used in different packages, you just need to make +sure you're calling the "use" function in every package you're using +C<Log::Log4perl>'s easy services: + + package Bar::Twix; + use Log::Log4perl qw(:easy); + sub eat { DEBUG("Twix mjam"); } + + package Bar::Mars; + use Log::Log4perl qw(:easy); + sub eat { INFO("Mars mjam"); } + + package main; + + use Log::Log4perl qw(:easy); + + Log::Log4perl->easy_init( { level => $DEBUG, + file => ">>test.log", + category => "Bar::Twix", + layout => '%F{1}-%L-%M: %m%n' }, + { level => $DEBUG, + file => "STDOUT", + category => "Bar::Mars", + layout => '%m%n' }, + ); + Bar::Twix::eat(); + Bar::Mars::eat(); + +As shown above, C<easy_init()> will take any number of different logger +definitions as hash references. + +Also, stealth loggers feature the functions C<LOGWARN()>, C<LOGDIE()>, +and C<LOGEXIT()>, +combining a logging request with a subsequent Perl warn() or die() or exit() +statement. So, for example + + if($all_is_lost) { + LOGDIE("Terrible Problem"); + } + +will log the message if the package's logger is at least C<FATAL> but +C<die()> (including the traditional output to STDERR) in any case afterwards. + +See L<"Log and die or warn"> for the similar C<logdie()> and C<logwarn()> +functions of regular (i.e non-stealth) loggers. + +Similarily, C<LOGCARP()>, C<LOGCLUCK()>, C<LOGCROAK()>, and C<LOGCONFESS()> +are provided in C<:easy> mode, facilitating the use of C<logcarp()>, +C<logcluck()>, C<logcroak()>, and C<logconfess()> with stealth loggers. + +B<When using Log::Log4perl in easy mode, +please make sure you understand the implications of +L</"Pitfalls with Categories">>. + +By the way, these convenience functions perform exactly as fast as the +standard Log::Log4perl logger methods, there's I<no> performance penalty +whatsoever. + +=head2 Nested Diagnostic Context (NDC) + +If you find that your application could use a global (thread-specific) +data stack which your loggers throughout the system have easy access to, +use Nested Diagnostic Contexts (NDCs). Also check out +L<"Mapped Diagnostic Context (MDC)">, this might turn out to be even more +useful. + +For example, when handling a request of a web client, it's probably +useful to have the user's IP address available in all log statements +within code dealing with this particular request. Instead of passing +this piece of data around between your application functions, you can just +use the global (but thread-specific) NDC mechanism. It allows you +to push data pieces (scalars usually) onto its stack via + + Log::Log4perl::NDC->push("San"); + Log::Log4perl::NDC->push("Francisco"); + +and have your loggers retrieve them again via the "%x" placeholder in +the PatternLayout. With the stack values above and a PatternLayout format +like "%x %m%n", the call + + $logger->debug("rocks"); + +will end up as + + San Francisco rocks + +in the log appender. + +The stack mechanism allows for nested structures. +Just make sure that at the end of the request, you either decrease the stack +one by one by calling + + Log::Log4perl::NDC->pop(); + Log::Log4perl::NDC->pop(); + +or clear out the entire NDC stack by calling + + Log::Log4perl::NDC->remove(); + +Even if you should forget to do that, C<Log::Log4perl> won't grow the stack +indefinitely, but limit it to a maximum, defined in C<Log::Log4perl::NDC> +(currently 5). A call to C<push()> on a full stack will just replace +the topmost element by the new value. + +Again, the stack is always available via the "%x" placeholder +in the Log::Log4perl::Layout::PatternLayout class whenever a logger +fires. It will replace "%x" by the blank-separated list of the +values on the stack. It does that by just calling + + Log::Log4perl::NDC->get(); + +internally. See details on how this standard log4j feature is implemented +in L<Log::Log4perl::NDC>. + +=head2 Mapped Diagnostic Context (MDC) + +Just like the previously discussed NDC stores thread-specific +information in a stack structure, the MDC implements a hash table +to store key/value pairs in. + +The static method + + Log::Log4perl::MDC->put($key, $value); + +stores C<$value> under a key C<$key>, with which it can be retrieved later +(possibly in a totally different part of the system) by calling +the C<get> method: + + my $value = Log::Log4perl::MDC->get($key); + +If no value has been stored previously under C<$key>, the C<get> method +will return C<undef>. + +Typically, MDC values are retrieved later on via the C<"%X{...}"> placeholder +in C<Log::Log4perl::Layout::PatternLayout>. If the C<get()> method +returns C<undef>, the placeholder will expand to the string C<[undef]>. + +An application taking a web request might store the remote host +like + + Log::Log4perl::MDC->put("remote_host", $r->headers("HOST")); + +at its beginning and if the appender's layout looks something like + + log4perl.appender.Logfile.layout.ConversionPattern = %X{remote_host}: %m%n + +then a log statement like + + DEBUG("Content delivered"); + +will log something like + + adsl-63.dsl.snf.pacbell.net: Content delivered + +later on in the program. + +For details, please check L<Log::Log4perl::MDC>. + +=head2 Resurrecting hidden Log4perl Statements + +Sometimes scripts need to be deployed in environments without having +Log::Log4perl installed yet. On the other hand, you don't want to +live without your Log4perl statements -- they're gonna come in +handy later. + +So, just deploy your script with Log4perl statements commented out with the +pattern C<###l4p>, like in + + ###l4p DEBUG "It works!"; + # ... + ###l4p INFO "Really!"; + +If Log::Log4perl is available, +use the C<:resurrect> tag to have Log4perl resurrect those buried +statements before the script starts running: + + use Log::Log4perl qw(:resurrect :easy); + + ###l4p Log::Log4perl->easy_init($DEBUG); + ###l4p DEBUG "It works!"; + # ... + ###l4p INFO "Really!"; + +This will have a source filter kick in and indeed print + + 2004/11/18 22:08:46 It works! + 2004/11/18 22:08:46 Really! + +In environments lacking Log::Log4perl, just comment out the first line +and the script will run nevertheless (but of course without logging): + + # use Log::Log4perl qw(:resurrect :easy); + + ###l4p Log::Log4perl->easy_init($DEBUG); + ###l4p DEBUG "It works!"; + # ... + ###l4p INFO "Really!"; + +because everything's a regular comment now. Alternatively, put the +magic Log::Log4perl comment resurrection line into your shell's +PERL5OPT environment variable, e.g. for bash: + + set PERL5OPT=-MLog::Log4perl=:resurrect,:easy + export PERL5OPT + +This will awaken the giant within an otherwise silent script like +the following: + + #!/usr/bin/perl + + ###l4p Log::Log4perl->easy_init($DEBUG); + ###l4p DEBUG "It works!"; + +As of C<Log::Log4perl> 1.12, you can even force I<all> modules +loaded by a script to have their hidden Log4perl statements +resurrected. For this to happen, load C<Log::Log4perl::Resurrector> +I<before> loading any modules: + + use Log::Log4perl qw(:easy); + use Log::Log4perl::Resurrector; + + use Foobar; # All hidden Log4perl statements in here will + # be uncommented before Foobar gets loaded. + + Log::Log4perl->easy_init($DEBUG); + ... + +Check the C<Log::Log4perl::Resurrector> manpage for more details. + +=head2 Access defined appenders + +All appenders defined in the configuration file or via Perl code +can be retrieved by the C<appender_by_name()> class method. This comes +in handy if you want to manipulate or query appender properties after +the Log4perl configuration has been loaded via C<init()>. + +Note that internally, Log::Log4perl uses the C<Log::Log4perl::Appender> +wrapper class to control the real appenders (like +C<Log::Log4perl::Appender::File> or C<Log::Dispatch::FileRotate>). +The C<Log::Log4perl::Appender> class has an C<appender> attribute, +pointing to the real appender. + +The reason for this is that external appenders like +C<Log::Dispatch::FileRotate> don't support all of Log::Log4perl's +appender control mechanisms (like appender thresholds). + +The previously mentioned method C<appender_by_name()> returns a +reference to the I<real> appender object. If you want access to the +wrapper class (e.g. if you want to modify the appender's threshold), +use the hash C<$Log::Log4perl::Logger::APPENDER_BY_NAME{...}> instead, +which holds references to all appender wrapper objects. + +=head2 Modify appender thresholds + +To set an appender's threshold, use its C<threshold()> method: + + $app->threshold( $FATAL ); + +To conveniently adjust I<all> appender thresholds (e.g. because a script +uses more_logging()), use + + # decrease thresholds of all appenders + Log::Log4perl->appender_thresholds_adjust(-1); + +This will decrease the thresholds of all appenders in the system by +one level, i.e. WARN becomes INFO, INFO becomes DEBUG, etc. To only modify +selected ones, use + + # decrease thresholds of all appenders + Log::Log4perl->appender_thresholds_adjust(-1, ['AppName1', ...]); + +and pass the names of affected appenders in a ref to an array. + +=head1 Advanced configuration within Perl + +Initializing Log::Log4perl can certainly also be done from within Perl. +At last, this is what C<Log::Log4perl::Config> does behind the scenes. +Log::Log4perl's configuration file parsers are using a publically +available API to set up Log::Log4perl's categories, appenders and layouts. + +Here's an example on how to configure two appenders with the same layout +in Perl, without using a configuration file at all: + + ######################## + # Initialization section + ######################## + use Log::Log4perl; + use Log::Log4perl::Layout; + use Log::Log4perl::Level; + + # Define a category logger + my $log = Log::Log4perl->get_logger("Foo::Bar"); + + # Define a layout + my $layout = Log::Log4perl::Layout::PatternLayout->new("[%r] %F %L %m%n"); + + # Define a file appender + my $file_appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::File", + name => "filelog", + filename => "/tmp/my.log"); + + # Define a stdout appender + my $stdout_appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::Screen", + name => "screenlog", + stderr => 0); + + # Have both appenders use the same layout (could be different) + $stdout_appender->layout($layout); + $file_appender->layout($layout); + + $log->add_appender($stdout_appender); + $log->add_appender($file_appender); + $log->level($INFO); + +Please note the class of the appender object is passed as a I<string> to +C<Log::Log4perl::Appender> in the I<first> argument. Behind the scenes, +C<Log::Log4perl::Appender> will create the necessary +C<Log::Log4perl::Appender::*> (or C<Log::Dispatch::*>) object and pass +along the name value pairs we provided to +C<Log::Log4perl::Appender-E<gt>new()> after the first argument. + +The C<name> value is optional and if you don't provide one, +C<Log::Log4perl::Appender-E<gt>new()> will create a unique one for you. +The names and values of additional parameters are dependent on the requirements +of the particular appender class and can be looked up in their +manual pages. + +A side note: In case you're wondering if +C<Log::Log4perl::Appender-E<gt>new()> will also take care of the +C<min_level> argument to the C<Log::Dispatch::*> constructors called +behind the scenes -- yes, it does. This is because we want the +C<Log::Dispatch> objects to blindly log everything we send them +(C<debug> is their lowest setting) because I<we> in C<Log::Log4perl> +want to call the shots and decide on when and what to log. + +The call to the appender's I<layout()> method specifies the format (as a +previously created C<Log::Log4perl::Layout::PatternLayout> object) in which the +message is being logged in the specified appender. +If you don't specify a layout, the logger will fall back to +C<Log::Log4perl::SimpleLayout>, which logs the debug level, a hyphen (-) +and the log message. + +Layouts are objects, here's how you create them: + + # Create a simple layout + my $simple = Log::Log4perl::SimpleLayout(); + + # create a flexible layout: + # ("yyyy/MM/dd hh:mm:ss (file:lineno)> message\n") + my $pattern = Log::Log4perl::Layout::PatternLayout("%d (%F:%L)> %m%n"); + +Every appender has exactly one layout assigned to it. You assign +the layout to the appender using the appender's C<layout()> object: + + my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::Screen", + name => "screenlog", + stderr => 0); + + # Assign the previously defined flexible layout + $app->layout($pattern); + + # Add the appender to a previously defined logger + $logger->add_appender($app); + + # ... and you're good to go! + $logger->debug("Blah"); + # => "2002/07/10 23:55:35 (test.pl:207)> Blah\n" + +It's also possible to remove appenders from a logger: + + $logger->remove_appender($appender_name); + +will remove an appender, specified by name, from a given logger. +Please note that this does +I<not> remove an appender from the system. + +To eradicate an appender from the system, +you need to call C<Log::Log4perl-E<gt>eradicate_appender($appender_name)> +which will first remove the appender from every logger in the system +and then will delete all references Log4perl holds to it. + +To remove a logger from the system, use +C<Log::Log4perl-E<gt>remove_logger($logger)>. After the remaining +reference C<$logger> goes away, the logger will self-destruct. If the +logger in question is a stealth logger, all of its convenience shortcuts +(DEBUG, INFO, etc) will turn into no-ops. + +=head1 How about Log::Dispatch::Config? + +Tatsuhiko Miyagawa's C<Log::Dispatch::Config> is a very clever +simplified logger implementation, covering some of the I<log4j> +functionality. Among the things that +C<Log::Log4perl> can but C<Log::Dispatch::Config> can't are: + +=over 4 + +=item * + +You can't assign categories to loggers. For small systems that's fine, +but if you can't turn off and on detailed logging in only a tiny +subsystem of your environment, you're missing out on a majorly +useful log4j feature. + +=item * + +Defining appender thresholds. Important if you want to solve problems like +"log all messages of level FATAL to STDERR, plus log all DEBUG +messages in C<Foo::Bar> to a log file". If you don't have appenders +thresholds, there's no way to prevent cluttering STDERR with DEBUG messages. + +=item * + +PatternLayout specifications in accordance with the standard +(e.g. "%d{HH:mm}"). + +=back + +Bottom line: Log::Dispatch::Config is fine for small systems with +simple logging requirements. However, if you're +designing a system with lots of subsystems which you need to control +independently, you'll love the features of C<Log::Log4perl>, +which is equally easy to use. + +=head1 Using Log::Log4perl with wrapper functions and classes + +If you don't use C<Log::Log4perl> as described above, +but from a wrapper function, the pattern layout will generate wrong data +for %F, %C, %L, and the like. Reason for this is that C<Log::Log4perl>'s +loggers assume a static caller depth to the application that's using them. + +If you're using +one (or more) wrapper functions, C<Log::Log4perl> will indicate where +your logger function called the loggers, not where your application +called your wrapper: + + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init({ level => $DEBUG, + layout => "%M %m%n" }); + + sub mylog { + my($message) = @_; + + DEBUG $message; + } + + sub func { + mylog "Hello"; + } + + func(); + +prints + + main::mylog Hello + +but that's probably not what your application expects. Rather, you'd +want + + main::func Hello + +because the C<func> function called your logging function. + +But don't despair, there's a solution: Just register your wrapper +package with Log4perl beforehand. If Log4perl then finds that it's being +called from a registered wrapper, it will automatically step up to the +next call frame. + + Log::Log4perl->wrapper_register(__PACKAGE__); + + sub mylog { + my($message) = @_; + + DEBUG $message; + } + +Alternatively, you can increase the value of the global variable +C<$Log::Log4perl::caller_depth> (defaults to 0) by one for every +wrapper that's in between your application and C<Log::Log4perl>, +then C<Log::Log4perl> will compensate for the difference: + + sub mylog { + my($message) = @_; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + DEBUG $message; + } + +Also, note that if you're writing a subclass of Log4perl, like + + package MyL4pWrapper; + use Log::Log4perl; + our @ISA = qw(Log::Log4perl); + +and you want to call get_logger() in your code, like + + use MyL4pWrapper; + + sub get_logger { + my $logger = Log::Log4perl->get_logger(); + } + +then the get_logger() call will get a logger for the C<MyL4pWrapper> +category, not for the package calling the wrapper class as in + + package UserPackage; + my $logger = MyL4pWrapper->get_logger(); + +To have the above call to get_logger return a logger for the +"UserPackage" category, you need to tell Log4perl that "MyL4pWrapper" +is a Log4perl wrapper class: + + use MyL4pWrapper; + Log::Log4perl->wrapper_register(__PACKAGE__); + + sub get_logger { + # Now gets a logger for the category of the calling package + my $logger = Log::Log4perl->get_logger(); + } + +This feature works both for Log4perl-relaying classes like the wrapper +described above, and for wrappers that inherit from Log4perl use Log4perl's +get_logger function via inheritance, alike. + +=head1 Access to Internals + +The following methods are only of use if you want to peek/poke in +the internals of Log::Log4perl. Be careful not to disrupt its +inner workings. + +=over 4 + +=item C<< Log::Log4perl->appenders() >> + +To find out which appenders are currently defined (not only +for a particular logger, but overall), a C<appenders()> +method is available to return a reference to a hash mapping appender +names to their Log::Log4perl::Appender object references. + +=back + +=head1 Dirty Tricks + +=over 4 + +=item infiltrate_lwp() + +The famous LWP::UserAgent module isn't Log::Log4perl-enabled. Often, though, +especially when tracing Web-related problems, it would be helpful to get +some insight on what's happening inside LWP::UserAgent. Ideally, LWP::UserAgent +would even play along in the Log::Log4perl framework. + +A call to C<Log::Log4perl-E<gt>infiltrate_lwp()> does exactly this. +In a very rude way, it pulls the rug from under LWP::UserAgent and transforms +its C<debug/conn> messages into C<debug()> calls of loggers of the category +C<"LWP::UserAgent">. Similarily, C<LWP::UserAgent>'s C<trace> messages +are turned into C<Log::Log4perl>'s C<info()> method calls. Note that this +only works for LWP::UserAgent versions E<lt> 5.822, because this (and +probably later) versions miss debugging functions entirely. + +=item Suppressing 'duplicate' LOGDIE messages + +If a script with a simple Log4perl configuration uses logdie() to catch +errors and stop processing, as in + + use Log::Log4perl qw(:easy) ; + Log::Log4perl->easy_init($DEBUG); + + shaky_function() or LOGDIE "It failed!"; + +there's a cosmetic problem: The message gets printed twice: + + 2005/07/10 18:37:14 It failed! + It failed! at ./t line 12 + +The obvious solution is to use LOGEXIT() instead of LOGDIE(), but there's +also a special tag for Log4perl that suppresses the second message: + + use Log::Log4perl qw(:no_extra_logdie_message); + +This causes logdie() and logcroak() to call exit() instead of die(). To +modify the script exit code in these occasions, set the variable +C<$Log::Log4perl::LOGEXIT_CODE> to the desired value, the default is 1. + +=item Redefine values without causing errors + +Log4perl's configuration file parser has a few basic safety mechanisms to +make sure configurations are more or less sane. + +One of these safety measures is catching redefined values. For example, if +you first write + + log4perl.category = WARN, Logfile + +and then a couple of lines later + + log4perl.category = TRACE, Logfile + +then you might have unintentionally overwritten the first value and Log4perl +will die on this with an error (suspicious configurations always throw an +error). Now, there's a chance that this is intentional, for example when +you're lumping together several configuration files and actually I<want> +the first value to overwrite the second. In this case use + + use Log::Log4perl qw(:nostrict); + +to put Log4perl in a more permissive mode. + +=item Prevent croak/confess from stringifying + +The logcroak/logconfess functions stringify their arguments before +they pass them to Carp's croak/confess functions. This can get in the +way if you want to throw an object or a hashref as an exception, in +this case use: + + $Log::Log4perl::STRINGIFY_DIE_MESSAGE = 0; + + eval { + # throws { foo => "bar" } + # without stringification + $logger->logcroak( { foo => "bar" } ); + }; + +=back + +=head1 EXAMPLE + +A simple example to cut-and-paste and get started: + + use Log::Log4perl qw(get_logger); + + my $conf = q( + log4perl.category.Bar.Twix = WARN, Logfile + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.Logfile.layout.ConversionPattern = %d %F{1} %L> %m %n + ); + + Log::Log4perl::init(\$conf); + + my $logger = get_logger("Bar::Twix"); + $logger->error("Blah"); + +This will log something like + + 2002/09/19 23:48:15 t1 25> Blah + +to the log file C<test.log>, which Log4perl will append to or +create it if it doesn't exist already. + +=head1 INSTALLATION + +If you want to use external appenders provided with C<Log::Dispatch>, +you need to install C<Log::Dispatch> (2.00 or better) from CPAN, +which itself depends on C<Attribute-Handlers> and +C<Params-Validate>. And a lot of other modules, that's the reason +why we're now shipping Log::Log4perl with its own standard appenders +and only if you wish to use additional ones, you'll have to go through +the C<Log::Dispatch> installation process. + +Log::Log4perl needs C<Test::More>, C<Test::Harness> and C<File::Spec>, +but they already come with fairly recent versions of perl. +If not, everything's automatically fetched from CPAN if you're using the CPAN +shell (CPAN.pm), because they're listed as dependencies. + +C<Time::HiRes> (1.20 or better) is required only if you need the +fine-grained time stamps of the C<%r> parameter in +C<Log::Log4perl::Layout::PatternLayout>. + +Manual installation works as usual with + + perl Makefile.PL + make + make test + make install + +=head1 DEVELOPMENT + +Log::Log4perl is still being actively developed. We will +always make sure the test suite (approx. 500 cases) will pass, but there +might still be bugs. please check L<http://github.com/mschilli/log4perl> +for the latest release. The api has reached a mature state, we will +not change it unless for a good reason. + +Bug reports and feedback are always welcome, just email them to our +mailing list shown in the AUTHORS section. We're usually addressing +them immediately. + +=head1 REFERENCES + +=over 4 + +=item [1] + +Michael Schilli, "Retire your debugger, log smartly with Log::Log4perl!", +Tutorial on perl.com, 09/2002, +L<http://www.perl.com/pub/a/2002/09/11/log4perl.html> + +=item [2] + +Ceki Gülcü, "Short introduction to log4j", +L<http://logging.apache.org/log4j/1.2/manual.html> + +=item [3] + +Vipan Singla, "Don't Use System.out.println! Use Log4j.", +L<http://www.vipan.com/htdocs/log4jhelp.html> + +=item [4] + +The Log::Log4perl project home page: L<http://log4perl.com> + +=back + +=head1 SEE ALSO + +L<Log::Log4perl::Config|Log::Log4perl::Config>, +L<Log::Log4perl::Appender|Log::Log4perl::Appender>, +L<Log::Log4perl::Layout::PatternLayout|Log::Log4perl::Layout::PatternLayout>, +L<Log::Log4perl::Layout::SimpleLayout|Log::Log4perl::Layout::SimpleLayout>, +L<Log::Log4perl::Level|Log::Log4perl::Level>, +L<Log::Log4perl::JavaMap|Log::Log4perl::JavaMap> +L<Log::Log4perl::NDC|Log::Log4perl::NDC>, + +=head1 AUTHORS + +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. + +=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. + diff --git a/lib/Log/Log4perl/Appender.pm b/lib/Log/Log4perl/Appender.pm new file mode 100644 index 0000000..af925ac --- /dev/null +++ b/lib/Log/Log4perl/Appender.pm @@ -0,0 +1,733 @@ +################################################## +package Log::Log4perl::Appender; +################################################## + +use 5.006; +use strict; +use warnings; + +use Log::Log4perl::Config; +use Log::Log4perl::Level; +use Carp; + +use constant _INTERNAL_DEBUG => 0; + +our $unique_counter = 0; + +################################################## +sub reset { +################################################## + $unique_counter = 0; +} + +################################################## +sub unique_name { +################################################## + # THREADS: Need to lock here to make it thread safe + $unique_counter++; + my $unique_name = sprintf("app%03d", $unique_counter); + # THREADS: Need to unlock here to make it thread safe + return $unique_name; +} + +################################################## +sub new { +################################################## + my($class, $appenderclass, %params) = @_; + + # Pull in the specified Log::Log4perl::Appender object + eval { + + # Eval erroneously succeeds on unknown appender classes if + # the eval string just consists of valid perl code (e.g. an + # appended ';' in $appenderclass variable). Fail if we see + # anything in there that can't be class name. + die "'$appenderclass' not a valid class name " if + $appenderclass =~ /[^:\w]/; + + # Check if the class/package is already available because + # something like Class::Prototyped injected it previously. + + # Use UNIVERSAL::can to check the appender's new() method + # [RT 28987] + if( ! $appenderclass->can('new') ) { + # Not available yet, try to pull it in. + # see 'perldoc -f require' for why two evals + eval "require $appenderclass"; + #unless ${$appenderclass.'::IS_LOADED'}; #for unit tests, + #see 004Config + die $@ if $@; + } + }; + + $@ and die "ERROR: can't load appenderclass '$appenderclass'\n$@"; + + $params{name} = unique_name() unless exists $params{name}; + + # If it's a Log::Dispatch::File appender, default to append + # mode (Log::Dispatch::File defaults to 'clobber') -- consensus 9/2002 + # (Log::Log4perl::Appender::File already defaults to 'append') + if ($appenderclass eq 'Log::Dispatch::File' && + ! exists $params{mode}) { + $params{mode} = 'append'; + } + + my $appender = $appenderclass->new( + # Set min_level to the lowest setting. *we* are + # controlling this now, the appender should just + # log it with no questions asked. + min_level => 'debug', + # Set 'name' and other parameters + map { $_ => $params{$_} } keys %params, + ); + + my $self = { + appender => $appender, + name => $params{name}, + layout => undef, + level => $ALL, + composite => 0, + }; + + #whether to collapse arrays, etc. + $self->{warp_message} = $params{warp_message}; + if($self->{warp_message} and + my $cref = + Log::Log4perl::Config::compile_if_perl($self->{warp_message})) { + $self->{warp_message} = $cref; + } + + bless $self, $class; + + return $self; +} + +################################################## +sub composite { # Set/Get the composite flag +################################################## + my ($self, $flag) = @_; + + $self->{composite} = $flag if defined $flag; + return $self->{composite}; +} + +################################################## +sub threshold { # Set/Get the appender threshold +################################################## + my ($self, $level) = @_; + + print "Setting threshold to $level\n" if _INTERNAL_DEBUG; + + if(defined $level) { + # Checking for \d makes for a faster regex(p) + $self->{level} = ($level =~ /^(\d+)$/) ? $level : + # Take advantage of &to_priority's error reporting + Log::Log4perl::Level::to_priority($level); + } + + return $self->{level}; +} + +################################################## +sub log { +################################################## +# Relay this call to Log::Log4perl::Appender:* or +# Log::Dispatch::* +################################################## + my ($self, $p, $category, $level, $cache) = @_; + + # Check if the appender has a last-minute veto in form + # of an "appender threshold" + if($self->{level} > $ + Log::Log4perl::Level::PRIORITY{$level}) { + print "$self->{level} > $level, aborting\n" if _INTERNAL_DEBUG; + return undef; + } + + # Run against the (yes only one) customized filter (which in turn + # might call other filters via the Boolean filter) and check if its + # ok() method approves the message or blocks it. + if($self->{filter}) { + if($self->{filter}->ok(%$p, + log4p_category => $category, + log4p_level => $level )) { + print "Filter $self->{filter}->{name} passes\n" if _INTERNAL_DEBUG; + } else { + print "Filter $self->{filter}->{name} blocks\n" if _INTERNAL_DEBUG; + return undef; + } + } + + unless($self->composite()) { + + #not defined, the normal case + if (! defined $self->{warp_message} ){ + #join any message elements + if (ref $p->{message} eq "ARRAY") { + for my $i (0..$#{$p->{message}}) { + if( !defined $p->{message}->[ $i ] ) { + local $Carp::CarpLevel = + $Carp::CarpLevel + $Log::Log4perl::caller_depth + 1; + carp "Warning: Log message argument #" . + ($i+1) . " undefined"; + } + } + $p->{message} = + join($Log::Log4perl::JOIN_MSG_ARRAY_CHAR, + @{$p->{message}} + ); + } + + #defined but false, e.g. Appender::DBI + } elsif (! $self->{warp_message}) { + ; #leave the message alone + + } elsif (ref($self->{warp_message}) eq "CODE") { + #defined and a subref + $p->{message} = + [$self->{warp_message}->(@{$p->{message}})]; + } else { + #defined and a function name? + no strict qw(refs); + $p->{message} = + [$self->{warp_message}->(@{$p->{message}})]; + } + + $p->{message} = $self->{layout}->render($p->{message}, + $category, + $level, + 3 + $Log::Log4perl::caller_depth, + ) if $self->layout(); + } + + my $args = [%$p, log4p_category => $category, log4p_level => $level]; + + if(defined $cache) { + $$cache = $args; + } else { + $self->{appender}->log(@$args); + } + + return 1; +} + +########################################### +sub log_cached { +########################################### + my ($self, $cache) = @_; + + $self->{appender}->log(@$cache); +} + +################################################## +sub name { # Set/Get the name +################################################## + my($self, $name) = @_; + + # Somebody wants to *set* the name? + if($name) { + $self->{name} = $name; + } + + return $self->{name}; +} + +########################################### +sub layout { # Set/Get the layout object + # associated with this appender +########################################### + my($self, $layout) = @_; + + # Somebody wants to *set* the layout? + if($layout) { + $self->{layout} = $layout; + + # somebody wants a layout, but not set yet, so give 'em default + }elsif (! $self->{layout}) { + $self->{layout} = Log::Log4perl::Layout::SimpleLayout + ->new($self->{name}); + + } + + return $self->{layout}; +} + +################################################## +sub filter { # Set filter +################################################## + my ($self, $filter) = @_; + + if($filter) { + print "Setting filter to $filter->{name}\n" if _INTERNAL_DEBUG; + $self->{filter} = $filter; + } + + return $self->{filter}; +} + +################################################## +sub AUTOLOAD { +################################################## +# Relay everything else to the underlying +# Log::Log4perl::Appender::* or Log::Dispatch::* +# object +################################################## + my $self = shift; + + no strict qw(vars); + + $AUTOLOAD =~ s/.*:://; + + if(! defined $self->{appender}) { + die "Can't locate object method $AUTOLOAD() in ", __PACKAGE__; + } + + return $self->{appender}->$AUTOLOAD(@_); +} + +################################################## +sub DESTROY { +################################################## + foreach my $key (keys %{$_[0]}) { + # print "deleting $key\n"; + delete $_[0]->{$key}; + } +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender - Log appender class + +=head1 SYNOPSIS + + use Log::Log4perl; + + # Define a logger + my $logger = Log::Log4perl->get_logger("abc.def.ghi"); + + # Define a layout + my $layout = Log::Log4perl::Layout::PatternLayout->new( + "%d (%F:%L)> %m"); + + # Define an appender + my $appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::Screen", + name => 'dumpy'); + + # Set the appender's layout + $appender->layout($layout); + $logger->add_appender($appender); + +=head1 DESCRIPTION + +This class is a wrapper around the C<Log::Log4perl::Appender> +appender set. + +It also supports the <Log::Dispatch::*> collections of appenders. The +module hides the idiosyncrasies of C<Log::Dispatch> (e.g. every +dispatcher gotta have a name, but there's no accessor to retrieve it) +from C<Log::Log4perl> and yet re-uses the extremely useful variety of +dispatchers already created and tested in C<Log::Dispatch>. + +=head1 FUNCTIONS + +=head2 Log::Log4perl::Appender->new($dispatcher_class_name, ...); + +The constructor C<new()> takes the name of the appender +class to be created as a I<string> (!) argument, optionally followed by +a number of appender-specific parameters, +for example: + + # Define an appender + my $appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::File" + filename => 'out.log'); + +In case of C<Log::Dispatch> appenders, +if no C<name> parameter is specified, the appender object will create +a unique one (format C<appNNN>), which can be retrieved later via +the C<name()> method: + + print "The appender's name is ", $appender->name(), "\n"; + +Other parameters are specific to the appender class being used. +In the case above, the C<filename> parameter specifies the name of +the C<Log::Log4perl::Appender::File> dispatcher used. + +However, if, for instance, +you're using a C<Log::Dispatch::Email> dispatcher to send you +email, you'll have to specify C<from> and C<to> email addresses. +Every dispatcher is different. +Please check the C<Log::Dispatch::*> documentation for the appender used +for details on specific requirements. + +The C<new()> method will just pass these parameters on to a newly created +C<Log::Dispatch::*> object of the specified type. + +When it comes to logging, the C<Log::Log4perl::Appender> will transparently +relay all messages to the C<Log::Dispatch::*> object it carries +in its womb. + +=head2 $appender->layout($layout); + +The C<layout()> method sets the log layout +used by the appender to the format specified by the +C<Log::Log4perl::Layout::*> object which is passed to it as a reference. +Currently there's two layouts available: + + Log::Log4perl::Layout::SimpleLayout + Log::Log4perl::Layout::PatternLayout + +Please check the L<Log::Log4perl::Layout::SimpleLayout> and +L<Log::Log4perl::Layout::PatternLayout> manual pages for details. + +=head1 Supported Appenders + +Here's the list of appender modules currently available via C<Log::Dispatch>, +if not noted otherwise, written by Dave Rolsky: + + Log::Dispatch::ApacheLog + Log::Dispatch::DBI (by Tatsuhiko Miyagawa) + Log::Dispatch::Email, + Log::Dispatch::Email::MailSend, + Log::Dispatch::Email::MailSendmail, + Log::Dispatch::Email::MIMELite + Log::Dispatch::File + Log::Dispatch::FileRotate (by Mark Pfeiffer) + Log::Dispatch::Handle + Log::Dispatch::Screen + Log::Dispatch::Syslog + Log::Dispatch::Tk (by Dominique Dumont) + +C<Log4perl> doesn't care which ones you use, they're all handled in +the same way via the C<Log::Log4perl::Appender> interface. +Please check the well-written manual pages of the +C<Log::Dispatch> hierarchy on how to use each one of them. + +=head1 Parameters passed on to the appender's log() method + +When calling the appender's log()-Funktion, Log::Log4perl will +submit a list of key/value pairs. Entries to the following keys are +guaranteed to be present: + +=over 4 + +=item message + +Text of the rendered message + +=item log4p_category + +Name of the category of the logger that triggered the event. + +=item log4p_level + +Log::Log4perl level of the event + +=back + +=head1 Pitfalls + +Since the C<Log::Dispatch::File> appender truncates log files by default, +and most of the time this is I<not> what you want, we've instructed +C<Log::Log4perl> to change this behavior by slipping it the +C<mode =E<gt> append> parameter behind the scenes. So, effectively +with C<Log::Log4perl> 0.23, a configuration like + + log4perl.category = INFO, FileAppndr + log4perl.appender.FileAppndr = Log::Dispatch::File + log4perl.appender.FileAppndr.filename = test.log + log4perl.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout + +will always I<append> to an existing logfile C<test.log> while if you +specifically request clobbering like in + + log4perl.category = INFO, FileAppndr + log4perl.appender.FileAppndr = Log::Dispatch::File + log4perl.appender.FileAppndr.filename = test.log + log4perl.appender.FileAppndr.mode = write + log4perl.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout + +it will overwrite an existing log file C<test.log> and start from scratch. + +=head1 Appenders Expecting Message Chunks + +Instead of simple strings, certain appenders are expecting multiple fields +as log messages. If a statement like + + $logger->debug($ip, $user, "signed in"); + +causes an off-the-shelf C<Log::Log4perl::Appender::Screen> +appender to fire, the appender will +just concatenate the three message chunks passed to it +in order to form a single string. +The chunks will be separated by a string defined in +C<$Log::Log4perl::JOIN_MSG_ARRAY_CHAR> (defaults to the empty string +""). + +However, different appenders might choose to +interpret the message above differently: An +appender like C<Log::Log4perl::Appender::DBI> might take the +three arguments passed to the logger and put them in three separate +rows into the DB. + +The C<warp_message> appender option is used to specify the desired +behavior. +If no setting for the appender property + + # *** Not defined *** + # log4perl.appender.SomeApp.warp_message + +is defined in the Log4perl configuration file, the +appender referenced by C<SomeApp> will fall back to the standard behavior +and join all message chunks together, separating them by +C<$Log::Log4perl::JOIN_MSG_ARRAY_CHAR>. + +If, on the other hand, it is set to a false value, like in + + log4perl.appender.SomeApp.layout=NoopLayout + log4perl.appender.SomeApp.warp_message = 0 + +then the message chunks are passed unmodified to the appender as an +array reference. Please note that you need to set the appender's +layout to C<Log::Log4perl::Layout::NoopLayout> which just leaves +the messages chunks alone instead of formatting them or replacing +conversion specifiers. + +B<Please note that the standard appenders in the Log::Dispatch hierarchy +will choke on a bunch of messages passed to them as an array reference. +You can't use C<warp_message = 0> (or the function name syntax +defined below) on them. +Only special appenders like Log::Log4perl::Appender::DBI can deal with +this.> + +If (and now we're getting fancy) +an appender expects message chunks, but we would +like to pre-inspect and probably modify them before they're +actually passed to the appender's C<log> +method, an inspection subroutine can be defined with the +appender's C<warp_message> property: + + log4perl.appender.SomeApp.layout=NoopLayout + log4perl.appender.SomeApp.warp_message = sub { \ + $#_ = 2 if @_ > 3; \ + return @_; } + +The inspection subroutine defined by the C<warp_message> +property will receive the list of message chunks, like they were +passed to the logger and is expected to return a corrected list. +The example above simply limits the argument list to a maximum of +three by cutting off excess elements and returning the shortened list. + +Also, the warp function can be specified by name like in + + log4perl.appender.SomeApp.layout=NoopLayout + log4perl.appender.SomeApp.warp_message = main::filter_my_message + +In this example, +C<filter_my_message> is a function in the C<main> package, +defined like this: + + my $COUNTER = 0; + + sub filter_my_message { + my @chunks = @_; + unshift @chunks, ++$COUNTER; + return @chunks; + } + +The subroutine above will add an ever increasing counter +as an additional first field to +every message passed to the C<SomeApp> appender -- but not to +any other appender in the system. + +=head2 Composite Appenders + +Composite appenders relay their messages to sub-appenders after providing +some filtering or synchronizing functionality on incoming messages. +Examples are +Log::Log4perl::Appender::Synchronized, +Log::Log4perl::Appender::Limit, and +Log::Log4perl::Appender::Buffer. Check their manual pages for details. + +Composite appender objects are regular Log::Log4perl::Appender objects, +but they have the composite flag set: + + $app->composite(1); + +and they define a post_init() method, which sets the appender it relays +its messages to: + + ########################################### + sub post_init { + ############################################ + my($self) = @_; + + if(! exists $self->{appender}) { + die "No appender defined for " . __PACKAGE__; + } + + my $appenders = Log::Log4perl->appenders(); + my $appender = Log::Log4perl->appenders()->{$self->{appender}}; + + if(! defined $appender) { + die "Appender $self->{appender} not defined (yet) when " . + __PACKAGE__ . " needed it"; + } + + $self->{app} = $appender; + } + +The reason for this post-processing step is that the relay appender +might not be defined yet when the composite appender gets defined. +This can happen if Log4perl is initialized with a configuration file +(which is the most common way to initialize Log4perl), because +appenders spring into existence in unpredictable order. + +For example, if you define a Synchronized appender like + + log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized + log4perl.appender.Syncer.appender = Logfile + +then Log4perl will set the appender's C<appender> attribute to the +I<name> of the appender to finally relay messages to. After the +Log4perl configuration file has been processed, Log4perl will remember to +call the composite appender's post_init() method, which will grab +the relay appender instance referred to by the name (Logfile) +and set it in its C<app> attribute. This is exactly what the +code snippet above does. + +But if you initialize Log4perl by its API, you need to remember to +perform these steps. Here's the lineup: + + use Log::Log4perl qw(get_logger :levels); + + my $fileApp = Log::Log4perl::Appender->new( + 'Log::Log4perl::Appender::File', + name => 'MyFileApp', + filename => 'mylog', + mode => 'append', + ); + $fileApp->layout( + Log::Log4perl::Layout::PatternLayout::Multiline->new( + '%d{yyyy-MM-dd HH:mm:ss} %p [%c] #%P> %m%n') + ); + # Make the appender known to the system (without assigning it to + # any logger + Log::Log4perl->add_appender( $fileApp ); + + my $syncApp = Log::Log4perl::Appender->new( + 'Log::Log4perl::Appender::Synchronized', + name => 'MySyncApp', + appender => 'MyFileApp', + key => 'nem', + ); + $syncApp->post_init(); + $syncApp->composite(1); + + # The Synchronized appender is now ready, assign it to a logger + # and start logging. + get_logger("")->add_appender($syncApp); + + get_logger("")->level($DEBUG); + get_logger("wonk")->debug("waah!"); + +The composite appender's log() function will typically cache incoming +messages until a certain trigger condition is met and then forward a bulk +of messages to the relay appender. + +Caching messages is surprisingly tricky, because you want them to look +like they came from the code location they were originally issued from +and not from the location that triggers the flush. Luckily, Log4perl +offers a cache mechanism for messages, all you need to do is call the +base class' log() function with an additional reference to a scalar, +and then save its content to your composite appender's message buffer +afterwards: + + ########################################### + sub log { + ########################################### + my($self, %params) = @_; + + # ... some logic to decide whether to cache or flush + + # Adjust the caller stack + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 2; + + # We need to cache. + # Ask the appender to save a cached message in $cache + $self->{relay_app}->SUPER::log(\%params, + $params{log4p_category}, + $params{log4p_level}, \my $cache); + + # Save it in the appender's message buffer + push @{ $self->{buffer} }, $cache; + } + +Note that before calling the log() method of the relay appender's base class +(and thus introducing two additional levels on the call stack), we need to +adjust the call stack to allow Log4perl to render cspecs like the %M or %L +correctly. The cache will then contain a correctly rendered message, according +to the layout of the target appender. + +Later, when the time comes to flush the cached messages, a call to the relay +appender's base class' log_cached() method with the cached message as +an argument will forward the correctly rendered message: + + ########################################### + sub log { + ########################################### + my($self, %params) = @_; + + # ... some logic to decide whether to cache or flush + + # Flush pending messages if we have any + for my $cache (@{$self->{buffer}}) { + $self->{relay_app}->SUPER::log_cached($cache); + } + } + + +=head1 SEE ALSO + +Log::Dispatch + +=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. + diff --git a/lib/Log/Log4perl/Appender/Buffer.pm b/lib/Log/Log4perl/Appender/Buffer.pm new file mode 100644 index 0000000..9d6ccd5 --- /dev/null +++ b/lib/Log/Log4perl/Appender/Buffer.pm @@ -0,0 +1,279 @@ +###################################################################### +# Buffer.pm -- 2004, Mike Schilli <m@perlmeister.com> +###################################################################### +# Composite appender buffering messages until a trigger condition is met. +###################################################################### + +########################################### +package Log::Log4perl::Appender::Buffer; +########################################### + +use strict; +use warnings; + +our @ISA = qw(Log::Log4perl::Appender); + +our $CVSVERSION = '$Revision: 1.2 $'; +our ($VERSION) = ($CVSVERSION =~ /(\d+\.\d+)/); + +########################################### +sub new { +########################################### + my($class, %options) = @_; + + my $self = { + appender=> undef, + buffer => [], + options => { + max_messages => undef, + trigger => undef, + trigger_level => undef, + }, + level => 0, + %options, + }; + + if($self->{trigger_level}) { + $self->{trigger} = level_trigger($self->{trigger_level}); + } + + # Pass back the appender to be synchronized as a dependency + # to the configuration file parser + push @{$options{l4p_depends_on}}, $self->{appender}; + + # Run our post_init method in the configurator after + # all appenders have been defined to make sure the + # appender we're playing 'dam' for really exists + push @{$options{l4p_post_config_subs}}, sub { $self->post_init() }; + + bless $self, $class; +} + +########################################### +sub log { +########################################### + my($self, %params) = @_; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 2; + + # Do we need to discard a message because there's already + # max_size messages in the buffer? + if(defined $self->{max_messages} and + @{$self->{buffer}} == $self->{max_messages}) { + shift @{$self->{buffer}}; + } + # Ask the appender to save a cached message in $cache + $self->{app}->SUPER::log(\%params, + $params{log4p_category}, + $params{log4p_level}, \my $cache); + + # Save it in the appender's message buffer, but only if + # it hasn't been suppressed by an appender threshold + if( defined $cache ) { + push @{ $self->{buffer} }, $cache; + } + + $self->flush() if $self->{trigger}->($self, \%params); +} + +########################################### +sub flush { +########################################### + my($self) = @_; + + # Flush pending messages if we have any + for my $cache (@{$self->{buffer}}) { + $self->{app}->SUPER::log_cached($cache); + } + + # Empty buffer + $self->{buffer} = []; +} + +########################################### +sub post_init { +########################################### + my($self) = @_; + + if(! exists $self->{appender}) { + die "No appender defined for " . __PACKAGE__; + } + + my $appenders = Log::Log4perl->appenders(); + my $appender = Log::Log4perl->appenders()->{$self->{appender}}; + + if(! defined $appender) { + die "Appender $self->{appender} not defined (yet) when " . + __PACKAGE__ . " needed it"; + } + + $self->{app} = $appender; +} + +########################################### +sub level_trigger { +########################################### + my($level) = @_; + + # closure holding $level + return sub { + my($self, $params) = @_; + + return Log::Log4perl::Level::to_priority( + $params->{log4p_level}) >= + Log::Log4perl::Level::to_priority($level); + }; +} + +########################################### +sub DESTROY { +########################################### + my($self) = @_; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + + Log::Log4perl::Appender::Buffer - Buffering Appender + +=head1 SYNOPSIS + + use Log::Log4perl qw(:easy); + + my $conf = qq( + log4perl.category = DEBUG, Buffer + + # Regular Screen Appender + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.stdout = 1 + log4perl.appender.Screen.layout = PatternLayout + log4perl.appender.Screen.layout.ConversionPattern = %d %p %c %m %n + + # Buffering appender, using the appender above as outlet + log4perl.appender.Buffer = Log::Log4perl::Appender::Buffer + log4perl.appender.Buffer.appender = Screen + log4perl.appender.Buffer.trigger_level = ERROR + ); + + Log::Log4perl->init(\$conf); + + DEBUG("This message gets buffered."); + INFO("This message gets buffered also."); + + # Time passes. Nothing happens. But then ... + + print "It's GO time!!!\n"; + + ERROR("This message triggers a buffer flush."); + +=head1 DESCRIPTION + +C<Log::Log4perl::Appender::Buffer> takes these arguments: + +=over 4 + +=item C<appender> + +Specifies the name of the appender it buffers messages for. The +appender specified must be defined somewhere in the configuration file, +not necessarily before the definition of +C<Log::Log4perl::Appender::Buffer>. + +=item C<max_messages> + +Specifies the maximum number of messages the appender will hold in +its ring buffer. C<max_messages> is optional. By default, +C<Log::Log4perl::Appender::Buffer> will I<not> limit the number of +messages buffered. This might be undesirable in long-running processes +accumulating lots of messages before a flush happens. If +C<max_messages> is set to a numeric value, +C<Log::Log4perl::Appender::Buffer> will displace old messages in its +buffer to make room if the buffer is full. + +=item C<trigger_level> + +If trigger_level is set to one of Log4perl's levels (see +Log::Log4perl::Level), a C<trigger> function will be defined internally +to flush the buffer if a message with a priority of $level or higher +comes along. This is just a convenience function. Defining + + log4perl.appender.Buffer.trigger_level = ERROR + +is equivalent to creating a trigger function like + + log4perl.appender.Buffer.trigger = sub { \ + my($self, $params) = @_; \ + return $params->{log4p_level} >= \ + $Log::Log4perl::Level::ERROR; } + +See the next section for defining generic trigger functions. + +=item C<trigger> + +C<trigger> holds a reference to a subroutine, which +C<Log::Log4perl::Appender::Buffer> will call on every incoming message +with the same parameters as the appender's C<log()> method: + + my($self, $params) = @_; + +C<$params> references a hash containing +the message priority (key C<l4p_level>), the +message category (key C<l4p_category>) and the content of the message +(key C<message>). + +If the subroutine returns 1, it will trigger a flush of buffered messages. + +Shortcut + +=back + +=head1 DEVELOPMENT NOTES + +C<Log::Log4perl::Appender::Buffer> is a I<composite> appender. +Unlike other appenders, it doesn't log any messages, it just +passes them on to its attached sub-appender. +For this reason, it doesn't need a layout (contrary to regular appenders). +If it defines none, messages are passed on unaltered. + +Custom filters are also applied to the composite appender only. +They are I<not> applied to the sub-appender. Same applies to appender +thresholds. This behaviour might change in the future. + +=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. + diff --git a/lib/Log/Log4perl/Appender/DBI.pm b/lib/Log/Log4perl/Appender/DBI.pm new file mode 100644 index 0000000..e2043d3 --- /dev/null +++ b/lib/Log/Log4perl/Appender/DBI.pm @@ -0,0 +1,643 @@ +package Log::Log4perl::Appender::DBI; + +our @ISA = qw(Log::Log4perl::Appender); + +use Carp; + +use strict; +use DBI; + +sub new { + my($proto, %p) = @_; + my $class = ref $proto || $proto; + + my $self = bless {}, $class; + + $self->_init(%p); + + my %defaults = ( + reconnect_attempts => 1, + reconnect_sleep => 0, + ); + + for (keys %defaults) { + if(exists $p{$_}) { + $self->{$_} = $p{$_}; + } else { + $self->{$_} = $defaults{$_}; + } + } + + #e.g. + #log4j.appender.DBAppndr.params.1 = %p + #log4j.appender.DBAppndr.params.2 = %5.5m + foreach my $pnum (keys %{$p{params}}){ + $self->{bind_value_layouts}{$pnum} = + Log::Log4perl::Layout::PatternLayout->new({ + ConversionPattern => {value => $p{params}->{$pnum}}, + undef_column_value => undef, + }); + } + #'bind_value_layouts' now contains a PatternLayout + #for each parameter heading for the Sql engine + + $self->{SQL} = $p{sql}; #save for error msg later on + + $self->{MAX_COL_SIZE} = $p{max_col_size}; + + $self->{BUFFERSIZE} = $p{bufferSize} || 1; + + if ($p{usePreparedStmt}) { + $self->{sth} = $self->create_statement($p{sql}); + $self->{usePreparedStmt} = 1; + }else{ + $self->{layout} = Log::Log4perl::Layout::PatternLayout->new({ + ConversionPattern => {value => $p{sql}}, + undef_column_value => undef, + }); + } + + if ($self->{usePreparedStmt} && $self->{bufferSize}){ + warn "Log4perl: you've defined both usePreparedStmt and bufferSize \n". + "in your appender '$p{name}'--\n". + "I'm going to ignore bufferSize and just use a prepared stmt\n"; + } + + return $self; +} + + +sub _init { + my $self = shift; + my %params = @_; + + if ($params{dbh}) { + $self->{dbh} = $params{dbh}; + } else { + $self->{connect} = sub { + DBI->connect(@params{qw(datasource username password)}, + {PrintError => 0, $params{attrs} ? %{$params{attrs}} : ()}) + or croak "Log4perl: $DBI::errstr"; + }; + $self->{dbh} = $self->{connect}->(); + $self->{_mine} = 1; + } +} + +sub create_statement { + my ($self, $stmt) = @_; + + $stmt || croak "Log4perl: sql not set in Log4perl::Appender::DBI"; + + return $self->{dbh}->prepare($stmt) || croak "Log4perl: DBI->prepare failed $DBI::errstr\n$stmt"; + +} + + +sub log { + my $self = shift; + my %p = @_; + + #%p is + # { name => $appender_name, + # level => loglevel + # message => $message, + # log4p_category => $category, + # log4p_level => $level,); + # }, + + #getting log4j behavior with no specified ConversionPattern + chomp $p{message} unless ref $p{message}; + + + my $qmarks = $self->calculate_bind_values(\%p); + + + if ($self->{usePreparedStmt}) { + + $self->query_execute($self->{sth}, @$qmarks); + + }else{ + + #first expand any %x's in the statement + my $stmt = $self->{layout}->render( + $p{message}, + $p{log4p_category}, + $p{log4p_level}, + 5 + $Log::Log4perl::caller_depth, + ); + + push @{$self->{BUFFER}}, $stmt, $qmarks; + + $self->check_buffer(); + } +} + +sub query_execute { + my($self, $sth, @qmarks) = @_; + + my $errstr = "[no error]"; + + for my $attempt (0..$self->{reconnect_attempts}) { + #warn "Exe: @qmarks"; # TODO + if(! $sth->execute(@qmarks)) { + + # save errstr because ping() would override it [RT 56145] + $errstr = $self->{dbh}->errstr(); + + # Exe failed -- was it because we lost the DB + # connection? + if($self->{dbh}->ping()) { + # No, the connection is ok, we failed because there's + # something wrong with the execute(): Bad SQL or + # missing parameters or some such). Abort. + croak "Log4perl: DBI appender error: '$errstr'"; + } + + if($attempt == $self->{reconnect_attempts}) { + croak "Log4perl: DBI appender failed to " . + ($self->{reconnect_attempts} == 1 ? "" : "re") . + "connect " . + "to database after " . + "$self->{reconnect_attempts} attempt" . + ($self->{reconnect_attempts} == 1 ? "" : "s") . + " (last error error was [$errstr]"; + } + if(! $self->{dbh}->ping()) { + # Ping failed, try to reconnect + if($attempt) { + #warn "Sleeping"; # TODO + sleep($self->{reconnect_sleep}) if $self->{reconnect_sleep}; + } + + eval { + #warn "Reconnecting to DB"; # TODO + $self->{dbh} = $self->{connect}->(); + }; + } + + if ($self->{usePreparedStmt}) { + $sth = $self->create_statement($self->{SQL}); + $self->{sth} = $sth if $self->{sth}; + } else { + #warn "Pending stmt: $self->{pending_stmt}"; #TODO + $sth = $self->create_statement($self->{pending_stmt}); + } + + next; + } + return 1; + } + croak "Log4perl: DBI->execute failed $errstr, \n". + "on $self->{SQL}\n @qmarks"; +} + +sub calculate_bind_values { + my ($self, $p) = @_; + + my @qmarks; + my $user_ph_idx = 0; + + my $i=0; + + if ($self->{bind_value_layouts}) { + + my $prev_pnum = 0; + my $max_pnum = 0; + + my @pnums = sort {$a <=> $b} keys %{$self->{bind_value_layouts}}; + $max_pnum = $pnums[-1]; + + #Walk through the integers for each possible bind value. + #If it doesn't have a layout assigned from the config file + #then shift it off the array from the $log call + #This needs to be reworked now that we always get an arrayref? --kg 1/2003 + foreach my $pnum (1..$max_pnum){ + my $msg; + + #we've got a bind_value_layout to fill the spot + if ($self->{bind_value_layouts}{$pnum}){ + $msg = $self->{bind_value_layouts}{$pnum}->render( + $p->{message}, + $p->{log4p_category}, + $p->{log4p_level}, + 5 + $Log::Log4perl::caller_depth, + ); + + #we don't have a bind_value_layout, so get + #a message bit + }elsif (ref $p->{message} eq 'ARRAY' && @{$p->{message}}){ + #$msg = shift @{$p->{message}}; + $msg = $p->{message}->[$i++]; + + #here handle cases where we ran out of message bits + #before we ran out of bind_value_layouts, just keep going + }elsif (ref $p->{message} eq 'ARRAY'){ + $msg = undef; + $p->{message} = undef; + + #here handle cases where we didn't get an arrayref + #log the message in the first placeholder and nothing in the rest + }elsif (! ref $p->{message} ){ + $msg = $p->{message}; + $p->{message} = undef; + + } + + if ($self->{MAX_COL_SIZE} && + length($msg) > $self->{MAX_COL_SIZE}){ + substr($msg, $self->{MAX_COL_SIZE}) = ''; + } + push @qmarks, $msg; + } + } + + #handle leftovers + if (ref $p->{message} eq 'ARRAY' && @{$p->{message}} ) { + #push @qmarks, @{$p->{message}}; + push @qmarks, @{$p->{message}}[$i..@{$p->{message}}-1]; + + } + + return \@qmarks; +} + + +sub check_buffer { + my $self = shift; + + return unless ($self->{BUFFER} && ref $self->{BUFFER} eq 'ARRAY'); + + if (scalar @{$self->{BUFFER}} >= $self->{BUFFERSIZE} * 2) { + + my ($sth, $stmt, $prev_stmt); + + $prev_stmt = ""; # Init to avoid warning (ms 5/10/03) + + while (@{$self->{BUFFER}}) { + my ($stmt, $qmarks) = splice (@{$self->{BUFFER}},0,2); + + $self->{pending_stmt} = $stmt; + + #reuse the sth if the stmt doesn't change + if ($stmt ne $prev_stmt) { + $sth->finish if $sth; + $sth = $self->create_statement($stmt); + } + + $self->query_execute($sth, @$qmarks); + + $prev_stmt = $stmt; + + } + + $sth->finish; + + my $dbh = $self->{dbh}; + + if ($dbh && ! $dbh->{AutoCommit}) { + $dbh->commit; + } + } +} + +sub DESTROY { + my $self = shift; + + $self->{BUFFERSIZE} = 1; + + $self->check_buffer(); + + if ($self->{_mine} && $self->{dbh}) { + $self->{dbh}->disconnect; + } +} + + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::DBI - implements appending to a DB + +=head1 SYNOPSIS + + my $config = q{ + log4j.category = WARN, DBAppndr + log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI + log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp + log4j.appender.DBAppndr.username = bobjones + log4j.appender.DBAppndr.password = 12345 + log4j.appender.DBAppndr.sql = \ + insert into log4perltest \ + (loglevel, custid, category, message, ipaddr) \ + values (?,?,?,?,?) + log4j.appender.DBAppndr.params.1 = %p + #2 is custid from the log() call + log4j.appender.DBAppndr.params.3 = %c + #4 is the message from log() + #5 is ipaddr from log() + + log4j.appender.DBAppndr.usePreparedStmt = 1 + #--or-- + log4j.appender.DBAppndr.bufferSize = 2 + + #just pass through the array of message items in the log statement + log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + log4j.appender.DBAppndr.warp_message = 0 + + #driver attributes support + log4j.appender.DBAppndr.attrs.f_encoding = utf8 + }; + + $logger->warn( $custid, 'big problem!!', $ip_addr ); + +=head1 CAVEAT + +This is a very young module and there are a lot of variations +in setups with different databases and connection methods, +so make sure you test thoroughly! Any feedback is welcome! + +=head1 DESCRIPTION + +This is a specialized Log::Dispatch object customized to work with +log4perl and its abilities, originally based on Log::Dispatch::DBI +by Tatsuhiko Miyagawa but with heavy modifications. + +It is an attempted compromise between what Log::Dispatch::DBI was +doing and what log4j's JDBCAppender does. Note the log4j docs say +the JDBCAppender "is very likely to be completely replaced in the future." + +The simplest usage is this: + + log4j.category = WARN, DBAppndr + log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI + log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp + log4j.appender.DBAppndr.username = bobjones + log4j.appender.DBAppndr.password = 12345 + log4j.appender.DBAppndr.sql = \ + INSERT INTO logtbl \ + (loglevel, message) \ + VALUES ('%c','%m') + + log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::PatternLayout + + + $logger->fatal('fatal message'); + $logger->warn('warning message'); + + =============================== + |FATAL|fatal message | + |WARN |warning message | + =============================== + + +But the downsides to that usage are: + +=over 4 + +=item * + +You'd better be darn sure there are not quotes in your log message, or your +insert could have unforeseen consequences! This is a very insecure way to +handle database inserts, using place holders and bind values is much better, +keep reading. (Note that the log4j docs warn "Be careful of quotes in your +messages!") B<*>. + +=item * + +It's not terribly high-performance, a statement is created and executed +for each log call. + +=item * + +The only run-time parameter you get is the %m message, in reality +you probably want to log specific data in specific table columns. + +=back + +So let's try using placeholders, and tell the logger to create a +prepared statement handle at the beginning and just reuse it +(just like Log::Dispatch::DBI does) + + + log4j.appender.DBAppndr.sql = \ + INSERT INTO logtbl \ + (custid, loglevel, message) \ + VALUES (?,?,?) + + #--------------------------------------------------- + #now the bind values: + #1 is the custid + log4j.appender.DBAppndr.params.2 = %p + #3 is the message + #--------------------------------------------------- + + log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + log4j.appender.DBAppndr.warp_message = 0 + + log4j.appender.DBAppndr.usePreparedStmt = 1 + + + $logger->warn( 1234, 'warning message' ); + + +Now see how we're using the '?' placeholders in our statement? This +means we don't have to worry about messages that look like + + invalid input: 1234';drop table custid; + +fubaring our database! + +Normally a list of things in the logging statement gets concatenated into +a single string, but setting C<warp_message> to 0 and using the +NoopLayout means that in + + $logger->warn( 1234, 'warning message', 'bgates' ); + +the individual list values will still be available for the DBI appender later +on. (If C<warp_message> is not set to 0, the default behavior is to +join the list elements into a single string. If PatternLayout or SimpleLayout +are used, their attempt to C<render()> your layout will result in something +like "ARRAY(0x841d8dc)" in your logs. More information on C<warp_message> +is in Log::Log4perl::Appender.) + +In your insert SQL you can mix up '?' placeholders with conversion specifiers +(%c, %p, etc) as you see fit--the logger will match the question marks to +params you've defined in the config file and populate the rest with values +from your list. If there are more '?' placeholders than there are values in +your message, it will use undef for the rest. For instance, + + log4j.appender.DBAppndr.sql = \ + insert into log4perltest \ + (loglevel, message, datestr, subpoena_id)\ + values (?,?,?,?) + log4j.appender.DBAppndr.params.1 = %p + log4j.appender.DBAppndr.params.3 = %d + + log4j.appender.DBAppndr.warp_message=0 + + + $logger->info('arrest him!', $subpoena_id); + +results in the first '?' placeholder being bound to %p, the second to +"arrest him!", the third to the date from "%d", and the fourth to your +$subpoenaid. If you forget the $subpoena_id and just log + + $logger->info('arrest him!'); + +then you just get undef in the fourth column. + + +If the logger statement is also being handled by other non-DBI appenders, +they will just join the list into a string, joined with +C<$Log::Log4perl::JOIN_MSG_ARRAY_CHAR> (default is an empty string). + +And see the C<usePreparedStmt>? That creates a statement handle when +the logger object is created and just reuses it. That, however, may +be problematic for long-running processes like webservers, in which case +you can use this parameter instead + + log4j.appender.DBAppndr.bufferSize=2 + +This copies log4j's JDBCAppender's behavior, it saves up that many +log statements and writes them all out at once. If your INSERT +statement uses only ? placeholders and no %x conversion specifiers +it should be quite efficient because the logger can re-use the +same statement handle for the inserts. + +If the program ends while the buffer is only partly full, the DESTROY +block should flush the remaining statements, if the DESTROY block +runs of course. + +* I<As I was writing this, Danko Mannhaupt was coming out with his +improved log4j JDBCAppender (http://www.mannhaupt.com/danko/projects/) +which overcomes many of the drawbacks of the original JDBCAppender.> + +=head1 DESCRIPTION 2 + +Or another way to say the same thing: + +The idea is that if you're logging to a database table, you probably +want specific parts of your log information in certain columns. To this +end, you pass an list to the log statement, like + + $logger->warn('big problem!!',$userid,$subpoena_nr,$ip_addr); + +and the array members drop into the positions defined by the placeholders +in your SQL statement. You can also define information in the config +file like + + log4j.appender.DBAppndr.params.2 = %p + +in which case those numbered placeholders will be filled in with +the specified values, and the rest of the placeholders will be +filled in with the values from your log statement's array. + +=head1 MISC PARAMETERS + + +=over 4 + +=item usePreparedStmt + +See above. + +=item warp_message + +see Log::Log4perl::Appender + +=item max_col_size + +If you're used to just throwing debugging messages like huge stacktraces +into your logger, some databases (Sybase's DBD!!) may surprise you +by choking on data size limitations. Normally, the data would +just be truncated to fit in the column, but Sybases's DBD it turns out +maxes out at 255 characters. Use this parameter in such a situation +to truncate long messages before they get to the INSERT statement. + +=back + +=head1 CHANGING DBH CONNECTIONS (POOLING) + +If you want to get your dbh from some place in particular, like +maybe a pool, subclass and override _init() and/or create_statement(), +for instance + + sub _init { + ; #no-op, no pooling at this level + } + sub create_statement { + my ($self, $stmt) = @_; + + $stmt || croak "Log4perl: sql not set in ".__PACKAGE__; + + return My::Connections->getConnection->prepare($stmt) + || croak "Log4perl: DBI->prepare failed $DBI::errstr\n$stmt"; + } + + +=head1 LIFE OF CONNECTIONS + +If you're using C<log4j.appender.DBAppndr.usePreparedStmt> +this module creates an sth when it starts and keeps it for the life +of the program. For long-running processes (e.g. mod_perl), connections +might go stale, but if C<Log::Log4perl::Appender::DBI> tries to write +a message and figures out that the DB connection is no longer working +(using DBI's ping method), it will reconnect. + +The reconnection process can be controlled by two parameters, +C<reconnect_attempts> and C<reconnect_sleep>. C<reconnect_attempts> +specifies the number of reconnections attempts the DBI appender +performs until it gives up and dies. C<reconnect_sleep> is the +time between reconnection attempts, measured in seconds. +C<reconnect_attempts> defaults to 1, C<reconnect_sleep> to 0. + +Alternatively, use C<Apache::DBI> or C<Apache::DBI::Cache> and read +CHANGING DB CONNECTIONS above. + +Note that C<Log::Log4perl::Appender::DBI> holds one connection open +for every appender, which might be too many. + +=head1 SEE ALSO + +L<Log::Dispatch::DBI> + +L<Log::Log4perl::JavaMap::JDBCAppender> + +=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. + diff --git a/lib/Log/Log4perl/Appender/File.pm b/lib/Log/Log4perl/Appender/File.pm new file mode 100755 index 0000000..484f416 --- /dev/null +++ b/lib/Log/Log4perl/Appender/File.pm @@ -0,0 +1,545 @@ +################################################## +package Log::Log4perl::Appender::File; +################################################## + +our @ISA = qw(Log::Log4perl::Appender); + +use warnings; +use strict; +use Log::Log4perl::Config::Watch; +use Fcntl; +use File::Path; +use File::Spec::Functions qw(splitpath); +use constant _INTERNAL_DEBUG => 0; + +################################################## +sub new { +################################################## + my($class, @options) = @_; + + my $self = { + name => "unknown name", + umask => undef, + owner => undef, + group => undef, + autoflush => 1, + syswrite => 0, + mode => "append", + binmode => undef, + utf8 => undef, + recreate => 0, + recreate_check_interval => 30, + recreate_check_signal => undef, + recreate_pid_write => undef, + create_at_logtime => 0, + header_text => undef, + mkpath => 0, + mkpath_umask => 0, + @options, + }; + + if($self->{create_at_logtime}) { + $self->{recreate} = 1; + } + for my $param ('umask', 'mkpath_umask') { + if(defined $self->{$param} and $self->{$param} =~ /^0/) { + # umask value is a string, meant to be an oct value + $self->{$param} = oct($self->{$param}); + } + } + + die "Mandatory parameter 'filename' missing" unless + exists $self->{filename}; + + bless $self, $class; + + if($self->{recreate_pid_write}) { + print "Creating pid file", + " $self->{recreate_pid_write}\n" if _INTERNAL_DEBUG; + open FILE, ">$self->{recreate_pid_write}" or + die "Cannot open $self->{recreate_pid_write}"; + print FILE "$$\n"; + close FILE; + } + + # This will die() if it fails + $self->file_open() unless $self->{create_at_logtime}; + + return $self; +} + +################################################## +sub filename { +################################################## + my($self) = @_; + + return $self->{filename}; +} + +################################################## +sub file_open { +################################################## + my($self) = @_; + + my $arrows = ">"; + my $sysmode = (O_CREAT|O_WRONLY); + + + if($self->{mode} eq "append") { + $arrows = ">>"; + $sysmode |= O_APPEND; + } elsif ($self->{mode} eq "pipe") { + $arrows = "|"; + } else { + $sysmode |= O_TRUNC; + } + + my $fh = do { local *FH; *FH; }; + + + my $didnt_exist = ! -e $self->{filename}; + if($didnt_exist && $self->{mkpath}) { + my ($volume, $path, $file) = splitpath($self->{filename}); + if($path ne '' && !-e $path) { + my $old_umask = umask($self->{mkpath_umask}) if defined $self->{mkpath_umask}; + my $options = {}; + foreach my $param (qw(owner group) ) { + $options->{$param} = $self->{$param} if defined $self->{$param}; + } + eval { + mkpath($path,$options); + }; + umask($old_umask) if defined $old_umask; + die "Can't create path ${path} ($!)" if $@; + } + } + + my $old_umask = umask($self->{umask}) if defined $self->{umask}; + + eval { + if($self->{syswrite}) { + sysopen $fh, "$self->{filename}", $sysmode or + die "Can't sysopen $self->{filename} ($!)"; + } else { + open $fh, "$arrows$self->{filename}" or + die "Can't open $self->{filename} ($!)"; + } + }; + umask($old_umask) if defined $old_umask; + die $@ if $@; + + if($didnt_exist and + ( defined $self->{owner} or defined $self->{group} ) + ) { + + eval { $self->perms_fix() }; + + if($@) { + # Cleanup and re-throw + unlink $self->{filename}; + die $@; + } + } + + if($self->{recreate}) { + $self->{watcher} = Log::Log4perl::Config::Watch->new( + file => $self->{filename}, + (defined $self->{recreate_check_interval} ? + (check_interval => $self->{recreate_check_interval}) : ()), + (defined $self->{recreate_check_signal} ? + (signal => $self->{recreate_check_signal}) : ()), + ); + } + + $self->{fh} = $fh; + + if ($self->{autoflush} and ! $self->{syswrite}) { + my $oldfh = select $self->{fh}; + $| = 1; + select $oldfh; + } + + if (defined $self->{binmode}) { + binmode $self->{fh}, $self->{binmode}; + } + + if (defined $self->{utf8}) { + binmode $self->{fh}, ":utf8"; + } + + if(defined $self->{header_text}) { + if( $self->{header_text} !~ /\n\Z/ ) { + $self->{header_text} .= "\n"; + } + my $fh = $self->{fh}; + print $fh $self->{header_text}; + } +} + +################################################## +sub file_close { +################################################## + my($self) = @_; + + if(defined $self->{fh}) { + $self->close_with_care( $self->{ fh } ); + } + + undef $self->{fh}; +} + +################################################## +sub perms_fix { +################################################## + my($self) = @_; + + my ($uid_org, $gid_org) = (stat $self->{filename})[4,5]; + + my ($uid, $gid) = ($uid_org, $gid_org); + + if(!defined $uid) { + die "stat of $self->{filename} failed ($!)"; + } + + my $needs_fixing = 0; + + if(defined $self->{owner}) { + $uid = $self->{owner}; + if($self->{owner} !~ /^\d+$/) { + $uid = (getpwnam($self->{owner}))[2]; + die "Unknown user: $self->{owner}" unless defined $uid; + } + } + + if(defined $self->{group}) { + $gid = $self->{group}; + if($self->{group} !~ /^\d+$/) { + $gid = getgrnam($self->{group}); + + die "Unknown group: $self->{group}" unless defined $gid; + } + } + if($uid != $uid_org or $gid != $gid_org) { + chown($uid, $gid, $self->{filename}) or + die "chown('$uid', '$gid') on '$self->{filename}' failed: $!"; + } +} + +################################################## +sub file_switch { +################################################## + my($self, $new_filename) = @_; + + print "Switching file from $self->{filename} to $new_filename\n" if + _INTERNAL_DEBUG; + + $self->file_close(); + $self->{filename} = $new_filename; + $self->file_open(); +} + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + if($self->{recreate}) { + if($self->{recreate_check_signal}) { + if(!$self->{watcher} or + $self->{watcher}->{signal_caught}) { + $self->file_switch($self->{filename}); + $self->{watcher}->{signal_caught} = 0; + } + } else { + if(!$self->{watcher} or + $self->{watcher}->file_has_moved()) { + $self->file_switch($self->{filename}); + } + } + } + + my $fh = $self->{fh}; + + if($self->{syswrite}) { + defined (syswrite $fh, $params{message}) or + die "Cannot syswrite to '$self->{filename}': $!"; + } else { + print $fh $params{message} or + die "Cannot write to '$self->{filename}': $!"; + } +} + +################################################## +sub DESTROY { +################################################## + my($self) = @_; + + if ($self->{fh}) { + my $fh = $self->{fh}; + $self->close_with_care( $fh ); + } +} + +########################################### +sub close_with_care { +########################################### + my( $self, $fh ) = @_; + + my $prev_rc = $?; + + my $rc = close $fh; + + # [rt #84723] If a sig handler is reaping the child generated + # by close() internally before close() gets to it, it'll + # result in a weird (but benign) error that we don't want to + # expose to the user. + if( !$rc ) { + if( $self->{ mode } eq "pipe" and + $!{ ECHILD } ) { + if( $Log::Log4perl::CHATTY_DESTROY_METHODS ) { + warn "$$: pipe closed with ECHILD error -- guess that's ok"; + } + $? = $prev_rc; + } else { + warn "Can't close $self->{filename} ($!)"; + } + } + + return $rc; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::File - Log to file + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::File; + + my $app = Log::Log4perl::Appender::File->new( + filename => 'file.log', + mode => 'append', + autoflush => 1, + umask => 0222, + ); + + $file->log(message => "Log me\n"); + +=head1 DESCRIPTION + +This is a simple appender for writing to a file. + +The C<log()> method takes a single scalar. If a newline character +should terminate the message, it has to be added explicitly. + +Upon destruction of the object, the filehandle to access the +file is flushed and closed. + +If you want to switch over to a different logfile, use the +C<file_switch($newfile)> method which will first close the old +file handle and then open a one to the new file specified. + +=head2 OPTIONS + +=over 4 + +=item filename + +Name of the log file. + +=item mode + +Messages will be append to the file if C<$mode> is set to the +string C<"append">. Will clobber the file +if set to C<"clobber">. If it is C<"pipe">, the file will be understood +as executable to pipe output to. Default mode is C<"append">. + +=item autoflush + +C<autoflush>, if set to a true value, triggers flushing the data +out to the file on every call to C<log()>. C<autoflush> is on by default. + +=item syswrite + +C<syswrite>, if set to a true value, makes sure that the appender uses +syswrite() instead of print() to log the message. C<syswrite()> usually +maps to the operating system's C<write()> function and makes sure that +no other process writes to the same log file while C<write()> is busy. +Might safe you from having to use other synchronisation measures like +semaphores (see: Synchronized appender). + +=item umask + +Specifies the C<umask> to use when creating the file, determining +the file's permission settings. +If set to C<0022> (default), new +files will be created with C<rw-r--r--> permissions. +If set to C<0000>, new files will be created with C<rw-rw-rw-> permissions. + +=item owner + +If set, specifies that the owner of the newly created log file should +be different from the effective user id of the running process. +Only makes sense if the process is running as root. +Both numerical user ids and user names are acceptable. +Log4perl does not attempt to change the ownership of I<existing> files. + +=item group + +If set, specifies that the group of the newly created log file should +be different from the effective group id of the running process. +Only makes sense if the process is running as root. +Both numerical group ids and group names are acceptable. +Log4perl does not attempt to change the group membership of I<existing> files. + +=item utf8 + +If you're printing out Unicode strings, the output filehandle needs +to be set into C<:utf8> mode: + + my $app = Log::Log4perl::Appender::File->new( + filename => 'file.log', + mode => 'append', + utf8 => 1, + ); + +=item binmode + +To manipulate the output filehandle via C<binmode()>, use the +binmode parameter: + + my $app = Log::Log4perl::Appender::File->new( + filename => 'file.log', + mode => 'append', + binmode => ":utf8", + ); + +A setting of ":utf8" for C<binmode> is equivalent to specifying +the C<utf8> option (see above). + +=item recreate + +Normally, if a file appender logs to a file and the file gets moved to +a different location (e.g. via C<mv>), the appender's open file handle +will automatically follow the file to the new location. + +This may be undesirable. When using an external logfile rotator, +for example, the appender should create a new file under the old name +and start logging into it. If the C<recreate> option is set to a true value, +C<Log::Log4perl::Appender::File> will do exactly that. It defaults to +false. Check the C<recreate_check_interval> option for performance +optimizations with this feature. + +=item recreate_check_interval + +In C<recreate> mode, the appender has to continuously check if the +file it is logging to is still in the same location. This check is +fairly expensive, since it has to call C<stat> on the file name and +figure out if its inode has changed. Doing this with every call +to C<log> can be prohibitively expensive. Setting it to a positive +integer value N will only check the file every N seconds. It defaults to 30. + +This obviously means that the appender will continue writing to +a moved file until the next check occurs, in the worst case +this will happen C<recreate_check_interval> seconds after the file +has been moved or deleted. If this is undesirable, +setting C<recreate_check_interval> to 0 will have the +appender check the file with I<every> call to C<log()>. + +=item recreate_check_signal + +In C<recreate> mode, if this option is set to a signal name +(e.g. "USR1"), the appender will recreate a missing logfile +when it receives the signal. It uses less resources than constant +polling. The usual limitation with perl's signal handling apply. +Check the FAQ for using this option with the log rotating +utility C<newsyslog>. + +=item recreate_pid_write + +The popular log rotating utility C<newsyslog> expects a pid file +in order to send the application a signal when its logs have +been rotated. This option expects a path to a file where the pid +of the currently running application gets written to. +Check the FAQ for using this option with the log rotating +utility C<newsyslog>. + +=item create_at_logtime + +The file appender typically creates its logfile in its constructor, i.e. +at Log4perl C<init()> time. This is desirable for most use cases, because +it makes sure that file permission problems get detected right away, and +not after days/weeks/months of operation when the appender suddenly needs +to log something and fails because of a problem that was obvious at +startup. + +However, there are rare use cases where the file shouldn't be created +at Log4perl C<init()> time, e.g. if the appender can't be used by the current +user although it is defined in the configuration file. If you set +C<create_at_logtime> to a true value, the file appender will try to create +the file at log time. Note that this setting lets permission problems +sit undetected until log time, which might be undesirable. + +=item header_text + +If you want Log4perl to print a header into every newly opened +(or re-opened) logfile, set C<header_text> to either a string +or a subroutine returning a string. If the message doesn't have a newline, +a newline at the end of the header will be provided. + +=item mkpath + +If this this option is set to true, +the directory path will be created if it does not exist yet. + +=item mkpath_umask + +Specifies the C<umask> to use when creating the directory, determining +the directory's permission settings. +If set to C<0022> (default), new +directory will be created with C<rwxr-xr-x> permissions. +If set to C<0000>, new directory will be created with C<rwxrwxrwx> permissions. + +=back + +Design and implementation of this module has been greatly inspired by +Dave Rolsky's C<Log::Dispatch> appender framework. + +=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. + diff --git a/lib/Log/Log4perl/Appender/Limit.pm b/lib/Log/Log4perl/Appender/Limit.pm new file mode 100644 index 0000000..8c55907 --- /dev/null +++ b/lib/Log/Log4perl/Appender/Limit.pm @@ -0,0 +1,340 @@ +###################################################################### +# Limit.pm -- 2003, Mike Schilli <m@perlmeister.com> +###################################################################### +# Special composite appender limiting the number of messages relayed +# to its appender(s). +###################################################################### + +########################################### +package Log::Log4perl::Appender::Limit; +########################################### + +use strict; +use warnings; +use Storable; + +our @ISA = qw(Log::Log4perl::Appender); + +our $CVSVERSION = '$Revision: 1.7 $'; +our ($VERSION) = ($CVSVERSION =~ /(\d+\.\d+)/); + +########################################### +sub new { +########################################### + my($class, %options) = @_; + + my $self = { + max_until_flushed => undef, + max_until_discarded => undef, + appender_method_on_flush + => undef, + appender => undef, + accumulate => 1, + persistent => undef, + block_period => 3600, + buffer => [], + %options, + }; + + # Pass back the appender to be limited as a dependency + # to the configuration file parser + push @{$options{l4p_depends_on}}, $self->{appender}; + + # Run our post_init method in the configurator after + # all appenders have been defined to make sure the + # appenders we're connecting to really exist. + push @{$options{l4p_post_config_subs}}, sub { $self->post_init() }; + + bless $self, $class; + + if(defined $self->{persistent}) { + $self->restore(); + } + + return $self; +} + +########################################### +sub log { +########################################### + my($self, %params) = @_; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 2; + + # Check if message needs to be discarded + my $discard = 0; + if(defined $self->{max_until_discarded} and + scalar @{$self->{buffer}} >= $self->{max_until_discarded} - 1) { + $discard = 1; + } + + # Check if we need to flush + my $flush = 0; + if(defined $self->{max_until_flushed} and + scalar @{$self->{buffer}} >= $self->{max_until_flushed} - 1) { + $flush = 1; + } + + if(!$flush and + (exists $self->{sent_last} and + $self->{sent_last} + $self->{block_period} > time() + ) + ) { + # Message needs to be blocked for now. + return if $discard; + + # Ask the appender to save a cached message in $cache + $self->{app}->SUPER::log(\%params, + $params{log4p_category}, + $params{log4p_level}, \my $cache); + + # Save message and other parameters + push @{$self->{buffer}}, $cache if $self->{accumulate}; + + $self->save() if $self->{persistent}; + + return; + } + + # Relay all messages we got to the SUPER class, which needs to render the + # messages according to the appender's layout, first. + + # Log pending messages if we have any + $self->flush(); + + # Log current message as well + $self->{app}->SUPER::log(\%params, + $params{log4p_category}, + $params{log4p_level}); + + $self->{sent_last} = time(); + + # We need to store the timestamp persistently, if requested + $self->save() if $self->{persistent}; +} + +########################################### +sub post_init { +########################################### + my($self) = @_; + + if(! exists $self->{appender}) { + die "No appender defined for " . __PACKAGE__; + } + + my $appenders = Log::Log4perl->appenders(); + my $appender = Log::Log4perl->appenders()->{$self->{appender}}; + + if(! defined $appender) { + die "Appender $self->{appender} not defined (yet) when " . + __PACKAGE__ . " needed it"; + } + + $self->{app} = $appender; +} + +########################################### +sub save { +########################################### + my($self) = @_; + + my $pdata = [$self->{buffer}, $self->{sent_last}]; + + # Save the buffer if we're in persistent mode + store $pdata, $self->{persistent} or + die "Cannot save messages in $self->{persistent} ($!)"; +} + +########################################### +sub restore { +########################################### + my($self) = @_; + + if(-f $self->{persistent}) { + my $pdata = retrieve $self->{persistent} or + die "Cannot retrieve messages from $self->{persistent} ($!)"; + ($self->{buffer}, $self->{sent_last}) = @$pdata; + } +} + +########################################### +sub flush { +########################################### + my($self) = @_; + + # Log pending messages if we have any + for(@{$self->{buffer}}) { + $self->{app}->SUPER::log_cached($_); + } + + # call flush() on the attached appender if so desired. + if( $self->{appender_method_on_flush} ) { + no strict 'refs'; + my $method = $self->{appender_method_on_flush}; + $self->{app}->$method(); + } + + # Empty buffer + $self->{buffer} = []; +} + +########################################### +sub DESTROY { +########################################### + my($self) = @_; + +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + + Log::Log4perl::Appender::Limit - Limit message delivery via block period + +=head1 SYNOPSIS + + use Log::Log4perl qw(:easy); + + my $conf = qq( + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Mailer = Log::Dispatch::Email::MailSend + log4perl.appender.Mailer.to = drone\@pageme.com + log4perl.appender.Mailer.subject = Something's broken! + log4perl.appender.Mailer.buffered = 0 + log4perl.appender.Mailer.layout = PatternLayout + log4perl.appender.Mailer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Mailer + log4perl.appender.Limiter.block_period = 3600 + ); + + Log::Log4perl->init(\$conf); + WARN("This message will be sent immediately."); + WARN("This message will be delayed by one hour."); + sleep(3601); + WARN("This message plus the last one will be sent now, seperately."); + +=head1 DESCRIPTION + +=over 4 + +=item C<appender> + +Specifies the name of the appender used by the limiter. The +appender specified must be defined somewhere in the configuration file, +not necessarily before the definition of +C<Log::Log4perl::Appender::Limit>. + +=item C<block_period> + +Period in seconds between delivery of messages. If messages arrive in between, +they will be either saved (if C<accumulate> is set to a true value) or +discarded (if C<accumulate> isn't set). + +=item C<persistent> + +File name in which C<Log::Log4perl::Appender::Limit> persistently stores +delivery times. If omitted, the appender will have no recollection of what +happened when the program restarts. + +=item C<max_until_flushed> + +Maximum number of accumulated messages. If exceeded, the appender flushes +all messages, regardless if the interval set in C<block_period> +has passed or not. Don't mix with C<max_until_discarded>. + +=item C<max_until_discarded> + +Maximum number of accumulated messages. If exceeded, the appender will +simply discard additional messages, waiting for C<block_period> to expire +to flush all accumulated messages. Don't mix with C<max_until_flushed>. + +=item C<appender_method_on_flush> + +Optional method name to be called on the appender attached to the +limiter when messages are flushed. For example, to have the sample code +in the SYNOPSIS section bundle buffered emails into one, change the +mailer's C<buffered> parameter to C<1> and set the limiters +C<appender_method_on_flush> value to the string C<"flush">: + + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Mailer = Log::Dispatch::Email::MailSend + log4perl.appender.Mailer.to = drone\@pageme.com + log4perl.appender.Mailer.subject = Something's broken! + log4perl.appender.Mailer.buffered = 1 + log4perl.appender.Mailer.layout = PatternLayout + log4perl.appender.Mailer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Mailer + log4perl.appender.Limiter.block_period = 3600 + log4perl.appender.Limiter.appender_method_on_flush = flush + +This will cause the mailer to buffer messages and wait for C<flush()> +to send out the whole batch. The limiter will then call the appender's +C<flush()> method when it's own buffer gets flushed out. + +=back + +If the appender attached to C<Limit> uses C<PatternLayout> with a timestamp +specifier, you will notice that the message timestamps are reflecting the +original log event, not the time of the message rendering in the +attached appender. Major trickery has been applied to accomplish +this (Cough!). + +=head1 DEVELOPMENT NOTES + +C<Log::Log4perl::Appender::Limit> is a I<composite> appender. +Unlike other appenders, it doesn't log any messages, it just +passes them on to its attached sub-appender. +For this reason, it doesn't need a layout (contrary to regular appenders). +If it defines none, messages are passed on unaltered. + +Custom filters are also applied to the composite appender only. +They are I<not> applied to the sub-appender. Same applies to appender +thresholds. This behaviour might change in the future. + +=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. + diff --git a/lib/Log/Log4perl/Appender/RRDs.pm b/lib/Log/Log4perl/Appender/RRDs.pm new file mode 100755 index 0000000..62fa793 --- /dev/null +++ b/lib/Log/Log4perl/Appender/RRDs.pm @@ -0,0 +1,134 @@ +################################################## +package Log::Log4perl::Appender::RRDs; +################################################## +our @ISA = qw(Log::Log4perl::Appender); + +use warnings; +use strict; +use RRDs; + +################################################## +sub new { +################################################## + my($class, @options) = @_; + + my $self = { + name => "unknown name", + dbname => undef, + rrdupd_params => [], + @options, + }; + + die "Mandatory parameter 'dbname' missing" unless + defined $self->{dbname}; + + bless $self, $class; + + return $self; +} + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + #print "UPDATE: '$self->{dbname}' - '$params{message}'\n"; + + RRDs::update($self->{dbname}, + @{$params{rrdupd_params}}, + $params{message}) or + die "Cannot update rrd $self->{dbname} ", + "with $params{message} ($!)"; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::RRDs - Log to a RRDtool Archive + +=head1 SYNOPSIS + + use Log::Log4perl qw(get_logger); + use RRDs; + + my $DB = "myrrddb.dat"; + + RRDs::create( + $DB, "--step=1", + "DS:myvalue:GAUGE:2:U:U", + "RRA:MAX:0.5:1:120"); + + print time(), "\n"; + + Log::Log4perl->init(\qq{ + log4perl.category = INFO, RRDapp + log4perl.appender.RRDapp = Log::Log4perl::Appender::RRDs + log4perl.appender.RRDapp.dbname = $DB + log4perl.appender.RRDapp.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.RRDapp.layout.ConversionPattern = N:%m + }); + + my $logger = get_logger(); + + for(10, 15, 20, 25) { + $logger->info($_); + sleep 1; + } + +=head1 DESCRIPTION + +C<Log::Log4perl::Appender::RRDs> appenders facilitate writing data +to RRDtool round-robin archives via Log4perl. For documentation +on RRD and its Perl interface C<RRDs> (which comes with the distribution), +check out L<http://rrdtool.org>. + +Messages sent to Log4perl's RRDs appender are expected to be numerical values +(ints or floats), which then are used to run a C<rrdtool update> command +on an existing round-robin database. The name of this database needs to +be set in the appender's C<dbname> configuration parameter. + +If there's more parameters you wish to pass to the C<update> method, +use the C<rrdupd_params> configuration parameter: + + log4perl.appender.RRDapp.rrdupd_params = --template=in:out + +To read out the round robin database later on, use C<rrdtool fetch> +or C<rrdtool graph> for graphic displays. + +=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. + diff --git a/lib/Log/Log4perl/Appender/Screen.pm b/lib/Log/Log4perl/Appender/Screen.pm new file mode 100755 index 0000000..6581baf --- /dev/null +++ b/lib/Log/Log4perl/Appender/Screen.pm @@ -0,0 +1,124 @@ +################################################## +package Log::Log4perl::Appender::Screen; +################################################## + +our @ISA = qw(Log::Log4perl::Appender); + +use warnings; +use strict; + +################################################## +sub new { +################################################## + my($class, @options) = @_; + + my $self = { + name => "unknown name", + stderr => 1, + utf8 => undef, + @options, + }; + + if( $self->{utf8} ) { + if( $self->{stderr} ) { + binmode STDERR, ":utf8"; + } else { + binmode STDOUT, ":utf8"; + } + } + + bless $self, $class; +} + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + if($self->{stderr}) { + print STDERR $params{message}; + } else { + print $params{message}; + } +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::Screen - Log to STDOUT/STDERR + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::Screen; + + my $app = Log::Log4perl::Appender::Screen->new( + stderr => 0, + utf8 => 1, + ); + + $file->log(message => "Log me\n"); + +=head1 DESCRIPTION + +This is a simple appender for writing to STDOUT or STDERR. + +The constructor C<new()> take an optional parameter C<stderr>, +if set to a true value, the appender will log to STDERR. +The default setting for C<stderr> is 1, so messages will be logged to +STDERR by default. + +If C<stderr> +is set to a false value, it will log to STDOUT (or, more accurately, +whichever file handle is selected via C<select()>, STDOUT by default). + +Design and implementation of this module has been greatly inspired by +Dave Rolsky's C<Log::Dispatch> appender framework. + +To enable printing wide utf8 characters, set the utf8 option to a true +value: + + my $app = Log::Log4perl::Appender::Screen->new( + stderr => 1, + utf8 => 1, + ); + +This will issue the necessary binmode command to the selected output +channel (stderr/stdout). + +=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. + diff --git a/lib/Log/Log4perl/Appender/ScreenColoredLevels.pm b/lib/Log/Log4perl/Appender/ScreenColoredLevels.pm new file mode 100644 index 0000000..0abad3f --- /dev/null +++ b/lib/Log/Log4perl/Appender/ScreenColoredLevels.pm @@ -0,0 +1,235 @@ +################################################## +package Log::Log4perl::Appender::ScreenColoredLevels; +################################################## +use Log::Log4perl::Appender::Screen; +our @ISA = qw(Log::Log4perl::Appender::Screen); + +use warnings; +use strict; + +use Term::ANSIColor qw(); +use Log::Log4perl::Level; + +BEGIN { + $Term::ANSIColor::EACHLINE="\n"; +} + +################################################## +sub new { +################################################## + my($class, %options) = @_; + + my %specific_options = ( color => {} ); + + for my $option ( keys %specific_options ) { + $specific_options{ $option } = delete $options{ $option } if + exists $options{ $option }; + } + + my $self = $class->SUPER::new( %options ); + @$self{ keys %specific_options } = values %specific_options; + bless $self, __PACKAGE__; # rebless + + # also accept lower/mixed case levels in config + for my $level ( keys %{ $self->{color} } ) { + my $uclevel = uc($level); + $self->{color}->{$uclevel} = $self->{color}->{$level}; + } + + my %default_colors = ( + TRACE => 'yellow', + DEBUG => '', + INFO => 'green', + WARN => 'blue', + ERROR => 'magenta', + FATAL => 'red', + ); + for my $level ( keys %default_colors ) { + if ( ! exists $self->{ 'color' }->{ $level } ) { + $self->{ 'color' }->{ $level } = $default_colors{ $level }; + } + } + + bless $self, $class; +} + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + my $msg = $params{ 'message' }; + + if ( my $color = $self->{ 'color' }->{ $params{ 'log4p_level' } } ) { + $msg = Term::ANSIColor::colored( $msg, $color ); + } + + if($self->{stderr}) { + print STDERR $msg; + } else { + print $msg; + } +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::ScreenColoredLevel - Colorize messages according to level + +=head1 SYNOPSIS + + use Log::Log4perl qw(:easy); + + Log::Log4perl->init(\ <<'EOT'); + log4perl.category = DEBUG, Screen + log4perl.appender.Screen = \ + Log::Log4perl::Appender::ScreenColoredLevels + log4perl.appender.Screen.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.Screen.layout.ConversionPattern = \ + %d %F{1} %L> %m %n + EOT + + # Appears black + DEBUG "Debug Message"; + + # Appears green + INFO "Info Message"; + + # Appears blue + WARN "Warn Message"; + + # Appears magenta + ERROR "Error Message"; + + # Appears red + FATAL "Fatal Message"; + +=head1 DESCRIPTION + +This appender acts like Log::Log4perl::Appender::Screen, except that +it colorizes its output, based on the priority of the message sent. + +You can configure the colors and attributes used for the different +levels, by specifying them in your configuration: + + log4perl.appender.Screen.color.TRACE=cyan + log4perl.appender.Screen.color.DEBUG=bold blue + +You can also specify nothing, to indicate that level should not have +coloring applied, which means the text will be whatever the default +color for your terminal is. This is the default for debug messages. + + log4perl.appender.Screen.color.DEBUG= + +You can use any attribute supported by L<Term::ANSIColor> as a configuration +option. + + log4perl.appender.Screen.color.FATAL=\ + bold underline blink red on_white + +The commonly used colors and attributes are: + +=over 4 + +=item attributes + +BOLD, DARK, UNDERLINE, UNDERSCORE, BLINK + +=item colors + +BLACK, RED, GREEN, YELLOW, BLUE, MAGENTA, CYAN, WHITE + +=item background colors + +ON_BLACK, ON_RED, ON_GREEN, ON_YELLOW, ON_BLUE, ON_MAGENTA, ON_CYAN, ON_WHITE + +=back + +See L<Term::ANSIColor> for a complete list, and information on which are +supported by various common terminal emulators. + +The default values for these options are: + +=over 4 + +=item Trace + +Yellow + +=item Debug + +None (whatever the terminal default is) + +=item Info + +Green + +=item Warn + +Blue + +=item Error + +Magenta + +=item Fatal + +Red + +=back + +The constructor C<new()> takes an optional parameter C<stderr>, +if set to a true value, the appender will log to STDERR. If C<stderr> +is set to a false value, it will log to STDOUT. The default setting +for C<stderr> is 1, so messages will be logged to STDERR by default. +The constructor can also take an optional parameter C<color>, whose +value is a hashref of color configuration options, any levels that +are not included in the hashref will be set to their default values. + +=head2 Using ScreenColoredLevels on Windows + +Note that if you're using this appender on Windows, you need to fetch +Win32::Console::ANSI from CPAN and add + + use Win32::Console::ANSI; + +to your script. + +=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. + diff --git a/lib/Log/Log4perl/Appender/Socket.pm b/lib/Log/Log4perl/Appender/Socket.pm new file mode 100755 index 0000000..2941ef8 --- /dev/null +++ b/lib/Log/Log4perl/Appender/Socket.pm @@ -0,0 +1,226 @@ +################################################## +package Log::Log4perl::Appender::Socket; +################################################## +our @ISA = qw(Log::Log4perl::Appender); + +use warnings; +use strict; + +use IO::Socket::INET; + +################################################## +sub new { +################################################## + my($class, @options) = @_; + + my $self = { + name => "unknown name", + silent_recovery => 0, + no_warning => 0, + PeerAddr => "localhost", + Proto => 'tcp', + Timeout => 5, + @options, + }; + + bless $self, $class; + + unless ($self->{defer_connection}){ + unless($self->connect(@options)) { + if($self->{silent_recovery}) { + if( ! $self->{no_warning}) { + warn "Connect to $self->{PeerAddr}:$self->{PeerPort} failed: $!"; + } + return $self; + } + die "Connect to $self->{PeerAddr}:$self->{PeerPort} failed: $!"; + } + + $self->{socket}->autoflush(1); + #autoflush has been the default behavior since 1997 + } + + return $self; +} + +################################################## +sub connect { +################################################## + my($self, @options) = @_; + + $self->{socket} = IO::Socket::INET->new(@options); + + return $self->{socket}; +} + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + + { + # If we were never able to establish + # a connection, try to establish one + # here. If it fails, return. + if(($self->{silent_recovery} or $self->{defer_connection}) and + !defined $self->{socket}) { + if(! $self->connect(%$self)) { + return undef; + } + } + + # Try to send the message across + eval { $self->{socket}->send($params{message}); + }; + + if($@) { + warn "Send to " . ref($self) . " failed ($@), retrying once..."; + if($self->connect(%$self)) { + redo; + } + if($self->{silent_recovery}) { + return undef; + } + warn "Reconnect to $self->{PeerAddr}:$self->{PeerPort} " . + "failed: $!"; + return undef; + } + }; + + return 1; +} + +################################################## +sub DESTROY { +################################################## + my($self) = @_; + + undef $self->{socket}; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::Socket - Log to a socket + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::Socket; + + my $appender = Log::Log4perl::Appender::Socket->new( + PeerAddr => "server.foo.com", + PeerPort => 1234, + ); + + $appender->log(message => "Log me\n"); + +=head1 DESCRIPTION + +This is a simple appender for writing to a socket. It relies on +L<IO::Socket::INET> and offers all parameters this module offers. + +Upon destruction of the object, pending messages will be flushed +and the socket will be closed. + +If the appender cannot contact the server during the initialization +phase (while running the constructor C<new>), it will C<die()>. + +If the appender fails to log a message because the socket's C<send()> +method fails (most likely because the server went down), it will +try to reconnect once. If it succeeds, the message will be sent. +If the reconnect fails, a warning is sent to STDERR and the C<log()> +method returns, discarding the message. + +If the option C<silent_recovery> is given to the constructor and +set to a true value, the behaviour is different: If the socket connection +can't be established at initialization time, a single warning is issued. +Every log attempt will then try to establish the connection and +discard the message silently if it fails. +If you don't even want the warning, set the C<no_warning> option to +a true value. + +Connecting at initialization time may not be the best option when +running under Apache1 Apache2/prefork, because the parent process creates +the socket and the connections are shared among the forked children--all +the children writing to the same socket could intermingle messages. So instead +of that, you can use C<defer_connection> which will put off making the +connection until the first log message is sent. + +=head1 EXAMPLE + +Write a server quickly using the IO::Socket::INET module: + + use IO::Socket::INET; + + my $sock = IO::Socket::INET->new( + Listen => 5, + LocalAddr => 'localhost', + LocalPort => 12345, + Proto => 'tcp'); + + while(my $client = $sock->accept()) { + print "Client connected\n"; + while(<$client>) { + print "$_\n"; + } + } + +Start it and then run the following script as a client: + + use Log::Log4perl qw(:easy); + + my $conf = q{ + log4perl.category = WARN, Socket + log4perl.appender.Socket = Log::Log4perl::Appender::Socket + log4perl.appender.Socket.PeerAddr = localhost + log4perl.appender.Socket.PeerPort = 12345 + log4perl.appender.Socket.layout = SimpleLayout + }; + + Log::Log4perl->init(\$conf); + + sleep(2); + + for(1..10) { + ERROR("Quack!"); + sleep(5); + } + +=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. + diff --git a/lib/Log/Log4perl/Appender/String.pm b/lib/Log/Log4perl/Appender/String.pm new file mode 100644 index 0000000..9e1bff7 --- /dev/null +++ b/lib/Log/Log4perl/Appender/String.pm @@ -0,0 +1,110 @@ +package Log::Log4perl::Appender::String; +our @ISA = qw(Log::Log4perl::Appender); + +################################################## +# Log dispatcher writing to a string buffer +################################################## + +################################################## +sub new { +################################################## + my $proto = shift; + my $class = ref $proto || $proto; + my %params = @_; + + my $self = { + name => "unknown name", + string => "", + %params, + }; + + bless $self, $class; +} + +################################################## +sub log { +################################################## + my $self = shift; + my %params = @_; + + $self->{string} .= $params{message}; +} + +################################################## +sub string { +################################################## + my($self, $new) = @_; + + if(defined $new) { + $self->{string} = $new; + } + + return $self->{string}; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::String - Append to a string + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::String; + + my $appender = Log::Log4perl::Appender::String->new( + name => 'my string appender', + ); + + # Append to the string + $appender->log( + message => "I'm searching the city for sci-fi wasabi\n" + ); + + # Retrieve the result + my $result = $appender->string(); + + # Reset the buffer to the empty string + $appender->string(""); + +=head1 DESCRIPTION + +This is a simple appender used internally by C<Log::Log4perl>. It +appends messages to a scalar instance variable. + +=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. + diff --git a/lib/Log/Log4perl/Appender/Synchronized.pm b/lib/Log/Log4perl/Appender/Synchronized.pm new file mode 100644 index 0000000..a36ed31 --- /dev/null +++ b/lib/Log/Log4perl/Appender/Synchronized.pm @@ -0,0 +1,292 @@ +###################################################################### +# Synchronized.pm -- 2003, 2007 Mike Schilli <m@perlmeister.com> +###################################################################### +# Special appender employing a locking strategy to synchronize +# access. +###################################################################### + +########################################### +package Log::Log4perl::Appender::Synchronized; +########################################### + +use strict; +use warnings; +use Log::Log4perl::Util::Semaphore; + +our @ISA = qw(Log::Log4perl::Appender); + +our $CVSVERSION = '$Revision: 1.12 $'; +our ($VERSION) = ($CVSVERSION =~ /(\d+\.\d+)/); + +########################################### +sub new { +########################################### + my($class, %options) = @_; + + my $self = { + appender=> undef, + key => '_l4p', + level => 0, + %options, + }; + + my @values = (); + for my $param (qw(uid gid mode destroy key)) { + push @values, $param, $self->{$param} if defined $self->{$param}; + } + + $self->{sem} = Log::Log4perl::Util::Semaphore->new( + @values + ); + + # Pass back the appender to be synchronized as a dependency + # to the configuration file parser + push @{$options{l4p_depends_on}}, $self->{appender}; + + # Run our post_init method in the configurator after + # all appenders have been defined to make sure the + # appender we're synchronizing really exists + push @{$options{l4p_post_config_subs}}, sub { $self->post_init() }; + + bless $self, $class; +} + +########################################### +sub log { +########################################### + my($self, %params) = @_; + + $self->{sem}->semlock(); + + # Relay that to the SUPER class which needs to render the + # message according to the appender's layout, first. + $Log::Log4perl::caller_depth +=2; + $self->{app}->SUPER::log(\%params, + $params{log4p_category}, + $params{log4p_level}); + $Log::Log4perl::caller_depth -=2; + + $self->{sem}->semunlock(); +} + +########################################### +sub post_init { +########################################### + my($self) = @_; + + if(! exists $self->{appender}) { + die "No appender defined for " . __PACKAGE__; + } + + my $appenders = Log::Log4perl->appenders(); + my $appender = Log::Log4perl->appenders()->{$self->{appender}}; + + if(! defined $appender) { + die "Appender $self->{appender} not defined (yet) when " . + __PACKAGE__ . " needed it"; + } + + $self->{app} = $appender; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + + Log::Log4perl::Appender::Synchronized - Synchronizing other appenders + +=head1 SYNOPSIS + + use Log::Log4perl qw(:easy); + + my $conf = qq( + log4perl.category = WARN, Syncer + + # File appender (unsynchronized) + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.autoflush = 1 + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.mode = truncate + log4perl.appender.Logfile.layout = SimpleLayout + + # Synchronizing appender, using the file appender above + log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized + log4perl.appender.Syncer.appender = Logfile +); + + Log::Log4perl->init(\$conf); + WARN("This message is guaranteed to be complete."); + +=head1 DESCRIPTION + +If multiple processes are using the same C<Log::Log4perl> appender +without synchronization, overwrites might happen. A typical scenario +for this would be a process spawning children, each of which inherits +the parent's Log::Log4perl configuration. + +In most cases, you won't need an external synchronisation tool like +Log::Log4perl::Appender::Synchronized at all. Log4perl's file appender, +Log::Log4perl::Appender::File, for example, provides the C<syswrite> +mechanism for making sure that even long log lines won't interleave. +Short log lines won't interleave anyway, because the operating system +makes sure the line gets written before a task switch occurs. + +In cases where you need additional synchronization, however, you can use +C<Log::Log4perl::Appender::Synchronized> as a gateway between your +loggers and your appenders. An appender itself, +C<Log::Log4perl::Appender::Synchronized> just takes two additional +arguments: + +=over 4 + +=item C<appender> + +Specifies the name of the appender it synchronizes access to. The +appender specified must be defined somewhere in the configuration file, +not necessarily before the definition of +C<Log::Log4perl::Appender::Synchronized>. + +=item C<key> + +This optional argument specifies the key for the semaphore that +C<Log::Log4perl::Appender::Synchronized> uses internally to ensure +atomic operations. It defaults to C<_l4p>. If you define more than +one C<Log::Log4perl::Appender::Synchronized> appender, it is +important to specify different keys for them, as otherwise every +new C<Log::Log4perl::Appender::Synchronized> appender will nuke +previously defined semaphores. The maximum key length is four +characters, longer keys will be truncated to 4 characters -- +C<mylongkey1> and C<mylongkey2> are interpreted to be the same: +C<mylo> (thanks to David Viner E<lt>dviner@yahoo-inc.comE<gt> for +pointing this out). + +=back + +C<Log::Log4perl::Appender::Synchronized> uses Log::Log4perl::Util::Semaphore +internally to perform locking with semaphores provided by the +operating system used. + +=head2 Performance tips + +The C<Log::Log4perl::Appender::Synchronized> serializes access to a +protected resource globally, slowing down actions otherwise performed in +parallel. + +Unless specified otherwise, all instances of +C<Log::Log4perl::Appender::Synchronized> objects in the system will +use the same global IPC key C<_l4p>. + +To control access to different appender instances, it often makes sense +to define different keys for different synchronizing appenders. In this +way, Log::Log4perl serializes access to each appender instance separately: + + log4perl.category = WARN, Syncer1, Syncer2 + + # File appender 1 (unsynchronized) + log4perl.appender.Logfile1 = Log::Log4perl::Appender::File + log4perl.appender.Logfile1.filename = test1.log + log4perl.appender.Logfile1.layout = SimpleLayout + + # File appender 2 (unsynchronized) + log4perl.appender.Logfile2 = Log::Log4perl::Appender::File + log4perl.appender.Logfile2.filename = test2.log + log4perl.appender.Logfile2.layout = SimpleLayout + + # Synchronizing appender, using the file appender above + log4perl.appender.Syncer1 = Log::Log4perl::Appender::Synchronized + log4perl.appender.Syncer1.appender = Logfile1 + log4perl.appender.Syncer1.key = l4p1 + + # Synchronizing appender, using the file appender above + log4perl.appender.Syncer2 = Log::Log4perl::Appender::Synchronized + log4perl.appender.Syncer2.appender = Logfile2 + log4perl.appender.Syncer2.key = l4p2 + +Without the C<.key = l4p1> and C<.key = l4p2> lines, both Synchronized +appenders would be using the default C<_l4p> key, causing unnecessary +serialization of output written to different files. + +=head2 Advanced configuration + +To configure the underlying Log::Log4perl::Util::Semaphore module in +a different way than with the default settings provided by +Log::Log4perl::Appender::Synchronized, use the following parameters: + + log4perl.appender.Syncer1.destroy = 1 + log4perl.appender.Syncer1.mode = sub { 0775 } + log4perl.appender.Syncer1.uid = hugo + log4perl.appender.Syncer1.gid = 100 + +Valid options are +C<destroy> (Remove the semaphore on exit), +C<mode> (permissions on the semaphore), +C<uid> (uid or user name the semaphore is owned by), +and +C<gid> (group id the semaphore is owned by), + +Note that C<mode> is usually given in octal and therefore needs to be +specified as a perl sub {}, unless you want to calculate what 0755 means +in decimal. + +Changing ownership or group settings for a semaphore will obviously only +work if the current user ID owns the semaphore already or if the current +user is C<root>. The C<destroy> option causes the current process to +destroy the semaphore on exit. Spawned children of the process won't +inherit this behavior. + +=head2 Semaphore user and group IDs with mod_perl + +Setting user and group IDs is especially important when the Synchronized +appender is used with mod_perl. If Log4perl gets initialized by a startup +handler, which runs as root, and not as the user who will later use +the semaphore, the settings for uid, gid, and mode can help establish +matching semaphore ownership and access rights. + +=head1 DEVELOPMENT NOTES + +C<Log::Log4perl::Appender::Synchronized> is a I<composite> appender. +Unlike other appenders, it doesn't log any messages, it just +passes them on to its attached sub-appender. +For this reason, it doesn't need a layout (contrary to regular appenders). +If it defines none, messages are passed on unaltered. + +Custom filters are also applied to the composite appender only. +They are I<not> applied to the sub-appender. Same applies to appender +thresholds. This behaviour might change in the future. + +=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. + diff --git a/lib/Log/Log4perl/Appender/TestArrayBuffer.pm b/lib/Log/Log4perl/Appender/TestArrayBuffer.pm new file mode 100644 index 0000000..ce62e1c --- /dev/null +++ b/lib/Log/Log4perl/Appender/TestArrayBuffer.pm @@ -0,0 +1,94 @@ +################################################## +package Log::Log4perl::Appender::TestArrayBuffer; +################################################## +# Like Log::Log4perl::Appender::TestBuffer, just with +# array capability. +# For testing only. +################################################## + +use base qw( Log::Log4perl::Appender::TestBuffer ); + +################################################## +sub log { +################################################## + my $self = shift; + my %params = @_; + + $self->{buffer} .= "[$params{level}]: " if $LOG_PRIORITY; + + if(ref($params{message}) eq "ARRAY") { + $self->{buffer} .= "[" . join(',', @{$params{message}}) . "]"; + } else { + $self->{buffer} .= $params{message}; + } +} + +1; + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::TestArrayBuffer - Subclass of Appender::TestBuffer + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::TestArrayBuffer; + + my $appender = Log::Log4perl::Appender::TestArrayBuffer->new( + name => 'buffer', + ); + + # Append to the buffer + $appender->log( + level = > 'alert', + message => ['first', 'second', 'third'], + ); + + # Retrieve the result + my $result = $appender->buffer(); + + # Reset the buffer to the empty string + $appender->reset(); + +=head1 DESCRIPTION + +This class is a subclass of Log::Log4perl::Appender::TestBuffer and +just provides message array refs as an additional feature. + +Just like Log::Log4perl::Appender::TestBuffer, +Log::Log4perl::Appender::TestArrayBuffer is used for internal +Log::Log4perl testing only. + +=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. + diff --git a/lib/Log/Log4perl/Appender/TestBuffer.pm b/lib/Log/Log4perl/Appender/TestBuffer.pm new file mode 100644 index 0000000..a929a6e --- /dev/null +++ b/lib/Log/Log4perl/Appender/TestBuffer.pm @@ -0,0 +1,189 @@ +package Log::Log4perl::Appender::TestBuffer; +our @ISA = qw(Log::Log4perl::Appender); + +################################################## +# Log dispatcher writing to a string buffer +# For testing. +# This is like having a Log::Log4perl::Appender::TestBuffer +################################################## + +our %POPULATION = (); +our $LOG_PRIORITY = 0; +our $DESTROY_MESSAGES = ""; + +################################################## +sub new { +################################################## + my $proto = shift; + my $class = ref $proto || $proto; + my %params = @_; + + my $self = { + name => "unknown name", + %params, + }; + + bless $self, $class; + + $self->{stderr} = exists $params{stderr} ? $params{stderr} : 1; + $self->{buffer} = ""; + + $POPULATION{$self->{name}} = $self; + + return $self; +} + +################################################## +sub log { +################################################## + my $self = shift; + my %params = @_; + + if( !defined $params{level} ) { + die "No level defined in log() call of " . __PACKAGE__; + } + $self->{buffer} .= "[$params{level}]: " if $LOG_PRIORITY; + $self->{buffer} .= $params{message}; +} + +########################################### +sub clear { +########################################### + my($self) = @_; + + $self->{buffer} = ""; +} + +################################################## +sub buffer { +################################################## + my($self, $new) = @_; + + if(defined $new) { + $self->{buffer} = $new; + } + + return $self->{buffer}; +} + +################################################## +sub reset { +################################################## + my($self) = @_; + + %POPULATION = (); + $self->{buffer} = ""; +} + +################################################## +sub DESTROY { +################################################## + my($self) = @_; + + $DESTROY_MESSAGES .= __PACKAGE__ . " destroyed"; + + #this delete() along with &reset() above was causing + #Attempt to free unreferenced scalar at + #blib/lib/Log/Log4perl/TestBuffer.pm line 69. + #delete $POPULATION{$self->name}; +} + +################################################## +sub by_name { +################################################## + my($self, $name) = @_; + + # Return a TestBuffer by appender name. This is useful if + # test buffers are created behind our back (e.g. via the + # Log4perl config file) and later on we want to + # retrieve an instance to query its content. + + die "No name given" unless defined $name; + + return $POPULATION{$name}; + +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::TestBuffer - Appender class for testing + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::TestBuffer; + + my $appender = Log::Log4perl::Appender::TestBuffer->new( + name => 'mybuffer', + ); + + # Append to the buffer + $appender->log( + level = > 'alert', + message => "I'm searching the city for sci-fi wasabi\n" + ); + + # Retrieve the result + my $result = $appender->buffer(); + + # Clear the buffer to the empty string + $appender->clear(); + +=head1 DESCRIPTION + +This class is used for internal testing of C<Log::Log4perl>. It +is a C<Log::Dispatch>-style appender, which writes to a buffer +in memory, from where actual results can be easily retrieved later +to compare with expected results. + +Every buffer created is stored in an internal global array, and can +later be referenced by name: + + my $app = Log::Log4perl::Appender::TestBuffer->by_name("mybuffer"); + +retrieves the appender object of a previously created buffer "mybuffer". +To reset this global array and have it forget all of the previously +created testbuffer appenders (external references to those appenders +nonwithstanding), use + + Log::Log4perl::Appender::TestBuffer->reset(); + +=head1 SEE ALSO + +=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. + diff --git a/lib/Log/Log4perl/Appender/TestFileCreeper.pm b/lib/Log/Log4perl/Appender/TestFileCreeper.pm new file mode 100755 index 0000000..aadf099 --- /dev/null +++ b/lib/Log/Log4perl/Appender/TestFileCreeper.pm @@ -0,0 +1,89 @@ +################################################## +package Log::Log4perl::Appender::TestFileCreeper; +################################################## +# Test appender, intentionally slow. It writes +# out one byte at a time to provoke sync errors. +# Don't use it, unless for testing. +################################################## + +use warnings; +use strict; + +use Log::Log4perl::Appender::File; + +our @ISA = qw(Log::Log4perl::Appender::File); + +################################################## +sub log { +################################################## + my($self, %params) = @_; + + my $fh = $self->{fh}; + + for (split //, $params{message}) { + print $fh $_; + my $oldfh = select $self->{fh}; + $| = 1; + select $oldfh; + } +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Appender::TestFileCreeper - Intentionally slow test appender + +=head1 SYNOPSIS + + use Log::Log4perl::Appender::TestFileCreeper; + + my $app = Log::Log4perl::Appender::TestFileCreeper->new( + filename => 'file.log', + mode => 'append', + ); + + $file->log(message => "Log me\n"); + +=head1 DESCRIPTION + +This is a test appender, and it is intentionally slow. It writes +out one byte at a time to provoke sync errors. Don't use it, unless +for testing. + +=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. + diff --git a/lib/Log/Log4perl/Catalyst.pm b/lib/Log/Log4perl/Catalyst.pm new file mode 100644 index 0000000..f9af5e9 --- /dev/null +++ b/lib/Log/Log4perl/Catalyst.pm @@ -0,0 +1,368 @@ +package Log::Log4perl::Catalyst; + +use strict; +use Log::Log4perl qw(:levels); +use Log::Log4perl::Logger; + +our $VERSION = $Log::Log4perl::VERSION; +our $CATALYST_APPENDER_SUFFIX = "catalyst_buffer"; +our $LOG_LEVEL_ADJUSTMENT = 1; + +init(); + +################################################## +sub init { +################################################## + + my @levels = qw[ trace debug info warn error fatal ]; + + Log::Log4perl->wrapper_register(__PACKAGE__); + + for my $level (@levels) { + no strict 'refs'; + + *{$level} = sub { + my ( $self, @message ) = @_; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + + $LOG_LEVEL_ADJUSTMENT; + + my $logger = Log::Log4perl->get_logger(); + $logger->$level(@message); + return 1; + }; + + *{"is_$level"} = sub { + my ( $self, @message ) = @_; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + + $LOG_LEVEL_ADJUSTMENT; + + my $logger = Log::Log4perl->get_logger(); + my $func = "is_" . $level; + return $logger->$func; + }; + } +} + +################################################## +sub new { +################################################## + my($class, $config, %options) = @_; + + my $self = { + autoflush => 0, + abort => 0, + watch_delay => 0, + %options, + }; + + if( !Log::Log4perl->initialized() ) { + if( defined $config ) { + if( $self->{watch_delay} ) { + Log::Log4perl::init_and_watch( $config, $self->{watch_delay} ); + } else { + Log::Log4perl::init( $config ); + } + } else { + Log::Log4perl->easy_init({ + level => $DEBUG, + layout => "[%d] [catalyst] [%p] %m%n", + }); + } + } + + # Unless we have autoflush, Catalyst likes to buffer all messages + # until it calls flush(). This is somewhat unusual for Log4perl, + # but we just put an army of buffer appenders in front of all + # appenders defined in the system. + + if(! $options{autoflush} ) { + for my $appender (values %Log::Log4perl::Logger::APPENDER_BY_NAME) { + next if $appender->{name} =~ /_$CATALYST_APPENDER_SUFFIX$/; + + # put a buffering appender in front of every appender + # defined so far + + my $buf_app_name = "$appender->{name}_$CATALYST_APPENDER_SUFFIX"; + + my $buf_app = Log::Log4perl::Appender->new( + 'Log::Log4perl::Appender::Buffer', + name => $buf_app_name, + appender => $appender->{name}, + trigger => sub { 0 }, # only trigger on explicit flush() + ); + + Log::Log4perl->add_appender($buf_app); + $buf_app->post_init(); + $buf_app->composite(1); + + # Point all loggers currently connected to the previously defined + # appenders to the chained buffer appenders instead. + + foreach my $logger ( + values %$Log::Log4perl::Logger::LOGGERS_BY_NAME){ + if(defined $logger->remove_appender( $appender->{name}, 0, 1)) { + $logger->add_appender( $buf_app ); + } + } + } + } + + bless $self, $class; + + return $self; +} + +################################################## +sub _flush { +################################################## + my ($self) = @_; + + for my $appender (values %Log::Log4perl::Logger::APPENDER_BY_NAME) { + next if $appender->{name} !~ /_$CATALYST_APPENDER_SUFFIX$/; + + if ($self->abort) { + $appender->{appender}{buffer} = []; + } + else { + $appender->flush(); + } + } + + $self->abort(undef); +} + +################################################## +sub abort { +################################################## + my $self = shift; + + $self->{abort} = $_[0] if @_; + + return $self->{abort}; +} + +################################################## +sub levels { +################################################## + # stub function, until we have something meaningful + return 0; +} + +################################################## +sub enable { +################################################## + # stub function, until we have something meaningful + return 0; +} + +################################################## +sub disable { +################################################## + # stub function, until we have something meaningful + return 0; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Catalyst - Log::Log4perl Catalyst Module + +=head1 SYNOPSIS + +In your main Catalyst application module: + + use Log::Log4perl::Catalyst; + + # Either make Log4perl act like the Catalyst default logger: + __PACKAGE__->log(Log::Log4perl::Catalyst->new()); + + # or use a Log4perl configuration file, utilizing the full + # functionality of Log4perl + __PACKAGE__->log(Log::Log4perl::Catalyst->new('l4p.conf')); + +... and then sprinkle logging statements all over any code executed +by Catalyst: + + $c->log->debug("This is using log4perl!"); + +=head1 DESCRIPTION + +This module provides Log4perl functions to Catalyst applications. It was +inspired by Catalyst::Log::Log4perl on CPAN, but has been completely +rewritten and uses a different approach to unite Catalyst and Log4perl. + +Log4perl provides loggers, usually associated with the current +package, which can then be remote-controlled by a central +configuration. This means that if you have a controller function like + + package MyApp::Controller::User; + + sub add : Chained('base'): PathPart('add'): Args(0) { + my ( $self, $c ) = @_; + + $c->log->info("Adding a user"); + # ... + } + +Level-based control is available via the following methods: + + $c->log->debug("Reading configuration"); + $c->log->info("Adding a user"); + $c->log->warn("Can't read configuration ($!)"); + $c->log->error("Can't add user ", $user); + $c->log->fatal("Database down, aborting request"); + +But that's not all, Log4perl is much more powerful. + +The logging statement can be suppressed or activated based on a Log4perl +file that looks like + + # All MyApp loggers opened up for DEBUG and above + log4perl.logger.MyApp = DEBUG, Screen + # ... + +or + + # All loggers block messages below INFO + log4perl.logger=INFO, Screen + # ... + +respectively. See the Log4perl manpage on how to perform fine-grained +log-level and location filtering, and how to forward messages not only +to the screen or to log files, but also to databases, email appenders, +and much more. + +Also, you can change the message layout. For example if you want +to know where a particular statement was logged, turn on file names and +line numbers: + + # Log4perl configuration file + # ... + log4perl.appender.Screen.layout.ConversionPattern = \ + %F{1}-%L: %p %m%n + +Messages will then look like + + MyApp.pm-1869: INFO Saving user profile for user "wonko" + +Or want to log a request's IP address with every log statement? No problem +with Log4perl, just call + + Log::Log4perl::MDC->put( "ip", $c->req->address() ); + +at the beginning of the request cycle and use + + # Log4perl configuration file + # ... + log4perl.appender.Screen.layout.ConversionPattern = \ + [%d]-%X{ip} %F{1}-%L: %p %m%n + +as a Log4perl layout. Messages will look like + + [2010/02/22 23:25:55]-123.122.108.10 MyApp.pm-1953: INFO Reading profile for user "wonko" + +Again, check the Log4perl manual page, there's a plethora of configuration +options. + +=head1 METHODS + +=over 4 + +=item new($config, [%options]) + +If called without parameters, new() initializes Log4perl in a way +so that messages are logged similarly to Catalyst's default logging +mechanism. If you provide a configuration, either the name of a configuration +file or a reference to a scalar string containing the configuration, it +will call Log4perl with these parameters. + +The second (optional) parameter is a list of key/value pairs: + + 'autoflush' => 1 # Log without buffering ('abort' not supported) + 'watch_delay' => 30 # If set, use L<Log::Log4perl>'s init_and_watch + +=item _flush() + +Flushes the cache. + +=item abort($abort) + +Clears the logging system's internal buffers without logging anything. + +=back + +=head2 Using :easy Macros with Catalyst + +If you're tired of typing + + $c->log->debug("..."); + +and would prefer to use Log4perl's convenient :easy mode macros like + + DEBUG "..."; + +then just pull those macros in via Log::Log4perl's :easy mode and start +cranking: + + use Log::Log4perl qw(:easy); + + # ... use macros later on + sub base :Chained('/') :PathPart('apples') :CaptureArgs(0) { + my ( $self, $c ) = @_; + + DEBUG "Handling apples"; + } + +Note the difference between Log4perl's initialization in Catalyst, which +uses the Catalyst-specific Log::Log4perl::Catalyst module (top of this +page), and making use of Log4perl's loggers with the standard +Log::Log4perl loggers and macros. While initialization requires Log4perl +to perform dark magic to conform to Catalyst's different logging strategy, +obtaining Log4perl's logger objects or calling its macros are unchanged. + +Instead of using Catalyst's way of referencing the "context" object $c to +obtain logger references via its log() method, you can just as well use +Log4perl's get_logger() or macros to access Log4perl's logger singletons. +The result is the same. + +=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. + diff --git a/lib/Log/Log4perl/Config.pm b/lib/Log/Log4perl/Config.pm new file mode 100644 index 0000000..5a19df2 --- /dev/null +++ b/lib/Log/Log4perl/Config.pm @@ -0,0 +1,1213 @@ +################################################## +package Log::Log4perl::Config; +################################################## +use 5.006; +use strict; +use warnings; + +use Log::Log4perl::Logger; +use Log::Log4perl::Level; +use Log::Log4perl::Config::PropertyConfigurator; +use Log::Log4perl::JavaMap; +use Log::Log4perl::Filter; +use Log::Log4perl::Filter::Boolean; +use Log::Log4perl::Config::Watch; + +use constant _INTERNAL_DEBUG => 0; + +our $CONFIG_FILE_READS = 0; +our $CONFIG_INTEGRITY_CHECK = 1; +our $CONFIG_INTEGRITY_ERROR = undef; + +our $WATCHER; +our $DEFAULT_WATCH_DELAY = 60; # seconds +our $OPTS = {}; +our $OLD_CONFIG; +our $LOGGERS_DEFINED; +our $UTF8 = 0; + +########################################### +sub init { +########################################### + Log::Log4perl::Logger->reset(); + + undef $WATCHER; # just in case there's a one left over (e.g. test cases) + + return _init(@_); +} + +########################################### +sub utf8 { +########################################### + my( $class, $flag ) = @_; + + $UTF8 = $flag if defined $flag; + + return $UTF8; +} + +########################################### +sub watcher { +########################################### + return $WATCHER; +} + +########################################### +sub init_and_watch { +########################################### + my ($class, $config, $delay, $opts) = @_; + # delay can be a signal name - in this case we're gonna + # set up a signal handler. + + if(defined $WATCHER) { + $config = $WATCHER->file(); + if(defined $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT) { + $delay = $WATCHER->signal(); + } else { + $delay = $WATCHER->check_interval(); + } + } + + print "init_and_watch ($config-$delay). Resetting.\n" if _INTERNAL_DEBUG; + + Log::Log4perl::Logger->reset(); + + defined ($delay) or $delay = $DEFAULT_WATCH_DELAY; + + if (ref $config) { + die "Log4perl can only watch a file, not a string of " . + "configuration information"; + }elsif ($config =~ m!^(https?|ftp|wais|gopher|file):!){ + die "Log4perl can only watch a file, not a url like $config"; + } + + if($delay =~ /\D/) { + $WATCHER = Log::Log4perl::Config::Watch->new( + file => $config, + signal => $delay, + l4p_internal => 1, + ); + } else { + $WATCHER = Log::Log4perl::Config::Watch->new( + file => $config, + check_interval => $delay, + l4p_internal => 1, + ); + } + + if(defined $opts) { + die "Parameter $opts needs to be a hash ref" if ref($opts) ne "HASH"; + $OPTS = $opts; + } + + eval { _init($class, $config); }; + + if($@) { + die "$@" unless defined $OLD_CONFIG; + # Call _init with a pre-parsed config to go back to old setting + _init($class, undef, $OLD_CONFIG); + warn "Loading new config failed, reverted to old one\n"; + } +} + +################################################## +sub _init { +################################################## + my($class, $config, $data) = @_; + + my %additivity = (); + + $LOGGERS_DEFINED = 0; + + print "Calling _init\n" if _INTERNAL_DEBUG; + + #keep track so we don't create the same one twice + my %appenders_created = (); + + #some appenders need to run certain subroutines right at the + #end of the configuration phase, when all settings are in place. + my @post_config_subs = (); + + # This logic is probably suited to win an obfuscated programming + # contest. It desperately needs to be rewritten. + # Basically, it works like this: + # config_read() reads the entire config file into a hash of hashes: + # log4j.logger.foo.bar.baz: WARN, A1 + # gets transformed into + # $data->{log4j}->{logger}->{foo}->{bar}->{baz} = "WARN, A1"; + # The code below creates the necessary loggers, sets the appenders + # and the layouts etc. + # In order to transform parts of this tree back into identifiers + # (like "foo.bar.baz"), we're using the leaf_paths functions below. + # Pretty scary. But it allows the lines of the config file to be + # in *arbitrary* order. + + $data = config_read($config) unless defined $data; + + if(_INTERNAL_DEBUG) { + require Data::Dumper; + Data::Dumper->import(); + print Data::Dumper::Dumper($data); + } + + my @loggers = (); + my %filter_names = (); + + my $system_wide_threshold; + + # Autocorrect the rootlogger/rootLogger typo + if(exists $data->{rootlogger} and + ! exists $data->{rootLogger}) { + $data->{rootLogger} = $data->{rootlogger}; + } + + # Find all logger definitions in the conf file. Start + # with root loggers. + if(exists $data->{rootLogger}) { + $LOGGERS_DEFINED++; + push @loggers, ["", $data->{rootLogger}->{value}]; + } + + # Check if we've got a system-wide threshold setting + if(exists $data->{threshold}) { + # yes, we do. + $system_wide_threshold = $data->{threshold}->{value}; + } + + if (exists $data->{oneMessagePerAppender}){ + $Log::Log4perl::one_message_per_appender = + $data->{oneMessagePerAppender}->{value}; + } + + if(exists $data->{utcDateTimes}) { + require Log::Log4perl::DateFormat; + $Log::Log4perl::DateFormat::GMTIME = !!$data->{utcDateTimes}->{value}; + } + + # Boolean filters + my %boolean_filters = (); + + # Continue with lower level loggers. Both 'logger' and 'category' + # are valid keywords. Also 'additivity' is one, having a logger + # attached. We'll differentiate between the two further down. + for my $key (qw(logger category additivity PatternLayout filter)) { + + if(exists $data->{$key}) { + + for my $path (@{leaf_paths($data->{$key})}) { + + print "Path before: @$path\n" if _INTERNAL_DEBUG; + + my $value = boolean_to_perlish(pop @$path); + + pop @$path; # Drop the 'value' keyword part + + if($key eq "additivity") { + # This isn't a logger but an additivity setting. + # Save it in a hash under the logger's name for later. + $additivity{join('.', @$path)} = $value; + + #a global user-defined conversion specifier (cspec) + }elsif ($key eq "PatternLayout"){ + &add_global_cspec(@$path[-1], $value); + + }elsif ($key eq "filter"){ + print "Found entry @$path\n" if _INTERNAL_DEBUG; + $filter_names{@$path[0]}++; + } else { + + if (ref($value) eq "ARRAY") { + die "Multiple definitions of logger ".join('.',@$path)." in log4perl config"; + } + + # This is a regular logger + $LOGGERS_DEFINED++; + push @loggers, [join('.', @$path), $value]; + } + } + } + } + + # Now go over all filters found by name + for my $filter_name (keys %filter_names) { + + print "Checking filter $filter_name\n" if _INTERNAL_DEBUG; + + # The boolean filter needs all other filters already + # initialized, defer its initialization + if($data->{filter}->{$filter_name}->{value} eq + "Log::Log4perl::Filter::Boolean") { + print "Boolean filter ($filter_name)\n" if _INTERNAL_DEBUG; + $boolean_filters{$filter_name}++; + next; + } + + my $type = $data->{filter}->{$filter_name}->{value}; + if(my $code = compile_if_perl($type)) { + $type = $code; + } + + print "Filter $filter_name is of type $type\n" if _INTERNAL_DEBUG; + + my $filter; + + if(ref($type) eq "CODE") { + # Subroutine - map into generic Log::Log4perl::Filter class + $filter = Log::Log4perl::Filter->new($filter_name, $type); + } else { + # Filter class + die "Filter class '$type' doesn't exist" unless + Log::Log4perl::Util::module_available($type); + eval "require $type" or die "Require of $type failed ($!)"; + + # Invoke with all defined parameter + # key/values (except the key 'value' which is the entry + # for the class) + $filter = $type->new(name => $filter_name, + map { $_ => $data->{filter}->{$filter_name}->{$_}->{value} } + grep { $_ ne "value" } + keys %{$data->{filter}->{$filter_name}}); + } + # Register filter with the global filter registry + $filter->register(); + } + + # Initialize boolean filters (they need the other filters to be + # initialized to be able to compile their logic) + for my $name (keys %boolean_filters) { + my $logic = $data->{filter}->{$name}->{logic}->{value}; + die "No logic defined for boolean filter $name" unless defined $logic; + my $filter = Log::Log4perl::Filter::Boolean->new( + name => $name, + logic => $logic); + $filter->register(); + } + + for (@loggers) { + my($name, $value) = @$_; + + my $logger = Log::Log4perl::Logger->get_logger($name); + my ($level, @appnames) = split /\s*,\s*/, $value; + + $logger->level( + Log::Log4perl::Level::to_priority($level), + 'dont_reset_all'); + + if(exists $additivity{$name}) { + $logger->additivity($additivity{$name}, 1); + } + + for my $appname (@appnames) { + + my $appender = create_appender_instance( + $data, $appname, \%appenders_created, \@post_config_subs, + $system_wide_threshold); + + $logger->add_appender($appender, 'dont_reset_all'); + set_appender_by_name($appname, $appender, \%appenders_created); + } + } + + #run post_config subs + for(@post_config_subs) { + $_->(); + } + + #now we're done, set up all the output methods (e.g. ->debug('...')) + Log::Log4perl::Logger::reset_all_output_methods(); + + #Run a sanity test on the config not disabled + if($Log::Log4perl::Config::CONFIG_INTEGRITY_CHECK and + !config_is_sane()) { + warn "Log::Log4perl configuration looks suspicious: ", + "$CONFIG_INTEGRITY_ERROR"; + } + + # Successful init(), save config for later + $OLD_CONFIG = $data; + + $Log::Log4perl::Logger::INITIALIZED = 1; +} + +################################################## +sub config_is_sane { +################################################## + if(! $LOGGERS_DEFINED) { + $CONFIG_INTEGRITY_ERROR = "No loggers defined"; + return 0; + } + + if(scalar keys %Log::Log4perl::Logger::APPENDER_BY_NAME == 0) { + $CONFIG_INTEGRITY_ERROR = "No appenders defined"; + return 0; + } + + return 1; +} + +################################################## +sub create_appender_instance { +################################################## + my($data, $appname, $appenders_created, $post_config_subs, + $system_wide_threshold) = @_; + + my $appenderclass = get_appender_by_name( + $data, $appname, $appenders_created); + + print "appenderclass=$appenderclass\n" if _INTERNAL_DEBUG; + + my $appender; + + if (ref $appenderclass) { + $appender = $appenderclass; + } else { + die "ERROR: you didn't tell me how to " . + "implement your appender '$appname'" + unless $appenderclass; + + if (Log::Log4perl::JavaMap::translate($appenderclass)){ + # It's Java. Try to map + print "Trying to map Java $appname\n" if _INTERNAL_DEBUG; + $appender = Log::Log4perl::JavaMap::get($appname, + $data->{appender}->{$appname}); + + }else{ + # It's Perl + my @params = grep { $_ ne "layout" and + $_ ne "value" + } keys %{$data->{appender}->{$appname}}; + + my %param = (); + foreach my $pname (@params){ + #this could be simple value like + #{appender}{myAppender}{file}{value} => 'log.txt' + #or a structure like + #{appender}{myAppender}{login} => + # { name => {value => 'bob'}, + # pwd => {value => 'xxx'}, + # } + #in the latter case we send a hashref to the appender + if (exists $data->{appender}{$appname} + {$pname}{value} ) { + $param{$pname} = $data->{appender}{$appname} + {$pname}{value}; + }else{ + $param{$pname} = {map {$_ => $data->{appender} + {$appname} + {$pname} + {$_} + {value}} + keys %{$data->{appender} + {$appname} + {$pname}} + }; + } + + } + + my $depends_on = []; + + $appender = Log::Log4perl::Appender->new( + $appenderclass, + name => $appname, + l4p_post_config_subs => $post_config_subs, + l4p_depends_on => $depends_on, + %param, + ); + + for my $dependency (@$depends_on) { + # If this appender indicates that it needs other appenders + # to exist (e.g. because it's a composite appender that + # relays messages on to its appender-refs) then we're + # creating their instances here. Reason for this is that + # these appenders are not attached to any logger and are + # therefore missed by the config parser which goes through + # the defined loggers and just creates *their* attached + # appenders. + $appender->composite(1); + next if exists $appenders_created->{$appname}; + my $app = create_appender_instance($data, $dependency, + $appenders_created, + $post_config_subs); + # If the appender appended a subroutine to $post_config_subs + # (a reference to an array of subroutines) + # here, the configuration parser will later execute this + # method. This is used by a composite appender which needs + # to make sure all of its appender-refs are available when + # all configuration settings are done. + + # Smuggle this sub-appender into the hash of known appenders + # without attaching it to any logger directly. + $ + Log::Log4perl::Logger::APPENDER_BY_NAME{$dependency} = $app; + } + } + } + + add_layout_by_name($data, $appender, $appname) unless + $appender->composite(); + + # Check for appender thresholds + my $threshold = + $data->{appender}->{$appname}->{Threshold}->{value}; + + if(defined $system_wide_threshold and + !defined $threshold) { + $threshold = $system_wide_threshold; + } + + if(defined $threshold) { + # Need to split into two lines because of CVS + $appender->threshold($ + Log::Log4perl::Level::PRIORITY{$threshold}); + } + + # Check for custom filters attached to the appender + my $filtername = + $data->{appender}->{$appname}->{Filter}->{value}; + if(defined $filtername) { + # Need to split into two lines because of CVS + my $filter = Log::Log4perl::Filter::by_name($filtername); + die "Filter $filtername doesn't exist" unless defined $filter; + $appender->filter($filter); + } + + if(defined $system_wide_threshold and + defined $threshold and + $ + Log::Log4perl::Level::PRIORITY{$system_wide_threshold} > + $ + Log::Log4perl::Level::PRIORITY{$threshold} + ) { + $appender->threshold($ + Log::Log4perl::Level::PRIORITY{$system_wide_threshold}); + } + + if(exists $data->{appender}->{$appname}->{threshold}) { + die "invalid keyword 'threshold' - perhaps you meant 'Threshold'?"; + } + + return $appender; +} + +########################################### +sub add_layout_by_name { +########################################### + my($data, $appender, $appender_name) = @_; + + my $layout_class = $data->{appender}->{$appender_name}->{layout}->{value}; + + die "Layout not specified for appender $appender_name" unless $layout_class; + + $layout_class =~ s/org.apache.log4j./Log::Log4perl::Layout::/; + + # Check if we have this layout class + if(!Log::Log4perl::Util::module_available($layout_class)) { + if(Log::Log4perl::Util::module_available( + "Log::Log4perl::Layout::$layout_class")) { + # Someone used the layout shortcut, use the fully qualified + # module name instead. + $layout_class = "Log::Log4perl::Layout::$layout_class"; + } else { + die "ERROR: trying to set layout for $appender_name to " . + "'$layout_class' failed"; + } + } + + eval "require $layout_class" or + die "Require to $layout_class failed ($!)"; + + $appender->layout($layout_class->new( + $data->{appender}->{$appender_name}->{layout}, + )); +} + +########################################### +sub get_appender_by_name { +########################################### + my($data, $name, $appenders_created) = @_; + + if (exists $appenders_created->{$name}) { + return $appenders_created->{$name}; + } else { + return $data->{appender}->{$name}->{value}; + } +} + +########################################### +sub set_appender_by_name { +########################################### +# keep track of appenders we've already created +########################################### + my($appname, $appender, $appenders_created) = @_; + + $appenders_created->{$appname} ||= $appender; +} + +################################################## +sub add_global_cspec { +################################################## +# the config file said +# log4j.PatternLayout.cspec.Z=sub {return $$*2} +################################################## + my ($letter, $perlcode) = @_; + + die "error: only single letters allowed in log4j.PatternLayout.cspec.$letter" + unless ($letter =~ /^[a-zA-Z]$/); + + Log::Log4perl::Layout::PatternLayout::add_global_cspec($letter, $perlcode); +} + +my $LWP_USER_AGENT; +sub set_LWP_UserAgent +{ + $LWP_USER_AGENT = shift; +} + + +########################################### +sub config_read { +########################################### +# Read the lib4j configuration and store the +# values into a nested hash structure. +########################################### + my($config) = @_; + + die "Configuration not defined" unless defined $config; + + my @text; + my $parser; + + $CONFIG_FILE_READS++; # Count for statistical purposes + + my $base_configurator = Log::Log4perl::Config::BaseConfigurator->new( + utf8 => $UTF8, + ); + + my $data = {}; + + if (ref($config) eq 'HASH') { # convert the hashref into a list + # of name/value pairs + print "Reading config from hash\n" if _INTERNAL_DEBUG; + @text = (); + for my $key ( keys %$config ) { + if( ref( $config->{$key} ) eq "CODE" ) { + $config->{$key} = $config->{$key}->(); + } + push @text, $key . '=' . $config->{$key} . "\n"; + } + } elsif (ref $config eq 'SCALAR') { + print "Reading config from scalar\n" if _INTERNAL_DEBUG; + @text = split(/\n/,$$config); + + } elsif (ref $config eq 'GLOB' or + ref $config eq 'IO::File') { + # If we have a file handle, just call the reader + print "Reading config from file handle\n" if _INTERNAL_DEBUG; + @text = @{ $base_configurator->file_h_read( $config ) }; + + } elsif (ref $config) { + # Caller provided a config parser object, which already + # knows which file (or DB or whatever) to parse. + print "Reading config from parser object\n" if _INTERNAL_DEBUG; + $data = $config->parse(); + return $data; + + } elsif ($config =~ m|^ldap://|){ + if(! Log::Log4perl::Util::module_available("Net::LDAP")) { + die "Log4perl: missing Net::LDAP needed to parse LDAP urls\n$@\n"; + } + + require Net::LDAP; + require Log::Log4perl::Config::LDAPConfigurator; + + return Log::Log4perl::Config::LDAPConfigurator->new->parse($config); + + } else { + + if ($config =~ /^(https?|ftp|wais|gopher|file):/){ + my ($result, $ua); + + die "LWP::UserAgent not available" unless + Log::Log4perl::Util::module_available("LWP::UserAgent"); + + require LWP::UserAgent; + unless (defined $LWP_USER_AGENT) { + $LWP_USER_AGENT = LWP::UserAgent->new; + + # Load proxy settings from environment variables, i.e.: + # http_proxy, ftp_proxy, no_proxy etc (see LWP::UserAgent) + # You need these to go thru firewalls. + $LWP_USER_AGENT->env_proxy; + } + $ua = $LWP_USER_AGENT; + + my $req = new HTTP::Request GET => $config; + my $res = $ua->request($req); + + if ($res->is_success) { + @text = split(/\n/, $res->content); + } else { + die "Log4perl couln't get $config, ". + $res->message." "; + } + } else { + print "Reading config from file '$config'\n" if _INTERNAL_DEBUG; + print "Reading ", -s $config, " bytes.\n" if _INTERNAL_DEBUG; + # Use the BaseConfigurator's file reader to avoid duplicating + # utf8 handling here. + $base_configurator->file( $config ); + @text = @{ $base_configurator->text() }; + } + } + + print "Reading $config: [@text]\n" if _INTERNAL_DEBUG; + + if(! grep /\S/, @text) { + return $data; + } + + if ($text[0] =~ /^<\?xml /) { + + die "XML::DOM not available" unless + Log::Log4perl::Util::module_available("XML::DOM"); + + require XML::DOM; + require Log::Log4perl::Config::DOMConfigurator; + + XML::DOM->VERSION($Log::Log4perl::DOM_VERSION_REQUIRED); + $parser = Log::Log4perl::Config::DOMConfigurator->new(); + $data = $parser->parse(\@text); + } else { + $parser = Log::Log4perl::Config::PropertyConfigurator->new(); + $data = $parser->parse(\@text); + } + + $data = $parser->parse_post_process( $data, leaf_paths($data) ); + + return $data; +} + +########################################### +sub unlog4j { +########################################### + my ($string) = @_; + + $string =~ s#^org\.apache\.##; + $string =~ s#^log4j\.##; + $string =~ s#^l4p\.##; + $string =~ s#^log4perl\.##i; + + $string =~ s#\.#::#g; + + return $string; +} + +############################################################ +sub leaf_paths { +############################################################ +# Takes a reference to a hash of hashes structure of +# arbitrary depth, walks the tree and returns a reference +# to an array of all possible leaf paths (each path is an +# array again). +# Example: { a => { b => { c => d }, e => f } } would generate +# [ [a, b, c, d], [a, e, f] ] +############################################################ + my ($root) = @_; + + my @stack = (); + my @result = (); + + push @stack, [$root, []]; + + while(@stack) { + my $item = pop @stack; + + my($node, $path) = @$item; + + if(ref($node) eq "HASH") { + for(keys %$node) { + push @stack, [$node->{$_}, [@$path, $_]]; + } + } else { + push @result, [@$path, $node]; + } + } + return \@result; +} + +########################################### +sub leaf_path_to_hash { +########################################### + my($leaf_path, $data) = @_; + + my $ref = \$data; + + for my $part ( @$leaf_path[0..$#$leaf_path-1] ) { + $ref = \$$ref->{ $part }; + } + + return $ref; +} + +########################################### +sub eval_if_perl { +########################################### + my($value) = @_; + + if(my $cref = compile_if_perl($value)) { + return $cref->(); + } + + return $value; +} + +########################################### +sub compile_if_perl { +########################################### + my($value) = @_; + + if($value =~ /^\s*sub\s*{/ ) { + my $mask; + unless( Log::Log4perl::Config->allow_code() ) { + die "\$Log::Log4perl::Config->allow_code() setting " . + "prohibits Perl code in config file"; + } + if( defined( $mask = Log::Log4perl::Config->allowed_code_ops() ) ) { + return compile_in_safe_cpt($value, $mask ); + } + elsif( $mask = Log::Log4perl::Config->allowed_code_ops_convenience_map( + Log::Log4perl::Config->allow_code() + ) ) { + return compile_in_safe_cpt($value, $mask ); + } + elsif( Log::Log4perl::Config->allow_code() == 1 ) { + + # eval without restriction + my $cref = eval "package main; $value" or + die "Can't evaluate '$value' ($@)"; + return $cref; + } + else { + die "Invalid value for \$Log::Log4perl::Config->allow_code(): '". + Log::Log4perl::Config->allow_code() . "'"; + } + } + + return undef; +} + +########################################### +sub compile_in_safe_cpt { +########################################### + my($value, $allowed_ops) = @_; + + # set up a Safe compartment + require Safe; + my $safe = Safe->new(); + $safe->permit_only( @{ $allowed_ops } ); + + # share things with the compartment + for( keys %{ Log::Log4perl::Config->vars_shared_with_safe_compartment() } ) { + my $toshare = Log::Log4perl::Config->vars_shared_with_safe_compartment($_); + $safe->share_from( $_, $toshare ) + or die "Can't share @{ $toshare } with Safe compartment"; + } + + # evaluate with restrictions + my $cref = $safe->reval("package main; $value") or + die "Can't evaluate '$value' in Safe compartment ($@)"; + return $cref; + +} + +########################################### +sub boolean_to_perlish { +########################################### + my($value) = @_; + + # Translate boolean to perlish + $value = 1 if $value =~ /^true$/i; + $value = 0 if $value =~ /^false$/i; + + return $value; +} + +########################################### +sub vars_shared_with_safe_compartment { +########################################### + my($class, @args) = @_; + + # Allow both for ...::Config::foo() and ...::Config->foo() + if(defined $class and $class ne __PACKAGE__) { + unshift @args, $class; + } + + # handle different invocation styles + if(@args == 1 && ref $args[0] eq 'HASH' ) { + # replace entire hash of vars + %Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT = %{$args[0]}; + } + elsif( @args == 1 ) { + # return vars for given package + return $Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT{ + $args[0]}; + } + elsif( @args == 2 ) { + # add/replace package/var pair + $Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT{ + $args[0]} = $args[1]; + } + + return wantarray ? %Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT + : \%Log::Log4perl::VARS_SHARED_WITH_SAFE_COMPARTMENT; + +} + +########################################### +sub allowed_code_ops { +########################################### + my($class, @args) = @_; + + # Allow both for ...::Config::foo() and ...::Config->foo() + if(defined $class and $class ne __PACKAGE__) { + unshift @args, $class; + } + + if(@args) { + @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE = @args; + } + else { + # give back 'undef' instead of an empty arrayref + unless( @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE ) { + return; + } + } + + return wantarray ? @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE + : \@Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +} + +########################################### +sub allowed_code_ops_convenience_map { +########################################### + my($class, @args) = @_; + + # Allow both for ...::Config::foo() and ...::Config->foo() + if(defined $class and $class ne __PACKAGE__) { + unshift @args, $class; + } + + # handle different invocation styles + if( @args == 1 && ref $args[0] eq 'HASH' ) { + # replace entire map + %Log::Log4perl::ALLOWED_CODE_OPS = %{$args[0]}; + } + elsif( @args == 1 ) { + # return single opcode mask + return $Log::Log4perl::ALLOWED_CODE_OPS{ + $args[0]}; + } + elsif( @args == 2 ) { + # make sure the mask is an array ref + if( ref $args[1] ne 'ARRAY' ) { + die "invalid mask (not an array ref) for convenience name '$args[0]'"; + } + # add name/mask pair + $Log::Log4perl::ALLOWED_CODE_OPS{ + $args[0]} = $args[1]; + } + + return wantarray ? %Log::Log4perl::ALLOWED_CODE_OPS + : \%Log::Log4perl::ALLOWED_CODE_OPS +} + +########################################### +sub allow_code { +########################################### + my($class, @args) = @_; + + # Allow both for ...::Config::foo() and ...::Config->foo() + if(defined $class and $class ne __PACKAGE__) { + unshift @args, $class; + } + + if(@args) { + $Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE = + $args[0]; + } + + return $Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE; +} + +################################################ +sub var_subst { +################################################ + my($varname, $subst_hash) = @_; + + # Throw out blanks + $varname =~ s/\s+//g; + + if(exists $subst_hash->{$varname}) { + print "Replacing variable: '$varname' => '$subst_hash->{$varname}'\n" + if _INTERNAL_DEBUG; + return $subst_hash->{$varname}; + + } elsif(exists $ENV{$varname}) { + print "Replacing ENV variable: '$varname' => '$ENV{$varname}'\n" + if _INTERNAL_DEBUG; + return $ENV{$varname}; + + } + + die "Undefined Variable '$varname'"; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Config - Log4perl configuration file syntax + +=head1 DESCRIPTION + +In C<Log::Log4perl>, configuration files are used to describe how the +system's loggers ought to behave. + +The format is the same as the one as used for C<log4j>, just with +a few perl-specific extensions, like enabling the C<Bar::Twix> +syntax instead of insisting on the Java-specific C<Bar.Twix>. + +Comment lines and blank lines (all whitespace or empty) are ignored. + +Comment lines may start with arbitrary whitespace followed by one of: + +=over 4 + +=item # - Common comment delimiter + +=item ! - Java .properties file comment delimiter accepted by log4j + +=item ; - Common .ini file comment delimiter + +=back + +Comments at the end of a line are not supported. So if you write + + log4perl.appender.A1.filename=error.log #in current dir + +you will find your messages in a file called C<error.log #in current dir>. + +Also, blanks between syntactical entities are ignored, it doesn't +matter if you write + + log4perl.logger.Bar.Twix=WARN,Screen + +or + + log4perl.logger.Bar.Twix = WARN, Screen + +C<Log::Log4perl> will strip the blanks while parsing your input. + +Assignments need to be on a single line. However, you can break the +line if you want to by using a continuation character at the end of the +line. Instead of writing + + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + +you can break the line at any point by putting a backslash at the very (!) +end of the line to be continued: + + log4perl.appender.A1.layout=\ + Log::Log4perl::Layout::SimpleLayout + +Watch out for trailing blanks after the backslash, which would prevent +the line from being properly concatenated. + +=head2 Loggers + +Loggers are addressed by category: + + log4perl.logger.Bar.Twix = WARN, Screen + +This sets all loggers under the C<Bar::Twix> hierarchy on priority +C<WARN> and attaches a later-to-be-defined C<Screen> appender to them. +Settings for the root appender (which doesn't have a name) can be +accomplished by simply omitting the name: + + log4perl.logger = FATAL, Database, Mailer + +This sets the root appender's level to C<FATAL> and also attaches the +later-to-be-defined appenders C<Database> and C<Mailer> to it. + +The additivity flag of a logger is set or cleared via the +C<additivity> keyword: + + log4perl.additivity.Bar.Twix = 0|1 + +(Note the reversed order of keyword and logger name, resulting +from the dilemma that a logger name could end in C<.additivity> +according to the log4j documentation). + +=head2 Appenders and Layouts + +Appender names used in Log4perl configuration file +lines need to be resolved later on, in order to +define the appender's properties and its layout. To specify properties +of an appender, just use the C<appender> keyword after the +C<log4perl> intro and the appender's name: + + # The Bar::Twix logger and its appender + log4perl.logger.Bar.Twix = DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::File + log4perl.appender.A1.filename=test.log + log4perl.appender.A1.mode=append + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + +This sets a priority of C<DEBUG> for loggers in the C<Bar::Twix> +hierarchy and assigns the C<A1> appender to it, which is later on +resolved to be an appender of type C<Log::Log4perl::Appender::File>, simply +appending to a log file. According to the C<Log::Log4perl::Appender::File> +manpage, the C<filename> parameter specifies the name of the log file +and the C<mode> parameter can be set to C<append> or C<write> (the +former will append to the logfile if one with the specified name +already exists while the latter would clobber and overwrite it). + +The order of the entries in the configuration file is not important, +C<Log::Log4perl> will read in the entire file first and try to make +sense of the lines after it knows the entire context. + +You can very well define all loggers first and then their appenders +(you could even define your appenders first and then your loggers, +but let's not go there): + + log4perl.logger.Bar.Twix = DEBUG, A1 + log4perl.logger.Bar.Snickers = FATAL, A2 + + log4perl.appender.A1=Log::Log4perl::Appender::File + log4perl.appender.A1.filename=test.log + log4perl.appender.A1.mode=append + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + + log4perl.appender.A2=Log::Log4perl::Appender::Screen + log4perl.appender.A2.stderr=0 + log4perl.appender.A2.layout=Log::Log4perl::Layout::PatternLayout + log4perl.appender.A2.layout.ConversionPattern = %d %m %n + +Note that you have to specify the full path to the layout class +and that C<ConversionPattern> is the keyword to specify the printf-style +formatting instructions. + +=head1 Configuration File Cookbook + +Here's some examples of often-used Log4perl configuration files: + +=head2 Append to STDERR + + log4perl.category.Bar.Twix = WARN, Screen + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.Screen.layout.ConversionPattern = %d %m %n + +=head2 Append to STDOUT + + log4perl.category.Bar.Twix = WARN, Screen + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.stderr = 0 + log4perl.appender.Screen.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.Screen.layout.ConversionPattern = %d %m %n + +=head2 Append to a log file + + log4perl.logger.Bar.Twix = DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::File + log4perl.appender.A1.filename=test.log + log4perl.appender.A1.mode=append + log4perl.appender.A1.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.A1.layout.ConversionPattern = %d %m %n + +Note that you could even leave out + + log4perl.appender.A1.mode=append + +and still have the logger append to the logfile by default, although +the C<Log::Log4perl::Appender::File> module does exactly the opposite. +This is due to some nasty trickery C<Log::Log4perl> performs behind +the scenes to make sure that beginner's CGI applications don't clobber +the log file every time they're called. + +=head2 Write a log file from scratch + +If you loathe the Log::Log4perl's append-by-default strategy, you can +certainly override it: + + log4perl.logger.Bar.Twix = DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::File + log4perl.appender.A1.filename=test.log + log4perl.appender.A1.mode=write + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + +C<write> is the C<mode> that has C<Log::Log4perl::Appender::File> +explicitly clobber the log file if it exists. + +=head2 Configuration files encoded in utf-8 + +If your configuration file is encoded in utf-8 (which matters if you +e.g. specify utf8-encoded appender filenames in it), then you need to +tell Log4perl before running init(): + + use Log::Log4perl::Config; + Log::Log4perl::Config->utf( 1 ); + + Log::Log4perl->init( ... ); + +This makes sure Log4perl interprets utf8-encoded config files correctly. +This setting might become the default at some point. + +=head1 SEE ALSO + +Log::Log4perl::Config::PropertyConfigurator + +Log::Log4perl::Config::DOMConfigurator + +Log::Log4perl::Config::LDAPConfigurator (coming soon!) + +=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. + diff --git a/lib/Log/Log4perl/Config/BaseConfigurator.pm b/lib/Log/Log4perl/Config/BaseConfigurator.pm new file mode 100644 index 0000000..84a782a --- /dev/null +++ b/lib/Log/Log4perl/Config/BaseConfigurator.pm @@ -0,0 +1,345 @@ +package 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 <dgregor@redhat.com> 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<file>, the derived class C<SomeConfigParser> may define any +type of configuration input medium (e.g. C<url =E<gt> 'http://foobar'>). +It just has to make sure its C<parse()> 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<parse()> 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<file> or C<text> parameters have been specified in the +constructor call, a later call to the configurator's C<text()> method +will return a reference to an array of configuration text lines. +This will typically be used by the C<parse()> 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<parse()> method returns a reference to a hash of hashes (HoH). +The top-most hash contains the +top-level keywords (C<category>, C<appender>) as keys, associated +with values which are references to more deeply nested hashes. + +=item * + +The C<log4perl.> 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<value> 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<parse()> 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<eg/yamlparser>. 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 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. + diff --git a/lib/Log/Log4perl/Config/DOMConfigurator.pm b/lib/Log/Log4perl/Config/DOMConfigurator.pm new file mode 100644 index 0000000..dee6ef2 --- /dev/null +++ b/lib/Log/Log4perl/Config/DOMConfigurator.pm @@ -0,0 +1,912 @@ +package 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 <sql>...</sql> +# DONE see DEBUG!!! below +# NO, (really is only used for AsyncAppender) appender-ref in <appender> +# 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? +# DONE see 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 custom 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 + } +} + + +#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-- + -------------------------- + + <?xml version="1.0" encoding="UTF-8"?> + <!DOCTYPE log4j:configuration SYSTEM "log4j.dtd"> + + <log4j:configuration xmlns:log4j="http://jakarta.apache.org/log4j/"> + + <appender name="FileAppndr1" class="org.apache.log4j.FileAppender"> + <layout class="Log::Log4perl::Layout::PatternLayout"> + <param name="ConversionPattern" + value="%d %4r [%t] %-5p %c %t - %m%n"/> + </layout> + <param name="File" value="t/tmp/DOMtest"/> + <param name="Append" value="false"/> + </appender> + + <category name="a.b.c.d" additivity="false"> + <level value="warn"/> <!-- note lowercase! --> + <appender-ref ref="FileAppndr1"/> + </category> + + <root> + <priority value="warn"/> + <appender-ref ref="FileAppndr1"/> + </root> + + </log4j:configuration> + + + + -------------------------- + --using the log4perl DTD-- + -------------------------- + + <?xml version="1.0" encoding="UTF-8"?> + <!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + + <log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/" + threshold="debug" oneMessagePerAppender="true"> + + <log4perl:appender name="jabbender" class="Log::Dispatch::Jabber"> + + <param-nested name="login"> + <param name="hostname" value="a.jabber.server"/> + <param name="password" value="12345"/> + <param name="port" value="5222"/> + <param name="resource" value="logger"/> + <param name="username" value="bobjones"/> + </param-nested> + + <param name="to" value="bob@a.jabber.server"/> + + <param-text name="to"> + mary@another.jabber.server + </param-text> + + <log4perl:layout class="org.apache.log4j.PatternLayout"> + <param name="ConversionPattern" value = "%K xx %G %U"/> + <cspec name="K"> + sub { return sprintf "%1x", $$} + </cspec> + <cspec name="G"> + sub {return 'thisistheGcspec'} + </cspec> + </log4perl:layout> + </log4perl:appender> + + <log4perl:appender name="DBAppndr2" class="Log::Log4perl::Appender::DBI"> + <param name="warp_message" value="0"/> + <param name="datasource" value="DBI:CSV:f_dir=t/tmp"/> + <param name="bufferSize" value="2"/> + <param name="password" value="sub { $ENV{PWD} }"/> + <param name="username" value="bobjones"/> + + <param-text name="sql"> + INSERT INTO log4perltest + (loglevel, message, shortcaller, thingid, + category, pkg, runtime1, runtime2) + VALUES + (?,?,?,?,?,?,?,?) + </param-text> + + <param-nested name="params"> + <param name="1" value="%p"/> + <param name="3" value="%5.5l"/> + <param name="5" value="%c"/> + <param name="6" value="%C"/> + </param-nested> + + <layout class="Log::Log4perl::Layout::NoopLayout"/> + </log4perl:appender> + + <category name="animal.dog"> + <priority value="info"/> + <appender-ref ref="jabbender"/> + <appender-ref ref="DBAppndr2"/> + </category> + + <category name="plant"> + <priority value="debug"/> + <appender-ref ref="DBAppndr2"/> + </category> + + <PatternLayout> + <cspec name="U"><![CDATA[ + sub { + return "UID $< GID $("; + } + ]]></cspec> + </PatternLayout> + + </log4perl:configuration> + + + + +=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 <?xml...> declaration +in your config file: + + <!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +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<Log::Log4perl::Filter>, +lots of examples in t/044XML-Filter.t, here's a short one: + + + <?xml version="1.0" encoding="UTF-8"?> + <!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + + <log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/"> + + <appender name="A1" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <filter class="Log::Log4perl::Filter::Boolean"> + <param name="logic" value="!Match3 && (Match1 || Match2)"/> + </filter> + </appender> + + <appender name="A2" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <filter-ref id="Match1"/> + </appender> + + <log4perl:filter name="Match1" value="sub { /let this through/ }" /> + + <log4perl:filter name="Match2"> + sub { + /and that, too/ + } + </log4perl:filter> + + <log4perl:filter name="Match3" class="Log::Log4perl::Filter::StringMatch"> + <param name="StringToMatch" value="suppress"/> + <param name="AcceptOnMatch" value="true"/> + </log4perl:filter> + + <log4perl:filter name="MyBoolean" class="Log::Log4perl::Filter::Boolean"> + <param name="logic" value="!Match3 && (Match1 || Match2)"/> + </log4perl:filter> + + + <root> + <priority value="info"/> + <appender-ref ref="A1"/> + </root> + + </log4perl:configuration> + + +=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 <log4perl:configuration> + +handles #1) and accepts <PatternLayout> + +=item <log4perl:appender> + +accepts <param-nested> and <param-text> + +=item <log4perl:layout> + +accepts custom cspecs for #3) + +=back + +=item * + +added a <param-nested> element (complementing the <param> element) + to handle #4) + +=item * + +added a root <PatternLayout> element to handle #2) + +=item * + +added <param-text> 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 <cspec> + +=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<in situ>, so I used namespaces +to extend it. If you really don't like having to type <log4perl:appender> +instead of just <appender>, 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 + + <param name="${hostname}" value="${hostnameval}.foo.com"/> + <param-text name="to">${currentsysadmin}@foo.com</param-text> + + +=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 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. + diff --git a/lib/Log/Log4perl/Config/PropertyConfigurator.pm b/lib/Log/Log4perl/Config/PropertyConfigurator.pm new file mode 100644 index 0000000..b633fb2 --- /dev/null +++ b/lib/Log/Log4perl/Config/PropertyConfigurator.pm @@ -0,0 +1,220 @@ +package 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 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. + diff --git a/lib/Log/Log4perl/Config/Watch.pm b/lib/Log/Log4perl/Config/Watch.pm new file mode 100644 index 0000000..0537018 --- /dev/null +++ b/lib/Log/Log4perl/Config/Watch.pm @@ -0,0 +1,353 @@ +package 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<Log::Log4perl> distribution, it can be used independently. + +The constructor defines the file to be watched and the check interval +in seconds. Subsequent calls to C<change_detected()> will + +=over 4 + +=item * + +return a false value immediately without doing physical file checks +if C<check_interval> hasn't elapsed. + +=item * + +perform a physical test on the specified file if the number +of seconds specified in C<check_interval> +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<check_interval> allows you to call the function +C<change_detected()> 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<check_interval> 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<check_interval> +to 0 and C<change_detected()> will run a physical file test on +every call. + +If you already have the current time available, you can pass it +on to C<change_detected()> as an optional parameter, like in + + change_detected($time) + +which then won't trigger a call to C<time()>, but use the value +provided. + +=head2 SIGNAL MODE + +Instead of polling time and file changes, C<new()> 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<gt>{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<change_detected()> +regardless if C<check_interval> 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<check_interval> and C<signal> limit the number of physical +file system checks, similarily as with C<change_detected()>. + +=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. + diff --git a/lib/Log/Log4perl/DateFormat.pm b/lib/Log/Log4perl/DateFormat.pm new file mode 100755 index 0000000..2ff8c0f --- /dev/null +++ b/lib/Log/Log4perl/DateFormat.pm @@ -0,0 +1,461 @@ +########################################### +package Log::Log4perl::DateFormat; +########################################### +use warnings; +use strict; + +use Carp qw( croak ); + +our $GMTIME = 0; + +my @MONTH_NAMES = qw( +January February March April May June July +August September October November December); + +my @WEEK_DAYS = qw( +Sunday Monday Tuesday Wednesday Thursday Friday Saturday); + +########################################### +sub new { +########################################### + my($class, $format) = @_; + + my $self = { + stack => [], + fmt => undef, + }; + + bless $self, $class; + + # Predefined formats + if($format eq "ABSOLUTE") { + $format = "HH:mm:ss,SSS"; + } elsif($format eq "DATE") { + $format = "dd MMM yyyy HH:mm:ss,SSS"; + } elsif($format eq "ISO8601") { + $format = "yyyy-MM-dd HH:mm:ss,SSS"; + } elsif($format eq "APACHE") { + $format = "[EEE MMM dd HH:mm:ss yyyy]"; + } + + if($format) { + $self->prepare($format); + } + + return $self; +} + +########################################### +sub prepare { +########################################### + my($self, $format) = @_; + + # the actual DateTime spec allows for literal text delimited by + # single quotes; a single quote can be embedded in the literal + # text by using two single quotes. + # + # my strategy here is to split the format into active and literal + # "chunks"; active chunks are prepared using $self->rep() as + # before, while literal chunks get transformed to accommodate + # single quotes and to protect percent signs. + # + # motivation: the "recommended" ISO-8601 date spec for a time in + # UTC is actually: + # + # YYYY-mm-dd'T'hh:mm:ss.SSS'Z' + + my $fmt = ""; + + foreach my $chunk ( split /('(?:''|[^'])*')/, $format ) { + if ( $chunk =~ /\A'(.*)'\z/ ) { + # literal text + my $literal = $1; + $literal =~ s/''/'/g; + $literal =~ s/\%/\%\%/g; + $fmt .= $literal; + } elsif ( $chunk =~ /'/ ) { + # single quotes should always be in a literal + croak "bad date format \"$format\": " . + "unmatched single quote in chunk \"$chunk\""; + } else { + # handle active chunks just like before + $chunk =~ s/(([GyMdhHmsSEeDFwWakKzZ])\2*)/$self->rep($1)/ge; + $fmt .= $chunk; + } + } + + return $self->{fmt} = $fmt; +} + +########################################### +sub rep { +########################################### + my ($self, $string) = @_; + + my $first = substr $string, 0, 1; + my $len = length $string; + + my $time=time(); + my @g = gmtime($time); + my @t = localtime($time); + my $z = $t[1]-$g[1]+($t[2]-$g[2])*60+($t[7]-$g[7])*1440+ + ($t[5]-$g[5])*(525600+(abs($t[7]-$g[7])>364)*1440); + my $offset = sprintf("%+.2d%.2d", $z/60, "00"); + + #my ($s,$mi,$h,$d,$mo,$y,$wd,$yd,$dst) = localtime($time); + + # Here's how this works: + # Detect what kind of parameter we're dealing with and determine + # what type of sprintf-placeholder to return (%d, %02d, %s or whatever). + # Then, we're setting up an array, specific to the current format, + # that can be used later on to compute the components of the placeholders + # one by one when we get the components of the current time later on + # via localtime. + + # So, we're parsing the "yyyy/MM" format once, replace it by, say + # "%04d:%02d" and store an array that says "for the first placeholder, + # get the localtime-parameter on index #5 (which is years since the + # epoch), add 1900 to it and pass it on to sprintf(). For the 2nd + # placeholder, get the localtime component at index #2 (which is hours) + # and pass it on unmodified to sprintf. + + # So, the array to compute the time format at logtime contains + # as many elements as the original SimpleDateFormat contained. Each + # entry is a array ref, holding an array with 2 elements: The index + # into the localtime to obtain the value and a reference to a subroutine + # to do computations eventually. The subroutine expects the original + # localtime() time component (like year since the epoch) and returns + # the desired value for sprintf (like y+1900). + + # This way, we're parsing the original format only once (during system + # startup) and during runtime all we do is call localtime *once* and + # run a number of blazingly fast computations, according to the number + # of placeholders in the format. + +########### +#G - epoch# +########### + if($first eq "G") { + # Always constant + return "AD"; + +################### +#e - epoch seconds# +################### + } elsif($first eq "e") { + # index (0) irrelevant, but we return time() which + # comes in as 2nd parameter + push @{$self->{stack}}, [0, sub { return $_[1] }]; + return "%d"; + +########## +#y - year# +########## + } elsif($first eq "y") { + if($len >= 4) { + # 4-digit year + push @{$self->{stack}}, [5, sub { return $_[0] + 1900 }]; + return "%04d"; + } else { + # 2-digit year + push @{$self->{stack}}, [5, sub { $_[0] % 100 }]; + return "%02d"; + } + +########### +#M - month# +########### + } elsif($first eq "M") { + if($len >= 3) { + # Use month name + push @{$self->{stack}}, [4, sub { return $MONTH_NAMES[$_[0]] }]; + if($len >= 4) { + return "%s"; + } else { + return "%.3s"; + } + } elsif($len == 2) { + # Use zero-padded month number + push @{$self->{stack}}, [4, sub { $_[0]+1 }]; + return "%02d"; + } else { + # Use zero-padded month number + push @{$self->{stack}}, [4, sub { $_[0]+1 }]; + return "%d"; + } + +################## +#d - day of month# +################## + } elsif($first eq "d") { + push @{$self->{stack}}, [3, sub { return $_[0] }]; + return "%0" . $len . "d"; + +################## +#h - am/pm hour# +################## + } elsif($first eq "h") { + push @{$self->{stack}}, [2, sub { ($_[0] % 12) || 12 }]; + return "%0" . $len . "d"; + +################## +#H - 24 hour# +################## + } elsif($first eq "H") { + push @{$self->{stack}}, [2, sub { return $_[0] }]; + return "%0" . $len . "d"; + +################## +#m - minute# +################## + } elsif($first eq "m") { + push @{$self->{stack}}, [1, sub { return $_[0] }]; + return "%0" . $len . "d"; + +################## +#s - second# +################## + } elsif($first eq "s") { + push @{$self->{stack}}, [0, sub { return $_[0] }]; + return "%0" . $len . "d"; + +################## +#E - day of week # +################## + } elsif($first eq "E") { + push @{$self->{stack}}, [6, sub { $WEEK_DAYS[$_[0]] }]; + if($len >= 4) { + return "%${len}s"; + } else { + return "%.3s"; + } + +###################### +#D - day of the year # +###################### + } elsif($first eq "D") { + push @{$self->{stack}}, [7, sub { $_[0] + 1}]; + return "%0" . $len . "d"; + +###################### +#a - am/pm marker # +###################### + } elsif($first eq "a") { + push @{$self->{stack}}, [2, sub { $_[0] < 12 ? "AM" : "PM" }]; + return "%${len}s"; + +###################### +#S - milliseconds # +###################### + } elsif($first eq "S") { + push @{$self->{stack}}, + [9, sub { substr sprintf("%06d", $_[0]), 0, $len }]; + return "%s"; + +############################### +#Z - RFC 822 time zone -0800 # +############################### + } elsif($first eq "Z") { + push @{$self->{stack}}, [10, sub { $offset }]; + return "$offset"; + +############################# +#Something that's not defined +#(F=day of week in month +# w=week in year W=week in month +# k=hour in day K=hour in am/pm +# z=timezone +############################# + } else { + return "-- '$first' not (yet) implemented --"; + } + + return $string; +} + +########################################### +sub format { +########################################### + my($self, $secs, $msecs) = @_; + + $msecs = 0 unless defined $msecs; + + my @time; + + if($GMTIME) { + @time = gmtime($secs); + } else { + @time = localtime($secs); + } + + # add milliseconds + push @time, $msecs; + + my @values = (); + + for(@{$self->{stack}}) { + my($val, $code) = @$_; + if($code) { + push @values, $code->($time[$val], $secs); + } else { + push @values, $time[$val]; + } + } + + return sprintf($self->{fmt}, @values); +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::DateFormat - Log4perl advanced date formatter helper class + +=head1 SYNOPSIS + + use Log::Log4perl::DateFormat; + + my $format = Log::Log4perl::DateFormat->new("HH:mm:ss,SSS"); + + # Simple time, resolution in seconds + my $time = time(); + print $format->format($time), "\n"; + # => "17:02:39,000" + + # Advanced time, resultion in milliseconds + use Time::HiRes; + my ($secs, $msecs) = Time::HiRes::gettimeofday(); + print $format->format($secs, $msecs), "\n"; + # => "17:02:39,959" + +=head1 DESCRIPTION + +C<Log::Log4perl::DateFormat> is a low-level helper class for the +advanced date formatting functions in C<Log::Log4perl::Layout::PatternLayout>. + +Unless you're writing your own Layout class like +L<Log::Log4perl::Layout::PatternLayout>, there's probably not much use +for you to read this. + +C<Log::Log4perl::DateFormat> is a formatter which allows dates to be +formatted according to the log4j spec on + + http://download.oracle.com/javase/1.4.2/docs/api/java/text/SimpleDateFormat.html + +which allows the following placeholders to be recognized and processed: + + Symbol Meaning Presentation Example + ------ ------- ------------ ------- + G era designator (Text) AD + e epoch seconds (Number) 1315011604 + y year (Number) 1996 + M month in year (Text & Number) July & 07 + d day in month (Number) 10 + h hour in am/pm (1~12) (Number) 12 + H hour in day (0~23) (Number) 0 + m minute in hour (Number) 30 + s second in minute (Number) 55 + S millisecond (Number) 978 + E day in week (Text) Tuesday + D day in year (Number) 189 + F day of week in month (Number) 2 (2nd Wed in July) + w week in year (Number) 27 + W week in month (Number) 2 + a am/pm marker (Text) PM + k hour in day (1~24) (Number) 24 + K hour in am/pm (0~11) (Number) 0 + z time zone (Text) Pacific Standard Time + Z RFC 822 time zone (Text) -0800 + ' escape for text (Delimiter) + '' single quote (Literal) ' + +For example, if you want to format the current Unix time in +C<"MM/dd HH:mm"> format, all you have to do is this: + + use Log::Log4perl::DateFormat; + + my $format = Log::Log4perl::DateFormat->new("MM/dd HH:mm"); + + my $time = time(); + print $format->format($time), "\n"; + +While the C<new()> method is expensive, because it parses the format +strings and sets up all kinds of structures behind the scenes, +followup calls to C<format()> are fast, because C<DateFormat> will +just call C<localtime()> and C<sprintf()> once to return the formatted +date/time string. + +So, typically, you would initialize the formatter once and then reuse +it over and over again to display all kinds of time values. + +Also, for your convenience, +the following predefined formats are available, just as outlined in the +log4j spec: + + Format Equivalent Example + ABSOLUTE "HH:mm:ss,SSS" "15:49:37,459" + DATE "dd MMM yyyy HH:mm:ss,SSS" "06 Nov 1994 15:49:37,459" + ISO8601 "yyyy-MM-dd HH:mm:ss,SSS" "1999-11-27 15:49:37,459" + APACHE "[EEE MMM dd HH:mm:ss yyyy]" "[Wed Mar 16 15:49:37 2005]" + +So, instead of passing + + Log::Log4perl::DateFormat->new("HH:mm:ss,SSS"); + +you could just as well say + + Log::Log4perl::DateFormat->new("ABSOLUTE"); + +and get the same result later on. + +=head2 Known Shortcomings + +The following placeholders are currently I<not> recognized, unless +someone (and that could be you :) implements them: + + F day of week in month + w week in year + W week in month + k hour in day + K hour in am/pm + z timezone (but we got 'Z' for the numeric time zone value) + +Also, C<Log::Log4perl::DateFormat> just knows about English week and +month names, internationalization support has to be added. + +=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. + diff --git a/lib/Log/Log4perl/FAQ.pm b/lib/Log/Log4perl/FAQ.pm new file mode 100644 index 0000000..c0c068b --- /dev/null +++ b/lib/Log/Log4perl/FAQ.pm @@ -0,0 +1,2682 @@ +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::FAQ - Frequently Asked Questions on Log::Log4perl + +=head1 DESCRIPTION + +This FAQ shows a wide variety of +commonly encountered logging tasks and how to solve them +in the most elegant way with Log::Log4perl. Most of the time, this will +be just a matter of smartly configuring your Log::Log4perl configuration files. + +=head2 Why use Log::Log4perl instead of any other logging module on CPAN? + +That's a good question. There's dozens of logging modules on CPAN. +When it comes to logging, people typically think: "Aha. Writing out +debug and error messages. Debug is lower than error. Easy. I'm gonna +write my own." Writing a logging module is like a rite of passage for +every Perl programmer, just like writing your own templating system. + +Of course, after getting the basics right, features need to +be added. You'd like to write a timestamp with every message. Then +timestamps with microseconds. Then messages need to be written to both +the screen and a log file. + +And, as your application grows in size you might wonder: Why doesn't +my logging system scale along with it? You would like to switch on +logging in selected parts of the application, and not all across the +board, because this kills performance. This is when people turn to +Log::Log4perl, because it handles all of that. + +Avoid this costly switch. + +Use C<Log::Log4perl> right from the start. C<Log::Log4perl>'s C<:easy> +mode supports easy logging in simple scripts: + + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init($DEBUG); + + DEBUG "A low-level message"; + ERROR "Won't make it until level gets increased to ERROR"; + +And when your application inevitably grows, your logging system grows +with it without you having to change any code. + +Please, don't re-invent logging. C<Log::Log4perl> is here, it's easy +to use, it scales, and covers many areas you haven't thought of yet, +but will enter soon. + +=head2 What's the easiest way to use Log4perl? + +If you just want to get all the comfort of logging, without much +overhead, use I<Stealth Loggers>. If you use Log::Log4perl in +C<:easy> mode like + + use Log::Log4perl qw(:easy); + +you'll have the following functions available in the current package: + + DEBUG("message"); + INFO("message"); + WARN("message"); + ERROR("message"); + FATAL("message"); + +Just make sure that every package of your code where you're using them in +pulls in C<use Log::Log4perl qw(:easy)> first, then you're set. +Every stealth logger's category will be equivalent to the name of the +package it's located in. + +These stealth loggers +will be absolutely silent until you initialize Log::Log4perl in +your main program with either + + # Define any Log4perl behavior + Log::Log4perl->init("foo.conf"); + +(using a full-blown Log4perl config file) or the super-easy method + + # Just log to STDERR + Log::Log4perl->easy_init($DEBUG); + +or the parameter-style method with a complexity somewhat in between: + + # Append to a log file + Log::Log4perl->easy_init( { level => $DEBUG, + file => ">>test.log" } ); + +For more info, please check out L<Log::Log4perl/"Stealth Loggers">. + +=head2 How can I simply log all my ERROR messages to a file? + +After pulling in the C<Log::Log4perl> module, just initialize its +behavior by passing in a configuration to its C<init> method as a string +reference. Then, obtain a logger instance and write out a message +with its C<error()> method: + + use Log::Log4perl qw(get_logger); + + # Define configuration + my $conf = q( + log4perl.logger = ERROR, FileApp + log4perl.appender.FileApp = Log::Log4perl::Appender::File + log4perl.appender.FileApp.filename = test.log + log4perl.appender.FileApp.layout = PatternLayout + log4perl.appender.FileApp.layout.ConversionPattern = %d> %m%n + ); + + # Initialize logging behavior + Log::Log4perl->init( \$conf ); + + # Obtain a logger instance + my $logger = get_logger("Bar::Twix"); + $logger->error("Oh my, a dreadful error!"); + $logger->warn("Oh my, a dreadful warning!"); + +This will append something like + + 2002/10/29 20:11:55> Oh my, a dreadful error! + +to the log file C<test.log>. How does this all work? + +While the Log::Log4perl C<init()> method typically +takes the name of a configuration file as its input parameter like +in + + Log::Log4perl->init( "/path/mylog.conf" ); + +the example above shows how to pass in a configuration as text in a +scalar reference. + +The configuration as shown +defines a logger of the root category, which has an appender of type +C<Log::Log4perl::Appender::File> attached. The line + + log4perl.logger = ERROR, FileApp + +doesn't list a category, defining a root logger. Compare that with + + log4perl.logger.Bar.Twix = ERROR, FileApp + +which would define a logger for the category C<Bar::Twix>, +showing probably different behavior. C<FileApp> on +the right side of the assignment is +an arbitrarily defined variable name, which is only used to somehow +reference an appender defined later on. + +Appender settings in the configuration are defined as follows: + + log4perl.appender.FileApp = Log::Log4perl::Appender::File + log4perl.appender.FileApp.filename = test.log + +It selects the file appender of the C<Log::Log4perl::Appender> +hierarchy, which will append to the file C<test.log> if it already +exists. If we wanted to overwrite a potentially existing file, we would +have to explicitly set the appropriate C<Log::Log4perl::Appender::File> +parameter C<mode>: + + log4perl.appender.FileApp = Log::Log4perl::Appender::File + log4perl.appender.FileApp.filename = test.log + log4perl.appender.FileApp.mode = write + +Also, the configuration defines a PatternLayout format, adding +the nicely formatted current date and time, an arrow (E<gt>) and +a space before the messages, which is then followed by a newline: + + log4perl.appender.FileApp.layout = PatternLayout + log4perl.appender.FileApp.layout.ConversionPattern = %d> %m%n + +Obtaining a logger instance and actually logging something is typically +done in a different system part as the Log::Log4perl initialisation section, +but in this example, it's just done right after init for the +sake of compactness: + + # Obtain a logger instance + my $logger = get_logger("Bar::Twix"); + $logger->error("Oh my, a dreadful error!"); + +This retrieves an instance of the logger of the category C<Bar::Twix>, +which, as all other categories, inherits behavior from the root logger if no +other loggers are defined in the initialization section. + +The C<error()> +method fires up a message, which the root logger catches. Its +priority is equal to +or higher than the root logger's priority (ERROR), which causes the root logger +to forward it to its attached appender. By contrast, the following + + $logger->warn("Oh my, a dreadful warning!"); + +doesn't make it through, because the root logger sports a higher setting +(ERROR and up) than the WARN priority of the message. + +=head2 How can I install Log::Log4perl on Microsoft Windows? + +You can install Log::Log4perl using the CPAN client. + +Alternatively you can install it using + + ppm install Log-Log4perl + +if you're using ActiveState perl. + + +That's it! Afterwards, just create a Perl script like + + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init($DEBUG); + + my $logger = get_logger("Twix::Bar"); + $logger->debug("Watch me!"); + +and run it. It should print something like + + 2002/11/06 01:22:05 Watch me! + +If you find that something doesn't work, please let us know at +log4perl-devel@lists.sourceforge.net -- we'll appreciate it. Have fun! + +=head2 How can I include global (thread-specific) data in my log messages? + +Say, you're writing a web application and want all your +log messages to include the current client's IP address. Most certainly, +you don't want to include it in each and every log message like in + + $logger->debug( $r->connection->remote_ip, + " Retrieving user data from DB" ); + +do you? Instead, you want to set it in a global data structure and +have Log::Log4perl include it automatically via a PatternLayout setting +in the configuration file: + + log4perl.appender.FileApp.layout.ConversionPattern = %X{ip} %m%n + +The conversion specifier C<%X{ip}> references an entry under the key +C<ip> in the global C<MDC> (mapped diagnostic context) table, which +you've set once via + + Log::Log4perl::MDC->put("ip", $r->connection->remote_ip); + +at the start of the request handler. Note that this is a +I<static> (class) method, there's no logger object involved. +You can use this method with as many key/value pairs as you like as long +as you reference them under different names. + +The mappings are stored in a global hash table within Log::Log4perl. +Luckily, because the thread +model in 5.8.0 doesn't share global variables between threads unless +they're explicitly marked as such, there's no problem with multi-threaded +environments. + +For more details on the MDC, please refer to +L<Log::Log4perl/"Mapped Diagnostic Context (MDC)"> and +L<Log::Log4perl::MDC>. + +=head2 My application is already logging to a file. How can I duplicate all messages to also go to the screen? + +Assuming that you already have a Log4perl configuration file like + + log4perl.logger = DEBUG, FileApp + + log4perl.appender.FileApp = Log::Log4perl::Appender::File + log4perl.appender.FileApp.filename = test.log + log4perl.appender.FileApp.layout = PatternLayout + log4perl.appender.FileApp.layout.ConversionPattern = %d> %m%n + +and log statements all over your code, +it's very easy with Log4perl to have the same messages both printed to +the logfile and the screen. No reason to change your code, of course, +just add another appender to the configuration file and you're done: + + log4perl.logger = DEBUG, FileApp, ScreenApp + + log4perl.appender.FileApp = Log::Log4perl::Appender::File + log4perl.appender.FileApp.filename = test.log + log4perl.appender.FileApp.layout = PatternLayout + log4perl.appender.FileApp.layout.ConversionPattern = %d> %m%n + + log4perl.appender.ScreenApp = Log::Log4perl::Appender::Screen + log4perl.appender.ScreenApp.stderr = 0 + log4perl.appender.ScreenApp.layout = PatternLayout + log4perl.appender.ScreenApp.layout.ConversionPattern = %d> %m%n + +The configuration file above is assuming that both appenders are +active in the same logger hierarchy, in this case the C<root> category. +But even if you've got file loggers defined in several parts of your system, +belonging to different logger categories, +each logging to different files, you can gobble up all logged messages +by defining a root logger with a screen appender, which would duplicate +messages from all your file loggers to the screen due to Log4perl's +appender inheritance. Check + + http://www.perl.com/pub/a/2002/09/11/log4perl.html + +for details. Have fun! + +=head2 How can I make sure my application logs a message when it dies unexpectedly? + +Whenever you encounter a fatal error in your application, instead of saying +something like + + open FILE, "<blah" or die "Can't open blah -- bailing out!"; + +just use Log::Log4perl's fatal functions instead: + + my $log = get_logger("Some::Package"); + open FILE, "<blah" or $log->logdie("Can't open blah -- bailing out!"); + +This will both log the message with priority FATAL according to your current +Log::Log4perl configuration and then call Perl's C<die()> +afterwards to terminate the program. It works the same with +stealth loggers (see L<Log::Log4perl/"Stealth Loggers">), +all you need to do is call + + use Log::Log4perl qw(:easy); + open FILE, "<blah" or LOGDIE "Can't open blah -- bailing out!"; + +What can you do if you're using some library which doesn't use Log::Log4perl +and calls C<die()> internally if something goes wrong? Use a +C<$SIG{__DIE__}> pseudo signal handler + + use Log::Log4perl qw(get_logger); + + $SIG{__DIE__} = sub { + if($^S) { + # We're in an eval {} and don't want log + # this message but catch it later + return; + } + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + my $logger = get_logger(""); + $logger->fatal(@_); + die @_; # Now terminate really + }; + +This will catch every C<die()>-Exception of your +application or the modules it uses. In case you want to +It +will fetch a root logger and pass on the C<die()>-Message to it. +If you make sure you've configured with a root logger like this: + + Log::Log4perl->init(\q{ + log4perl.category = FATAL, Logfile + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.filename = fatal_errors.log + log4perl.appender.Logfile.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.Logfile.layout.ConversionPattern = %F{1}-%L (%M)> %m%n + }); + +then all C<die()> messages will be routed to a file properly. The line + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + +in the pseudo signal handler above merits a more detailed explanation. With +the setup above, if a module calls C<die()> in one of its functions, +the fatal message will be logged in the signal handler and not in the +original function -- which will cause the %F, %L and %M placeholders +in the pattern layout to be replaced by the filename, the line number +and the function/method name of the signal handler, not the error-throwing +module. To adjust this, Log::Log4perl has the C<$caller_depth> variable, +which defaults to 0, but can be set to positive integer values +to offset the caller level. Increasing +it by one will cause it to log the calling function's parameters, not +the ones of the signal handler. +See L<Log::Log4perl/"Using Log::Log4perl from wrapper classes"> for more +details. + +=head2 How can I hook up the LWP library with Log::Log4perl? + +Or, to put it more generally: How can you utilize a third-party +library's embedded logging and debug statements in Log::Log4perl? +How can you make them print +to configurable appenders, turn them on and off, just as if they +were regular Log::Log4perl logging statements? + +The easiest solution is to map the third-party library logging statements +to Log::Log4perl's stealth loggers via a typeglob assignment. + +As an example, let's take LWP, one of the most popular Perl modules, +which makes handling WWW requests and responses a breeze. +Internally, LWP uses its own logging and debugging system, +utilizing the following calls +inside the LWP code (from the LWP::Debug man page): + + # Function tracing + LWP::Debug::trace('send()'); + + # High-granular state in functions + LWP::Debug::debug('url ok'); + + # Data going over the wire + LWP::Debug::conns("read $n bytes: $data"); + +First, let's assign Log::Log4perl priorities +to these functions: I'd suggest that +C<debug()> messages have priority C<INFO>, +C<trace()> uses C<DEBUG> and C<conns()> also logs with C<DEBUG> -- +although your mileage may certainly vary. + +Now, in order to transparently hook up LWP::Debug with Log::Log4perl, +all we have to do is say + + package LWP::Debug; + use Log::Log4perl qw(:easy); + + *trace = *INFO; + *conns = *DEBUG; + *debug = *DEBUG; + + package main; + # ... go on with your regular program ... + +at the beginning of our program. In this way, every time the, say, +C<LWP::UserAgent> module calls C<LWP::Debug::trace()>, it will implicitly +call INFO(), which is the C<info()> method of a stealth logger defined for +the Log::Log4perl category C<LWP::Debug>. Is this cool or what? + +Here's a complete program: + + use LWP::UserAgent; + use HTTP::Request::Common; + use Log::Log4perl qw(:easy); + + Log::Log4perl->easy_init( + { category => "LWP::Debug", + level => $DEBUG, + layout => "%r %p %M-%L %m%n", + }); + + package LWP::Debug; + use Log::Log4perl qw(:easy); + *trace = *INFO; + *conns = *DEBUG; + *debug = *DEBUG; + + package main; + my $ua = LWP::UserAgent->new(); + my $resp = $ua->request(GET "http://amazon.com"); + + if($resp->is_success()) { + print "Success: Received ", + length($resp->content()), "\n"; + } else { + print "Error: ", $resp->code(), "\n"; + } + +This will generate the following output on STDERR: + + 174 INFO LWP::UserAgent::new-164 () + 208 INFO LWP::UserAgent::request-436 () + 211 INFO LWP::UserAgent::send_request-294 GET http://amazon.com + 212 DEBUG LWP::UserAgent::_need_proxy-1123 Not proxied + 405 INFO LWP::Protocol::http::request-122 () + 859 DEBUG LWP::Protocol::collect-206 read 233 bytes + 863 DEBUG LWP::UserAgent::request-443 Simple response: Found + 869 INFO LWP::UserAgent::request-436 () + 871 INFO LWP::UserAgent::send_request-294 + GET http://www.amazon.com:80/exec/obidos/gateway_redirect + 872 DEBUG LWP::UserAgent::_need_proxy-1123 Not proxied + 873 INFO LWP::Protocol::http::request-122 () + 1016 DEBUG LWP::UserAgent::request-443 Simple response: Found + 1020 INFO LWP::UserAgent::request-436 () + 1022 INFO LWP::UserAgent::send_request-294 + GET http://www.amazon.com/exec/obidos/subst/home/home.html/ + 1023 DEBUG LWP::UserAgent::_need_proxy-1123 Not proxied + 1024 INFO LWP::Protocol::http::request-122 () + 1382 DEBUG LWP::Protocol::collect-206 read 632 bytes + ... + 2605 DEBUG LWP::Protocol::collect-206 read 77 bytes + 2607 DEBUG LWP::UserAgent::request-443 Simple response: OK + Success: Received 42584 + +Of course, in this way, the embedded logging and debug statements within +LWP can be utilized in any Log::Log4perl way you can think of. You can +have them sent to different appenders, block them based on the +category and everything else Log::Log4perl has to offer. + +Only drawback of this method: Steering logging behavior via category +is always based on the C<LWP::Debug> package. Although the logging +statements reflect the package name of the issuing module properly, +the stealth loggers in C<LWP::Debug> are all of the category C<LWP::Debug>. +This implies that you can't control the logging behavior based on the +package that's I<initiating> a log request (e.g. LWP::UserAgent) but only +based on the package that's actually I<executing> the logging statement, +C<LWP::Debug> in this case. + +To work around this conundrum, we need to write a wrapper function and +plant it into the C<LWP::Debug> package. It will determine the caller and +create a logger bound to a category with the same name as the caller's +package: + + package LWP::Debug; + + use Log::Log4perl qw(:levels get_logger); + + sub l4p_wrapper { + my($prio, @message) = @_; + $Log::Log4perl::caller_depth += 2; + get_logger(scalar caller(1))->log($prio, @message); + $Log::Log4perl::caller_depth -= 2; + } + + no warnings 'redefine'; + *trace = sub { l4p_wrapper($INFO, @_); }; + *debug = *conns = sub { l4p_wrapper($DEBUG, @_); }; + + package main; + # ... go on with your main program ... + +This is less performant than the previous approach, because every +log request will request a reference to a logger first, then call +the wrapper, which will in turn call the appropriate log function. + +This hierarchy shift has to be compensated for by increasing +C<$Log::Log4perl::caller_depth> by 2 before calling the log function +and decreasing it by 2 right afterwards. Also, the C<l4p_wrapper> +function shown above calls C<caller(1)> which determines the name +of the package I<two> levels down the calling hierarchy (and +therefore compensates for both the wrapper function and the +anonymous subroutine calling it). + +C<no warnings 'redefine'> suppresses a warning Perl would generate +otherwise +upon redefining C<LWP::Debug>'s C<trace()>, C<debug()> and C<conns()> +functions. In case you use a perl prior to 5.6.x, you need +to manipulate C<$^W> instead. + +To make things easy for you when dealing with LWP, Log::Log4perl 0.47 +introduces C<Log::Log4perl-E<gt>infiltrate_lwp()> which does exactly the +above. + +=head2 What if I need dynamic values in a static Log4perl configuration file? + +Say, your application uses Log::Log4perl for logging and +therefore comes with a Log4perl configuration file, specifying the logging +behavior. +But, you also want it to take command line parameters to set values +like the name of the log file. +How can you have +both a static Log4perl configuration file and a dynamic command line +interface? + +As of Log::Log4perl 0.28, every value in the configuration file +can be specified as a I<Perl hook>. So, instead of saying + + log4perl.appender.Logfile.filename = test.log + +you could just as well have a Perl subroutine deliver the value +dynamically: + + log4perl.appender.Logfile.filename = sub { logfile(); }; + +given that C<logfile()> is a valid function in your C<main> package +returning a string containing the path to the log file. + +Or, think about using the value of an environment variable: + + log4perl.appender.DBI.user = sub { $ENV{USERNAME} }; + +When C<Log::Log4perl-E<gt>init()> parses the configuration +file, it will notice the assignment above because of its +C<sub {...}> pattern and treat it in a special way: +It will evaluate the subroutine (which can contain +arbitrary Perl code) and take its return value as the right side +of the assignment. + +A typical application would be called like this on the command line: + + app # log file is "test.log" + app -l mylog.txt # log file is "mylog.txt" + +Here's some sample code implementing the command line interface above: + + use Log::Log4perl qw(get_logger); + use Getopt::Std; + + getopt('l:', \our %OPTS); + + my $conf = q( + log4perl.category.Bar.Twix = WARN, Logfile + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.filename = sub { logfile(); }; + log4perl.appender.Logfile.layout = SimpleLayout + ); + + Log::Log4perl::init(\$conf); + + my $logger = get_logger("Bar::Twix"); + $logger->error("Blah"); + + ########################################### + sub logfile { + ########################################### + if(exists $OPTS{l}) { + return $OPTS{l}; + } else { + return "test.log"; + } + } + +Every Perl hook may contain arbitrary perl code, +just make sure to fully qualify eventual variable names +(e.g. C<%main::OPTS> instead of C<%OPTS>). + +B<SECURITY NOTE>: this feature means arbitrary perl code +can be embedded in the config file. In the rare case +where the people who have access to your config file +are different from the people who write your code and +shouldn't have execute rights, you might want to call + + $Log::Log4perl::Config->allow_code(0); + +before you call init(). This will prevent Log::Log4perl from +executing I<any> Perl code in the config file (including +code for custom conversion specifiers +(see L<Log::Log4perl::Layout::PatternLayout/"Custom cspecs">). + +=head2 How can I roll over my logfiles automatically at midnight? + +Long-running applications tend to produce ever-increasing logfiles. +For backup and cleanup purposes, however, it is often desirable to move +the current logfile to a different location from time to time and +start writing a new one. + +This is a non-trivial task, because it has to happen in sync with +the logging system in order not to lose any messages in the process. + +Luckily, I<Mark Pfeiffer>'s C<Log::Dispatch::FileRotate> appender +works well with Log::Log4perl to rotate your logfiles in a variety of ways. + +Note, however, that having the application deal with rotating a log +file is not cheap. Among other things, it requires locking the log file +with every write to avoid race conditions. +There are good reasons to use external rotators like C<newsyslog> +instead. +See the entry C<How can I rotate a logfile with newsyslog?> in the +FAQ for more information on how to configure it. + +When using C<Log::Dispatch::FileRotate>, +all you have to do is specify it in your Log::Log4perl configuration file +and your logfiles will be rotated automatically. + +You can choose between rolling based on a maximum size ("roll if greater +than 10 MB") or based on a date pattern ("roll everyday at midnight"). +In both cases, C<Log::Dispatch::FileRotate> allows you to define a +number C<max> of saved files to keep around until it starts overwriting +the oldest ones. If you set the C<max> parameter to 2 and the name of +your logfile is C<test.log>, C<Log::Dispatch::FileRotate> will +move C<test.log> to C<test.log.1> on the first rollover. On the second +rollover, it will move C<test.log.1> to C<test.log.2> and then C<test.log> +to C<test.log.1>. On the third rollover, it will move C<test.log.1> to +C<test.log.2> (therefore discarding the old C<test.log.2>) and +C<test.log> to C<test.log.1>. And so forth. This way, there's always +going to be a maximum of 2 saved log files around. + +Here's an example of a Log::Log4perl configuration file, defining a +daily rollover at midnight (date pattern C<yyyy-MM-dd>), keeping +a maximum of 5 saved logfiles around: + + log4perl.category = WARN, Logfile + log4perl.appender.Logfile = Log::Dispatch::FileRotate + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.max = 5 + log4perl.appender.Logfile.DatePattern = yyyy-MM-dd + log4perl.appender.Logfile.TZ = PST + log4perl.appender.Logfile.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.Logfile.layout.ConversionPattern = %d %m %n + +Please see the C<Log::Dispatch::FileRotate> documentation for details. +C<Log::Dispatch::FileRotate> is available on CPAN. + +=head2 What's the easiest way to turn off all logging, even with a lengthy Log4perl configuration file? + +In addition to category-based levels and appender thresholds, +Log::Log4perl supports system-wide logging thresholds. This is the +minimum level the system will require of any logging events in order for them +to make it through to any configured appenders. + +For example, putting the line + + log4perl.threshold = ERROR + +anywhere in your configuration file will limit any output to any appender +to events with priority of ERROR or higher (ERROR or FATAL that is). + +However, in order to suppress all logging entirely, you need to use a +priority that's higher than FATAL: It is simply called C<OFF>, and it is never +used by any logger. By definition, it is higher than the highest +defined logger level. + +Therefore, if you keep the line + + log4perl.threshold = OFF + +somewhere in your Log::Log4perl configuration, the system will be quiet +as a graveyard. If you deactivate the line (e.g. by commenting it out), +the system will, upon config reload, snap back to normal operation, providing +logging messages according to the rest of the configuration file again. + +=head2 How can I log DEBUG and above to the screen and INFO and above to a file? + +You need one logger with two appenders attached to it: + + log4perl.logger = DEBUG, Screen, File + + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = SimpleLayout + + log4perl.appender.File = Log::Log4perl::Appender::File + log4perl.appender.File.filename = test.log + log4perl.appender.File.layout = SimpleLayout + log4perl.appender.Screen.Threshold = INFO + +Since the file logger isn't supposed to get any messages with a priority +less than INFO, the appender's C<Threshold> setting blocks those out, +although the logger forwards them. + +It's a common mistake to think you can define two loggers for this, but +it won't work unless those two loggers have different categories. If you +wanted to log all DEBUG and above messages from the Foo::Bar module to a file +and all INFO and above messages from the Quack::Schmack module to the +screen, then you could have defined two loggers with different levels +C<log4perl.logger.Foo.Bar> (level INFO) +and C<log4perl.logger.Quack.Schmack> (level DEBUG) and assigned the file +appender to the former and the screen appender to the latter. But what we +wanted to accomplish was to route all messages, regardless of which module +(or category) they came from, to both appenders. The only +way to accomplish this is to define the root logger with the lower +level (DEBUG), assign both appenders to it, and block unwanted messages at +the file appender (C<Threshold> set to INFO). + +=head2 I keep getting duplicate log messages! What's wrong? + +Having several settings for related categories in the Log4perl +configuration file sometimes leads to a phenomenon called +"message duplication". It can be very confusing at first, +but if thought through properly, it turns out that Log4perl behaves +as advertised. But, don't despair, of course there's a number of +ways to avoid message duplication in your logs. + +Here's a sample Log4perl configuration file that produces the +phenomenon: + + log4perl.logger.Cat = ERROR, Screen + log4perl.logger.Cat.Subcat = WARN, Screen + + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = SimpleLayout + +It defines two loggers, one for category C<Cat> and one for +C<Cat::Subcat>, which is obviously a subcategory of C<Cat>. +The parent logger has a priority setting of ERROR, the child +is set to the lower C<WARN> level. + +Now imagine the following code in your program: + + my $logger = get_logger("Cat.Subcat"); + $logger->warn("Warning!"); + +What do you think will happen? An unexperienced Log4perl user +might think: "Well, the message is being sent with level WARN, so the +C<Cat::Subcat> logger will accept it and forward it to the +attached C<Screen> appender. Then, the message will percolate up +the logger hierarchy, find +the C<Cat> logger, which will suppress the message because of its +ERROR setting." +But, perhaps surprisingly, what you'll get with the +code snippet above is not one but two log messages written +to the screen: + + WARN - Warning! + WARN - Warning! + +What happened? The culprit is that once the logger C<Cat::Subcat> +decides to fire, it will forward the message I<unconditionally> +to all directly or indirectly attached appenders. The C<Cat> logger +will never be asked if it wants the message or not -- the message +will just be pushed through to the appender attached to C<Cat>. + +One way to prevent the message from bubbling up the logger +hierarchy is to set the C<additivity> flag of the subordinate logger to +C<0>: + + log4perl.logger.Cat = ERROR, Screen + log4perl.logger.Cat.Subcat = WARN, Screen + log4perl.additivity.Cat.Subcat = 0 + + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = SimpleLayout + +The message will now be accepted by the C<Cat::Subcat> logger, +forwarded to its appender, but then C<Cat::Subcat> will suppress +any further action. While this setting avoids duplicate messages +as seen before, it is often not the desired behavior. Messages +percolating up the hierarchy are a useful Log4perl feature. + +If you're defining I<different> appenders for the two loggers, +one other option is to define an appender threshold for the +higher-level appender. Typically it is set to be +equal to the logger's level setting: + + log4perl.logger.Cat = ERROR, Screen1 + log4perl.logger.Cat.Subcat = WARN, Screen2 + + log4perl.appender.Screen1 = Log::Log4perl::Appender::Screen + log4perl.appender.Screen1.layout = SimpleLayout + log4perl.appender.Screen1.Threshold = ERROR + + log4perl.appender.Screen2 = Log::Log4perl::Appender::Screen + log4perl.appender.Screen2.layout = SimpleLayout + +Since the C<Screen1> appender now blocks every message with +a priority less than ERROR, even if the logger in charge +lets it through, the message percolating up the hierarchy is +being blocked at the last minute and I<not> appended to C<Screen1>. + +So far, we've been operating well within the boundaries of the +Log4j standard, which Log4perl adheres to. However, if +you would really, really like to use a single appender +and keep the message percolation intact without having to deal +with message duplication, there's a non-standard solution for you: + + log4perl.logger.Cat = ERROR, Screen + log4perl.logger.Cat.Subcat = WARN, Screen + + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = SimpleLayout + + log4perl.oneMessagePerAppender = 1 + +The C<oneMessagePerAppender> flag will suppress duplicate messages +to the same appender. Again, that's non-standard. But way cool :). + +=head2 How can I configure Log::Log4perl to send me email if something happens? + +Some incidents require immediate action. You can't wait until someone +checks the log files, you need to get notified on your pager right away. + +The easiest way to do that is by using the C<Log::Dispatch::Email::MailSend> +module as an appender. It comes with the C<Log::Dispatch> bundle and +allows you to specify recipient and subject of outgoing emails in the Log4perl +configuration file: + + log4perl.category = FATAL, Mailer + log4perl.appender.Mailer = Log::Dispatch::Email::MailSend + log4perl.appender.Mailer.to = drone@pageme.net + log4perl.appender.Mailer.subject = Something's broken! + log4perl.appender.Mailer.layout = SimpleLayout + +The message of every log incident this appender gets +will then be forwarded to the given +email address. Check the C<Log::Dispatch::Email::MailSend> documentation +for details. And please make sure there's not a flood of email messages +sent out by your application, filling up the recipient's inbox. + +There's one caveat you need to know about: The C<Log::Dispatch::Email> +hierarchy of appenders turns on I<buffering> by default. This means that +the appender will not send out messages right away but wait until a +certain threshold has been reached. If you'd rather have your alerts +sent out immediately, use + + log4perl.appender.Mailer.buffered = 0 + +to turn buffering off. + +=head2 How can I write my own appender? + +First off, Log::Log4perl comes with a set of standard appenders. Then, +there's a lot of Log4perl-compatible appenders already +available on CPAN: Just run a search for C<Log::Dispatch> on +http://search.cpan.org and chances are that what you're looking for +has already been developed, debugged and been used successfully +in production -- no need for you to reinvent the wheel. + +Also, Log::Log4perl ships with a nifty database appender named +Log::Log4perl::Appender::DBI -- check it out if talking to databases is your +desire. + +But if you're up for a truly exotic task, you might have to write +an appender yourself. That's very easy -- it takes no longer +than a couple of minutes. + +Say, we wanted to create an appender of the class +C<ColorScreenAppender>, which logs messages +to the screen in a configurable color. Just create a new class +in C<ColorScreenAppender.pm>: + + package ColorScreenAppender; + +Now let's assume that your Log::Log4perl +configuration file C<test.conf> looks like this: + + log4perl.logger = INFO, ColorApp + + log4perl.appender.ColorApp=ColorScreenAppender + log4perl.appender.ColorApp.color=blue + + log4perl.appender.ColorApp.layout = PatternLayout + log4perl.appender.ColorApp.layout.ConversionPattern=%d %m %n + +This will cause Log::Log4perl on C<init()> to look for a class +ColorScreenAppender and call its constructor new(). Let's add +new() to ColorScreenAppender.pm: + + sub new { + my($class, %options) = @_; + + my $self = { %options }; + bless $self, $class; + + return $self; + } + +To initialize this appender, Log::Log4perl will call +and pass all attributes of the appender as defined in the configuration +file to the constructor as name/value pairs (in this case just one): + + ColorScreenAppender->new(color => "blue"); + +The new() method listed above stores the contents of the +%options hash in the object's +instance data hash (referred to by $self). +That's all for initializing a new appender with Log::Log4perl. + +Second, ColorScreenAppender needs to expose a +C<log()> method, which will be called by Log::Log4perl +every time it thinks the appender should fire. Along with the +object reference (as usual in Perl's object world), log() +will receive a list of name/value pairs, of which only the one +under the key C<message> shall be of interest for now since it is the +message string to be logged. At this point, Log::Log4perl has already taken +care of joining the message to be a single string. + +For our special appender ColorScreenAppender, we're using the +Term::ANSIColor module to colorize the output: + + use Term::ANSIColor; + + sub log { + my($self, %params) = @_; + + print colored($params{message}, + $self->{color}); + } + +The color (as configured in the Log::Log4perl configuration file) +is available as $self-E<gt>{color} in the appender object. Don't +forget to return + + 1; + +at the end of ColorScreenAppender.pm and you're done. Install the new appender +somewhere where perl can find it and try it with a test script like + + use Log::Log4perl qw(:easy); + Log::Log4perl->init("test.conf"); + ERROR("blah"); + +to see the new colored output. Is this cool or what? + +And it gets even better: You can write dynamically generated appender +classes using the C<Class::Prototyped> module. Here's an example of +an appender prepending every outgoing message with a configurable +number of bullets: + + use Class::Prototyped; + + my $class = Class::Prototyped->newPackage( + "MyAppenders::Bulletizer", + bullets => 1, + log => sub { + my($self, %params) = @_; + print "*" x $self->bullets(), + $params{message}; + }, + ); + + use Log::Log4perl qw(:easy); + + Log::Log4perl->init(\ q{ + log4perl.logger = INFO, Bully + + log4perl.appender.Bully=MyAppenders::Bulletizer + log4perl.appender.Bully.bullets=3 + + log4perl.appender.Bully.layout = PatternLayout + log4perl.appender.Bully.layout.ConversionPattern=%m %n + }); + + # ... prints: "***Boo!\n"; + INFO "Boo!"; + +=head2 How can I drill down on references before logging them? + +If you've got a reference to a nested structure or object, then +you probably don't want to log it as C<HASH(0x81141d4)> but rather +dump it as something like + + $VAR1 = { + 'a' => 'b', + 'd' => 'e' + }; + +via a module like Data::Dumper. While it's syntactically correct to say + + $logger->debug(Data::Dumper::Dumper($ref)); + +this call imposes a huge performance penalty on your application +if the message is suppressed by Log::Log4perl, because Data::Dumper +will perform its expensive operations in any case, because it doesn't +know that its output will be thrown away immediately. + +As of Log::Log4perl 0.28, there's a better way: Use the +message output filter format as in + + $logger->debug( {filter => \&Data::Dumper::Dumper, + value => $ref} ); + +and Log::Log4perl won't call the filter function unless the message really +gets written out to an appender. Just make sure to pass the whole slew as a +reference to a hash specifying a filter function (as a sub reference) +under the key C<filter> and the value to be passed to the filter function in +C<value>). +When it comes to logging, Log::Log4perl will call the filter function, +pass the C<value> as an argument and log the return value. +Saves you serious cycles. + +=head2 How can I collect all FATAL messages in an extra log file? + +Suppose you have employed Log4perl all over your system and you've already +activated logging in various subsystems. On top of that, without disrupting +any other settings, how can you collect all FATAL messages all over the system +and send them to a separate log file? + +If you define a root logger like this: + + log4perl.logger = FATAL, File + log4perl.appender.File = Log::Log4perl::Appender::File + log4perl.appender.File.filename = /tmp/fatal.txt + log4perl.appender.File.layout = PatternLayout + log4perl.appender.File.layout.ConversionPattern= %d %m %n + # !!! Something's missing ... + +you'll be surprised to not only receive all FATAL messages +issued anywhere in the system, +but also everything else -- gazillions of +ERROR, WARN, INFO and even DEBUG messages will end up in +your fatal.txt logfile! +Reason for this is Log4perl's (or better: Log4j's) appender additivity. +Once a +lower-level logger decides to fire, the message is going to be forwarded +to all appenders upstream -- without further priority checks with their +attached loggers. + +There's a way to prevent this, however: If your appender defines a +minimum threshold, only messages of this priority or higher are going +to be logged. So, just add + + log4perl.appender.File.Threshold = FATAL + +to the configuration above, and you'll get what you wanted in the +first place: An overall system FATAL message collector. + +=head2 How can I bundle several log messages into one? + +Would you like to tally the messages arriving at your appender and +dump out a summary once they're exceeding a certain threshold? +So that something like + + $logger->error("Blah"); + $logger->error("Blah"); + $logger->error("Blah"); + +won't be logged as + + Blah + Blah + Blah + +but as + + [3] Blah + +instead? If you'd like to hold off on logging a message until it has been +sent a couple of times, you can roll that out by creating a buffered +appender. + +Let's define a new appender like + + package TallyAppender; + + sub new { + my($class, %options) = @_; + + my $self = { maxcount => 5, + %options + }; + + bless $self, $class; + + $self->{last_message} = ""; + $self->{last_message_count} = 0; + + return $self; + } + +with two additional instance variables C<last_message> and +C<last_message_count>, storing the content of the last message sent +and a counter of how many times this has happened. Also, it features +a configuration parameter C<maxcount> which defaults to 5 in the +snippet above but can be set in the Log4perl configuration file like this: + + log4perl.logger = INFO, A + log4perl.appender.A=TallyAppender + log4perl.appender.A.maxcount = 3 + +The main tallying logic lies in the appender's C<log> method, +which is called every time Log4perl thinks a message needs to get logged +by our appender: + + sub log { + my($self, %params) = @_; + + # Message changed? Print buffer. + if($self->{last_message} and + $params{message} ne $self->{last_message}) { + print "[$self->{last_message_count}]: " . + "$self->{last_message}"; + $self->{last_message_count} = 1; + $self->{last_message} = $params{message}; + return; + } + + $self->{last_message_count}++; + $self->{last_message} = $params{message}; + + # Threshold exceeded? Print, reset counter + if($self->{last_message_count} >= + $self->{maxcount}) { + print "[$self->{last_message_count}]: " . + "$params{message}"; + $self->{last_message_count} = 0; + $self->{last_message} = ""; + return; + } + } + +We basically just check if the oncoming message in C<$param{message}> +is equal to what we've saved before in the C<last_message> instance +variable. If so, we're increasing C<last_message_count>. +We print the message in two cases: If the new message is different +than the buffered one, because then we need to dump the old stuff +and store the new. Or, if the counter exceeds the threshold, as +defined by the C<maxcount> configuration parameter. + +Please note that the appender always gets the fully rendered message and +just compares it as a whole -- so if there's a date/timestamp in there, +that might confuse your logic. You can work around this by specifying +%m %n as a layout and add the date later on in the appender. Or, make +the comparison smart enough to omit the date. + +At last, don't forget what happens if the program is being shut down. +If there's still messages in the buffer, they should be printed out +at that point. That's easy to do in the appender's DESTROY method, +which gets called at object destruction time: + + sub DESTROY { + my($self) = @_; + + if($self->{last_message_count}) { + print "[$self->{last_message_count}]: " . + "$self->{last_message}"; + return; + } + } + +This will ensure that none of the buffered messages are lost. +Happy buffering! + +=head2 I want to log ERROR and WARN messages to different files! How can I do that? + +Let's assume you wanted to have each logging statement written to a +different file, based on the statement's priority. Messages with priority +C<WARN> are supposed to go to C</tmp/app.warn>, events prioritized +as C<ERROR> should end up in C</tmp/app.error>. + +Now, if you define two appenders C<AppWarn> and C<AppError> +and assign them both to the root logger, +messages bubbling up from any loggers below will be logged by both +appenders because of Log4perl's message propagation feature. If you limit +their exposure via the appender threshold mechanism and set +C<AppWarn>'s threshold to C<WARN> and C<AppError>'s to C<ERROR>, you'll +still get C<ERROR> messages in C<AppWarn>, because C<AppWarn>'s C<WARN> +setting will just filter out messages with a I<lower> priority than +C<WARN> -- C<ERROR> is higher and will be allowed to pass through. + +What we need for this is a Log4perl I<Custom Filter>, available with +Log::Log4perl 0.30. + +Both appenders need to verify that +the priority of the oncoming messages exactly I<matches> the priority +the appender is supposed to log messages of. To accomplish this task, +let's define two custom filters, C<MatchError> and C<MatchWarn>, which, +when attached to their appenders, will limit messages passed on to them +to those matching a given priority: + + log4perl.logger = WARN, AppWarn, AppError + + # Filter to match level ERROR + log4perl.filter.MatchError = Log::Log4perl::Filter::LevelMatch + log4perl.filter.MatchError.LevelToMatch = ERROR + log4perl.filter.MatchError.AcceptOnMatch = true + + # Filter to match level WARN + log4perl.filter.MatchWarn = Log::Log4perl::Filter::LevelMatch + log4perl.filter.MatchWarn.LevelToMatch = WARN + log4perl.filter.MatchWarn.AcceptOnMatch = true + + # Error appender + log4perl.appender.AppError = Log::Log4perl::Appender::File + log4perl.appender.AppError.filename = /tmp/app.err + log4perl.appender.AppError.layout = SimpleLayout + log4perl.appender.AppError.Filter = MatchError + + # Warning appender + log4perl.appender.AppWarn = Log::Log4perl::Appender::File + log4perl.appender.AppWarn.filename = /tmp/app.warn + log4perl.appender.AppWarn.layout = SimpleLayout + log4perl.appender.AppWarn.Filter = MatchWarn + +The appenders C<AppWarn> and C<AppError> defined above are logging to C</tmp/app.warn> and +C</tmp/app.err> respectively and have the custom filters C<MatchWarn> and C<MatchError> +attached. +This setup will direct all WARN messages, issued anywhere in the system, to /tmp/app.warn (and +ERROR messages to /tmp/app.error) -- without any overlaps. + +=head2 On our server farm, Log::Log4perl configuration files differ slightly from host to host. Can I roll them all into one? + +You sure can, because Log::Log4perl allows you to specify attribute values +dynamically. Let's say that one of your appenders expects the host's IP address +as one of its attributes. Now, you could certainly roll out different +configuration files for every host and specify the value like + + log4perl.appender.MyAppender = Log::Log4perl::Appender::SomeAppender + log4perl.appender.MyAppender.ip = 10.0.0.127 + +but that's a maintenance nightmare. Instead, you can have Log::Log4perl +figure out the IP address at configuration time and set the appender's +value correctly: + + # Set the IP address dynamically + log4perl.appender.MyAppender = Log::Log4perl::Appender::SomeAppender + log4perl.appender.MyAppender.ip = sub { \ + use Sys::Hostname; \ + use Socket; \ + return inet_ntoa(scalar gethostbyname hostname); \ + } + +If Log::Log4perl detects that an attribute value starts with something like +C<"sub {...">, it will interpret it as a perl subroutine which is to be executed +once at configuration time (not runtime!) and its return value is +to be used as the attribute value. This comes in handy +for rolling out applications where Log::Log4perl configuration files +show small host-specific differences, because you can deploy the unmodified +application distribution on all instances of the server farm. + +=head2 Log4perl doesn't interpret my backslashes correctly! + +If you're using Log4perl's feature to specify the configuration as a +string in your program (as opposed to a separate configuration file), +chances are that you've written it like this: + + # *** WRONG! *** + + Log::Log4perl->init( \ <<END_HERE); + log4perl.logger = WARN, A1 + log4perl.appender.A1 = Log::Log4perl::Appender::Screen + log4perl.appender.A1.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.A1.layout.ConversionPattern = %m%n + END_HERE + + # *** WRONG! *** + +and you're getting the following error message: + + Layout not specified for appender A1 at .../Config.pm line 342. + +What's wrong? The problem is that you're using a here-document with +substitution enabled (C<E<lt>E<lt>END_HERE>) and that Perl won't +interpret backslashes at line-ends as continuation characters but +will essentially throw them out. So, in the code above, the layout line +will look like + + log4perl.appender.A1.layout = + +to Log::Log4perl which causes it to report an error. To interpret the backslash +at the end of the line correctly as a line-continuation character, use +the non-interpreting mode of the here-document like in + + # *** RIGHT! *** + + Log::Log4perl->init( \ <<'END_HERE'); + log4perl.logger = WARN, A1 + log4perl.appender.A1 = Log::Log4perl::Appender::Screen + log4perl.appender.A1.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.A1.layout.ConversionPattern = %m%n + END_HERE + + # *** RIGHT! *** + +(note the single quotes around C<'END_HERE'>) or use C<q{...}> +instead of a here-document and Perl will treat the backslashes at +line-end as intended. + +=head2 I want to suppress certain messages based on their content! + +Let's assume you've plastered all your functions with Log4perl +statements like + + sub some_func { + + INFO("Begin of function"); + + # ... Stuff happens here ... + + INFO("End of function"); + } + +to issue two log messages, one at the beginning and one at the end of +each function. Now you want to suppress the message at the beginning +and only keep the one at the end, what can you do? You can't use the category +mechanism, because both messages are issued from the same package. + +Log::Log4perl's custom filters (0.30 or better) provide an interface for the +Log4perl user to step in right before a message gets logged and decide if +it should be written out or suppressed, based on the message content or other +parameters: + + use Log::Log4perl qw(:easy); + + Log::Log4perl::init( \ <<'EOT' ); + log4perl.logger = INFO, A1 + log4perl.appender.A1 = Log::Log4perl::Appender::Screen + log4perl.appender.A1.layout = \ + Log::Log4perl::Layout::PatternLayout + log4perl.appender.A1.layout.ConversionPattern = %m%n + + log4perl.filter.M1 = Log::Log4perl::Filter::StringMatch + log4perl.filter.M1.StringToMatch = Begin + log4perl.filter.M1.AcceptOnMatch = false + + log4perl.appender.A1.Filter = M1 +EOT + +The last four statements in the configuration above are defining a custom +filter C<M1> of type C<Log::Log4perl::Filter::StringMatch>, which comes with +Log4perl right out of the box and allows you to define a text pattern to match +(as a perl regular expression) and a flag C<AcceptOnMatch> indicating +if a match is supposed to suppress the message or let it pass through. + +The last line then assigns this filter to the C<A1> appender, which will +call it every time it receives a message to be logged and throw all +messages out I<not> matching the regular expression C<Begin>. + +Instead of using the standard C<Log::Log4perl::Filter::StringMatch> filter, +you can define your own, simply using a perl subroutine: + + log4perl.filter.ExcludeBegin = sub { !/Begin/ } + log4perl.appender.A1.Filter = ExcludeBegin + +For details on custom filters, check L<Log::Log4perl::Filter>. + +=head2 My new module uses Log4perl -- but what happens if the calling program didn't configure it? + +If a Perl module uses Log::Log4perl, it will typically rely on the +calling program to initialize it. If it is using Log::Log4perl in C<:easy> +mode, like in + + package MyMod; + use Log::Log4perl qw(:easy); + + sub foo { + DEBUG("In foo"); + } + + 1; + +and the calling program doesn't initialize Log::Log4perl at all (e.g. because +it has no clue that it's available), Log::Log4perl will silently +ignore all logging messages. However, if the module is using Log::Log4perl +in regular mode like in + + package MyMod; + use Log::Log4perl qw(get_logger); + + sub foo { + my $logger = get_logger(""); + $logger->debug("blah"); + } + + 1; + +and the main program is just using the module like in + + use MyMode; + MyMode::foo(); + +then Log::Log4perl will also ignore all logging messages but +issue a warning like + + Log4perl: Seems like no initialization happened. + Forgot to call init()? + +(only once!) to remind novice users to not forget to initialize +the logging system before using it. +However, if you want to suppress this message, just +add the C<:nowarn> target to the module's C<use Log::Log4perl> call: + + use Log::Log4perl qw(get_logger :nowarn); + +This will have Log::Log4perl silently ignore all logging statements if +no initialization has taken place. If, instead of using init(), you're +using Log4perl's API to define loggers and appenders, the same +notification happens if no call to add_appenders() is made, i.e. no +appenders are defined. + +If the module wants to figure out if some other program part has +already initialized Log::Log4perl, it can do so by calling + + Log::Log4perl::initialized() + +which will return a true value in case Log::Log4perl has been initialized +and a false value if not. + +=head2 How can I synchronize access to an appender? + +If you're using the same instance of an appender in multiple processes, +and each process is passing on messages to the appender in parallel, +you might end up with overlapping log entries. + +Typical scenarios include a file appender that you create in the main +program, and which will then be shared between the parent and a +forked child process. Or two separate processes, each initializing a +Log4perl file appender on the same logfile. + +Log::Log4perl won't synchronize access to the shared logfile by +default. Depending on your operating system's flush mechanism, +buffer size and the size of your messages, there's a small chance of +an overlap. + +The easiest way to prevent overlapping messages in logfiles written to +by multiple processes is setting the +file appender's C<syswrite> flag along with a file write mode of C<"append">. +This makes sure that +C<Log::Log4perl::Appender::File> uses C<syswrite()> (which is guaranteed +to run uninterrupted) instead of C<print()> which might buffer +the message or get interrupted by the OS while it is writing. And in +C<"append"> mode, the OS kernel ensures that multiple processes share +one end-of-file marker, ensuring that each process writes to the I<real> +end of the file. (The value of C<"append"> +for the C<mode> parameter is the default setting in Log4perl's file +appender so you don't have to set it explicitly.) + + # Guarantees atomic writes + + log4perl.category.Bar.Twix = WARN, Logfile + + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.mode = append + log4perl.appender.Logfile.syswrite = 1 + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = SimpleLayout + +Another guaranteed way of having messages separated with any kind of +appender is putting a Log::Log4perl::Appender::Synchronized composite +appender in between Log::Log4perl and the real appender. It will make +sure to let messages pass through this virtual gate one by one only. + +Here's a sample configuration to synchronize access to a file appender: + + log4perl.category.Bar.Twix = WARN, Syncer + + log4perl.appender.Logfile = Log::Log4perl::Appender::File + log4perl.appender.Logfile.autoflush = 1 + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = SimpleLayout + + log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized + log4perl.appender.Syncer.appender = Logfile + +C<Log::Log4perl::Appender::Synchronized> uses +the C<IPC::Shareable> module and its semaphores, which will slow down writing +the log messages, but ensures sequential access featuring atomic checks. +Check L<Log::Log4perl::Appender::Synchronized> for details. + +=head2 Can I use Log::Log4perl with log4j's Chainsaw? + +Yes, Log::Log4perl can be configured to send its events to log4j's +graphical log UI I<Chainsaw>. + +=for html +<p> +<TABLE><TR><TD> +<A HREF="http://log4perl.sourceforge.net/images/chainsaw2.jpg"><IMG SRC="http://log4perl.sourceforge.net/images/chainsaw2s.jpg"></A> +<TR><TD> +<I>Figure 1: Chainsaw receives Log::Log4perl events</I> +</TABLE> +<p> + +=for text +Figure1: Chainsaw receives Log::Log4perl events + +Here's how it works: + +=over 4 + +=item * + +Get Guido Carls' E<lt>gcarls@cpan.orgE<gt> Log::Log4perl extension +C<Log::Log4perl::Layout::XMLLayout> from CPAN and install it: + + perl -MCPAN -eshell + cpan> install Log::Log4perl::Layout::XMLLayout + +=item * + +Install and start Chainsaw, which is part of the C<log4j> distribution now +(see http://jakarta.apache.org/log4j ). Create a configuration file like + + <log4j:configuration debug="true"> + <plugin name="XMLSocketReceiver" + class="org.apache.log4j.net.XMLSocketReceiver"> + <param name="decoder" value="org.apache.log4j.xml.XMLDecoder"/> + <param name="Port" value="4445"/> + </plugin> + <root> <level value="debug"/> </root> + </log4j:configuration> + +and name it e.g. C<config.xml>. Then start Chainsaw like + + java -Dlog4j.debug=true -Dlog4j.configuration=config.xml \ + -classpath ".:log4j-1.3alpha.jar:log4j-chainsaw-1.3alpha.jar" \ + org.apache.log4j.chainsaw.LogUI + +and watch the GUI coming up. + +=item * + +Configure Log::Log4perl to use a socket appender with an XMLLayout, pointing +to the host/port where Chainsaw (as configured above) is waiting with its +XMLSocketReceiver: + + use Log::Log4perl qw(get_logger); + use Log::Log4perl::Layout::XMLLayout; + + my $conf = q( + log4perl.category.Bar.Twix = WARN, Appender + log4perl.appender.Appender = Log::Log4perl::Appender::Socket + log4perl.appender.Appender.PeerAddr = localhost + log4perl.appender.Appender.PeerPort = 4445 + log4perl.appender.Appender.layout = Log::Log4perl::Layout::XMLLayout + ); + + Log::Log4perl::init(\$conf); + + # Nasty hack to suppress encoding header + my $app = Log::Log4perl::appenders->{"Appender"}; + $app->layout()->{enc_set} = 1; + + my $logger = get_logger("Bar.Twix"); + $logger->error("One"); + +The nasty hack shown in the code snippet above is currently (October 2003) +necessary, because Chainsaw expects XML messages to arrive in a format like + + <log4j:event logger="Bar.Twix" + timestamp="1066794904310" + level="ERROR" + thread="10567"> + <log4j:message><![CDATA[Two]]></log4j:message> + <log4j:NDC><![CDATA[undef]]></log4j:NDC> + <log4j:locationInfo class="main" + method="main" + file="./t" + line="32"> + </log4j:locationInfo> + </log4j:event> + +without a preceding + + <?xml version = "1.0" encoding = "iso8859-1"?> + +which Log::Log4perl::Layout::XMLLayout applies to the first event sent +over the socket. + +=back + +See figure 1 for a screenshot of Chainsaw in action, receiving events from +the Perl script shown above. + +Many thanks to Chainsaw's +Scott Deboy <sdeboy@comotivsystems.com> for his support! + +=head2 How can I run Log::Log4perl under mod_perl? + +In persistent environments it's important to play by the rules outlined +in section L<Log::Log4perl/"Initialize once and only once">. +If you haven't read this yet, please go ahead and read it right now. It's +very important. + +And no matter if you use a startup handler to init() Log::Log4perl or use the +init_once() strategy (added in 0.42), either way you're very likely to have +unsynchronized writes to logfiles. + +If Log::Log4perl is configured with a log file appender, and it is +initialized via +the Apache startup handler, the file handle created initially will be +shared among all Apache processes. Similarly, with the init_once() +approach: although every process has a separate L4p configuration, +processes are gonna share the appender file I<names> instead, effectively +opening several different file handles on the same file. + +Now, having several appenders using the same file handle or having +several appenders logging to the same file unsynchronized, this might +result in overlapping messages. Sometimes, this is acceptable. If it's +not, here's two strategies: + +=over 4 + +=item * + +Use the L<Log::Log4perl::Appender::Synchronized> appender to connect to +your file appenders. Here's the writeup: +http://log4perl.sourceforge.net/releases/Log-Log4perl/docs/html/Log/Log4perl/FAQ.html#23804 + +=item * + +Use a different logfile for every process like in + + #log4perl.conf + ... + log4perl.appender.A1.filename = sub { "mylog.$$.log" } + +=back + +=head2 My program already uses warn() and die(). How can I switch to Log4perl? + +If your program already uses Perl's C<warn()> function to spew out +error messages and you'd like to channel those into the Log4perl world, +just define a C<__WARN__> handler where your program or module resides: + + use Log::Log4perl qw(:easy); + + $SIG{__WARN__} = sub { + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + WARN @_; + }; + +Why the C<local> setting of C<$Log::Log4perl::caller_depth>? +If you leave that out, +C<PatternLayout> conversion specifiers like C<%M> or C<%F> (printing +the current function/method and source filename) will refer +to where the __WARN__ handler resides, not the environment +Perl's C<warn()> function was issued from. Increasing C<caller_depth> +adjusts for this offset. Having it C<local>, makes sure the level +gets set back after the handler exits. + +Once done, if your program does something like + + sub some_func { + warn "Here's a warning"; + } + +you'll get (depending on your Log::Log4perl configuration) something like + + 2004/02/19 20:41:02-main::some_func: Here's a warning at ./t line 25. + +in the appropriate appender instead of having a screen full of STDERR +messages. It also works with the C<Carp> module and its C<carp()> +and C<cluck()> functions. + +If, on the other hand, catching C<die()> and friends is +required, a C<__DIE__> handler is appropriate: + + $SIG{__DIE__} = sub { + if($^S) { + # We're in an eval {} and don't want log + # this message but catch it later + return; + } + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + LOGDIE @_; + }; + +This will call Log4perl's C<LOGDIE()> function, which will log a fatal +error and then call die() internally, causing the program to exit. Works +equally well with C<Carp>'s C<croak()> and C<confess()> functions. + +=head2 Some module prints messages to STDERR. How can I funnel them to Log::Log4perl? + +If a module you're using doesn't use Log::Log4perl but prints logging +messages to STDERR instead, like + + ######################################## + package IgnorantModule; + ######################################## + + sub some_method { + print STDERR "Parbleu! An error!\n"; + } + + 1; + +there's still a way to capture these messages and funnel them +into Log::Log4perl, even without touching the module. What you need is +a trapper module like + + ######################################## + package Trapper; + ######################################## + + use Log::Log4perl qw(:easy); + + sub TIEHANDLE { + my $class = shift; + bless [], $class; + } + + sub PRINT { + my $self = shift; + $Log::Log4perl::caller_depth++; + DEBUG @_; + $Log::Log4perl::caller_depth--; + } + + 1; + +and a C<tie> command in the main program to tie STDERR to the trapper +module along with regular Log::Log4perl initialization: + + ######################################## + package main; + ######################################## + + use Log::Log4perl qw(:easy); + + Log::Log4perl->easy_init( + {level => $DEBUG, + file => 'stdout', # make sure not to use stderr here! + layout => "%d %M: %m%n", + }); + + tie *STDERR, "Trapper"; + +Make sure not to use STDERR as Log::Log4perl's file appender +here (which would be the default in C<:easy> mode), because it would +end up in an endless recursion. + +Now, calling + + IgnorantModule::some_method(); + +will result in the desired output + + 2004/05/06 11:13:04 IgnorantModule::some_method: Parbleu! An error! + +=head2 How come PAR (Perl Archive Toolkit) creates executables which then can't find their Log::Log4perl appenders? + +If not instructed otherwise, C<Log::Log4perl> dynamically pulls in +appender classes found in its configuration. If you specify + + #!/usr/bin/perl + # mytest.pl + + use Log::Log4perl qw(get_logger); + + my $conf = q( + log4perl.category.Bar.Twix = WARN, Logfile + log4perl.appender.Logfile = Log::Log4perl::Appender::Screen + log4perl.appender.Logfile.layout = SimpleLayout + ); + + Log::Log4perl::init(\$conf); + my $logger = get_logger("Bar::Twix"); + $logger->error("Blah"); + +then C<Log::Log4perl::Appender::Screen> will be pulled in while the program +runs, not at compile time. If you have PAR compile the script above to an +executable binary via + + pp -o mytest mytest.pl + +and then run C<mytest> on a machine without having Log::Log4perl installed, +you'll get an error message like + + ERROR: can't load appenderclass 'Log::Log4perl::Appender::Screen' + Can't locate Log/Log4perl/Appender/Screen.pm in @INC ... + +Why? At compile time, C<pp> didn't realize that +C<Log::Log4perl::Appender::Screen> would be needed later on and didn't +wrap it into the executable created. To avoid this, either say +C<use Log::Log4perl::Appender::Screen> in the script explicitly or +compile it with + + pp -o mytest -M Log::Log4perl::Appender::Screen mytest.pl + +to make sure the appender class gets included. + +=head2 How can I access a custom appender defined in the configuration? + +Any appender defined in the configuration file or somewhere in the code +can be accessed later via +C<Log::Log4perl-E<gt>appender_by_name("appender_name")>, +which returns a reference of the appender object. + +Once you've got a hold of the object, it can be queried or modified to +your liking. For example, see the custom C<IndentAppender> defined below: +After calling C<init()> to define the Log4perl settings, the +appender object is retrieved to call its C<indent_more()> and C<indent_less()> +methods to control indentation of messages: + + package IndentAppender; + + sub new { + bless { indent => 0 }, $_[0]; + } + + sub indent_more { $_[0]->{indent}++ } + sub indent_less { $_[0]->{indent}-- } + + sub log { + my($self, %params) = @_; + print " " x $self->{indent}, $params{message}; + } + + package main; + + use Log::Log4perl qw(:easy); + + my $conf = q( + log4perl.category = DEBUG, Indented + log4perl.appender.Indented = IndentAppender + log4perl.appender.Indented.layout = Log::Log4perl::Layout::SimpleLayout + ); + + Log::Log4perl::init(\$conf); + + my $appender = Log::Log4perl->appender_by_name("Indented"); + + DEBUG "No identation"; + $appender->indent_more(); + DEBUG "One more"; + $appender->indent_more(); + DEBUG "Two more"; + $appender->indent_less(); + DEBUG "One less"; + +As you would expect, this will print + + DEBUG - No identation + DEBUG - One more + DEBUG - Two more + DEBUG - One less + +because the very appender used by Log4perl is modified dynamically at +runtime. + +=head2 I don't know if Log::Log4perl is installed. How can I prepare my script? + +In case your script needs to be prepared for environments that may or may +not have Log::Log4perl installed, there's a trick. + +If you put the following BEGIN blocks at the top of the program, +you'll be able to use the DEBUG(), INFO(), etc. macros in +Log::Log4perl's C<:easy> mode. +If Log::Log4perl +is installed in the target environment, the regular Log::Log4perl rules +apply. If not, all of DEBUG(), INFO(), etc. are "stubbed" out, i.e. they +turn into no-ops: + + use warnings; + use strict; + + BEGIN { + eval { require Log::Log4perl; }; + + if($@) { + print "Log::Log4perl not installed - stubbing.\n"; + no strict qw(refs); + *{"main::$_"} = sub { } for qw(DEBUG INFO WARN ERROR FATAL); + } else { + no warnings; + print "Log::Log4perl installed - life is good.\n"; + require Log::Log4perl::Level; + Log::Log4perl::Level->import(__PACKAGE__); + Log::Log4perl->import(qw(:easy)); + Log::Log4perl->easy_init($main::DEBUG); + } + } + + # The regular script begins ... + DEBUG "Hey now!"; + +This snippet will first probe for Log::Log4perl, and if it can't be found, +it will alias DEBUG(), INFO(), with empty subroutines via typeglobs. +If Log::Log4perl is available, its level constants are first imported +(C<$DEBUG>, C<$INFO>, etc.) and then C<easy_init()> gets called to initialize +the logging system. + +=head2 Can file appenders create files with different permissions? + +Typically, when C<Log::Log4perl::Appender::File> creates a new file, +its permissions are set to C<rw-r--r-->. Why? Because your +environment's I<umask> most likely defaults to +C<0022>, that's the standard setting. + +What's a I<umask>, you're asking? It's a template that's applied to +the permissions of all newly created files. While calls like +C<open(FILE, "E<gt>foo")> will always try to create files in C<rw-rw-rw- +> mode, the system will apply the current I<umask> template to +determine the final permission setting. I<umask> is a bit mask that's +inverted and then applied to the requested permission setting, using a +bitwise AND: + + $request_permission &~ $umask + +So, a I<umask> setting of 0000 (the leading 0 simply indicates an +octal value) will create files in C<rw-rw-rw-> mode, a setting of 0277 +will use C<r-------->, and the standard 0022 will use C<rw-r--r-->. + +As an example, if you want your log files to be created with +C<rw-r--rw-> permissions, use a I<umask> of C<0020> before +calling Log::Log4perl->init(): + + use Log::Log4perl; + + umask 0020; + # Creates log.out in rw-r--rw mode + Log::Log4perl->init(\ q{ + log4perl.logger = WARN, File + log4perl.appender.File = Log::Log4perl::Appender::File + log4perl.appender.File.filename = log.out + log4perl.appender.File.layout = SimpleLayout + }); + +=head2 Using Log4perl in an END block causes a problem! + +It's not easy to get to this error, but if you write something like + + END { Log::Log4perl::get_logger()->debug("Hey there."); } + + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init($DEBUG); + +it won't work. The reason is that C<Log::Log4perl> defines an +END block that cleans up all loggers. And perl will run END blocks +in the reverse order as they're encountered in the compile phase, +so in the scenario above, the END block will run I<after> Log4perl +has cleaned up its loggers. + +Placing END blocks using Log4perl I<after> +a C<use Log::Log4perl> statement fixes the problem: + + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init($DEBUG); + + END { Log::Log4perl::get_logger()->debug("Hey there."); } + +In this scenario, the shown END block is executed I<before> Log4perl +cleans up and the debug message will be processed properly. + +=head2 Help! My appender is throwing a "Wide character in print" warning! + +This warning shows up when Unicode strings are printed without +precautions. The warning goes away if the complaining appender is +set to utf-8 mode: + + # Either in the log4perl configuration file: + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.utf8 = 1 + + # Or, in easy mode: + Log::Log4perl->easy_init( { + level => $DEBUG, + file => ":utf8> test.log" + } ); + +If the complaining appender is a screen appender, set its C<utf8> option: + + log4perl.appender.Screen.stderr = 1 + log4perl.appender.Screen.utf8 = 1 + +Alternatively, C<binmode> does the trick: + + # Either STDOUT ... + binmode(STDOUT, ":utf8); + + # ... or STDERR. + binmode(STDERR, ":utf8); + +Some background on this: Perl's strings are either byte strings or +Unicode strings. C<"Mike"> is a byte string. +C<"\x{30DE}\x{30A4}\x{30AF}"> is a Unicode string. Unicode strings are +marked specially and are UTF-8 encoded internally. + +If you print a byte string to STDOUT, +all is well, because STDOUT is by default set to byte mode. However, +if you print a Unicode string to STDOUT without precautions, C<perl> +will try to transform the Unicode string back to a byte string before +printing it out. This is troublesome if the Unicode string contains +'wide' characters which can't be represented in Latin-1. + +For example, if you create a Unicode string with three japanese Katakana +characters as in + + perl -le 'print "\x{30DE}\x{30A4}\x{30AF}"' + +(coincidentally pronounced Ma-i-ku, the japanese pronunciation of +"Mike"), STDOUT is in byte mode and the warning + + Wide character in print at ./script.pl line 14. + +appears. Setting STDOUT to UTF-8 mode as in + + perl -le 'binmode(STDOUT, ":utf8"); print "\x{30DE}\x{30A4}\x{30AF}"' + +will silently print the Unicode string to STDOUT in UTF-8. To see the +characters printed, you'll need a UTF-8 terminal with a font including +japanese Katakana characters. + +=head2 How can I send errors to the screen, and debug messages to a file? + +Let's assume you want to maintain a detailed DEBUG output in a file +and only messages of level ERROR and higher should be printed on the +screen. Often times, developers come up with something like this: + + # Wrong!!! + log4perl.logger = DEBUG, FileApp + log4perl.logger = ERROR, ScreenApp + # Wrong!!! + +This won't work, however. Logger definitions aren't additive, and the +second statement will overwrite the first one. Log4perl versions +below 1.04 were silently accepting this, leaving people confused why +it wouldn't work as expected. +As of 1.04, this will throw a I<fatal error> to notify the user of +the problem. + +What you want to do instead, is this: + + log4perl.logger = DEBUG, FileApp, ScreenApp + + log4perl.appender.FileApp = Log::Log4perl::Appender::File + log4perl.appender.FileApp.filename = test.log + log4perl.appender.FileApp.layout = SimpleLayout + + log4perl.appender.ScreenApp = Log::Log4perl::Appender::Screen + log4perl.appender.ScreenApp.stderr = 0 + log4perl.appender.ScreenApp.layout = SimpleLayout + ### limiting output to ERROR messages + log4perl.appender.ScreenApp.Threshold = ERROR + ### + +Note that without the second appender's C<Threshold> setting, both appenders +would receive all messages prioritized DEBUG and higher. With the +threshold set to ERROR, the second appender will filter the messages +as required. + +=head2 Where should I put my logfiles? + +Your log files may go anywhere you want them, but the effective +user id of the calling process must have write access. + +If the log file doesn't exist at program start, Log4perl's file appender +will create it. For this, it needs write access to the directory where +the new file will be located in. If the log file already exists at startup, +the process simply needs write access to the file. Note that it will +need write access to the file's directory if you're encountering situations +where the logfile gets recreated, e.g. during log rotation. + +If Log::Log4perl is used by a web server application (e.g. in a CGI script +or mod_perl), then the webserver's user (usually C<nobody> or C<www>) +must have the permissions mentioned above. + +To prepare your web server to use log4perl, we'd recommend: + + webserver:~$ su - + webserver:~# mkdir /var/log/cgiapps + webserver:~# chown nobody:root /var/log/cgiapps/ + webserver:~# chown nobody:root -R /var/log/cgiapps/ + webserver:~# chmod 02755 -R /var/log/cgiapps/ + +Then set your /etc/log4perl.conf file to include: + + log4perl.appender.FileAppndr1.filename = + /var/log/cgiapps/<app-name>.log + +=head2 How can my file appender deal with disappearing log files? + +The file appender that comes with Log4perl, L<Log::Log4perl::Appender::File>, +will open a specified log file at initialization time and will +keep writing to it via a file handle. + +In case the associated file goes way, messages written by a +long-running process will still be written +to the file handle. In case the file has been moved to a different +location on the same file system, the writer will keep writing to +it under the new filename. In case the file has been removed from +the file system, the log messages will end up in nowhere land. This +is not a bug in Log4perl, this is how Unix works. There is +no error message in this case, because the writer has no idea that +the file handle is not associated with a visible file. + +To prevent the loss of log messages when log files disappear, the +file appender's C<recreate> option needs to be set to a true value: + + log4perl.appender.Logfile.recreate = 1 + +This will instruct the file appender to check in regular intervals +(default: 30 seconds) if the log file is still there. If it finds +out that the file is missing, it will recreate it. + +Continuously checking if the log file still exists is fairly +expensive. For this reason it is only performed every 30 seconds. To +change this interval, the option C<recreate_check_interval> can be set +to the number of seconds between checks. In the extreme case where the +check should be performed before every write, it can even be set to 0: + + log4perl.appender.Logfile.recreate = 1 + log4perl.appender.Logfile.recreate_check_interval = 0 + +To avoid having to check the file system so frequently, a signal +handler can be set up: + + log4perl.appender.Logfile.recreate = 1 + log4perl.appender.Logfile.recreate_check_signal = USR1 + +This will install a signal handler which will recreate a missing log file +immediately when it receives the defined signal. + +Note that the init_and_watch() method for Log4perl's initialization +can also be instructed to install a signal handler, usually using the +HUP signal. Make sure to use a different signal if you're using both +of them at the same time. + +=head2 How can I rotate a logfile with newsyslog? + +Here's a few things that need to be taken care of when using the popular +log file rotating utility C<newsyslog> +(http://www.courtesan.com/newsyslog) with Log4perl's file appender +in long-running processes. + +For example, with a newsyslog configuration like + + # newsyslog.conf + /tmp/test.log 666 12 5 * B + +and a call to + + # newsyslog -f /path/to/newsyslog.conf + +C<newsyslog> will take action if C</tmp/test.log> is larger than the +specified 5K in size. It will move the current log file C</tmp/test.log> to +C</tmp/test.log.0> and create a new and empty C</tmp/test.log> with +the specified permissions (this is why C<newsyslog> needs to run as root). +An already existing C</tmp/test.log.0> would be moved to +C</tmp/test.log.1>, C</tmp/test.log.1> to C</tmp/test.log.2>, and so +forth, for every one of a max number of 12 archived logfiles that have +been configured in C<newsyslog.conf>. + +Although a new file has been created, from Log4perl's appender's point +of view, this situation is identical to the one described in the +previous FAQ entry, labeled C<How can my file appender deal with +disappearing log files>. + +To make sure that log messages are written to the new log file and not +to an archived one or end up in nowhere land, +the appender's C<recreate> and C<recreate_check_interval> have to be +configured to deal with the 'disappearing' log file. + +The situation gets interesting when C<newsyslog>'s option +to compress archived log files is enabled. This causes the +original log file not to be moved, but to disappear. If the +file appender isn't configured to recreate the logfile in this situation, +log messages will actually be lost without warning. This also +applies for the short time frame of C<recreate_check_interval> seconds +in between the recreator's file checks. + +To make sure that no messages get lost, one option is to set the +interval to + + log4perl.appender.Logfile.recreate_check_interval = 0 + +However, this is fairly expensive. A better approach is to define +a signal handler: + + log4perl.appender.Logfile.recreate = 1 + log4perl.appender.Logfile.recreate_check_signal = USR1 + log4perl.appender.Logfile.recreate_pid_write = /tmp/myappid + +As a service for C<newsyslog> users, Log4perl's file appender writes +the current process ID to a PID file specified by the C<recreate_pid_write> +option. C<newsyslog> then needs to be configured as in + + # newsyslog.conf configuration for compressing archive files and + # sending a signal to the Log4perl-enabled application + /tmp/test.log 666 12 5 * B /tmp/myappid 30 + +to send the defined signal (30, which is USR1 on FreeBSD) to the +application process at rotation time. Note that the signal number +is different on Linux, where USR1 denotes as 10. Check C<man signal> +for details. + +=head2 How can a process under user id A log to a file under user id B? + +This scenario often occurs in configurations where processes run under +various user IDs but need to write to a log file under a fixed, but +different user id. + +With a traditional file appender, the log file will probably be created +under one user's id and appended to under a different user's id. With +a typical umask of 0002, the file will be created with -rw-rw-r-- +permissions. If a user who's not in the first user's group +subsequently appends to the log file, it will fail because of a +permission problem. + +Two potential solutions come to mind: + +=over 4 + +=item * + +Creating the file with a umask of 0000 will allow all users to append +to the log file. Log4perl's file appender C<Log::Log4perl::Appender::File> +has an C<umask> option that can be set to support this: + + log4perl.appender.File = Log::Log4perl::Appender::File + log4perl.appender.File.umask = sub { 0000 }; + +This way, the log file will be created with -rw-rw-rw- permissions and +therefore has world write permissions. This might open up the logfile +for unwanted manipulations by arbitrary users, though. + +=item * + +Running the process under an effective user id of C<root> will allow +it to write to the log file, no matter who started the process. +However, this is not a good idea, because of security concerns. + +=back + +Luckily, under Unix, there's the syslog daemon which runs as root and +takes log requests from user processes over a socket and writes them +to log files as configured in C</etc/syslog.conf>. + +By modifying C</etc/syslog.conf> and HUPing the syslog daemon, you can +configure new log files: + + # /etc/syslog.conf + ... + user.* /some/path/file.log + +Using the C<Log::Dispatch::Syslog> appender, which comes with the +C<Log::Log4perl> distribution, you can then send messages via syslog: + + use Log::Log4perl qw(:easy); + + Log::Log4perl->init(\<<EOT); + log4perl.logger = DEBUG, app + log4perl.appender.app=Log::Dispatch::Syslog + log4perl.appender.app.Facility=user + log4perl.appender.app.layout=SimpleLayout + EOT + + # Writes to /some/path/file.log + ERROR "Message!"; + +This way, the syslog daemon will solve the permission problem. + +Note that while it is possible to use syslog() without Log4perl (syslog +supports log levels, too), traditional syslog setups have a +significant drawback. + +Without Log4perl's ability to activate logging in only specific +parts of a system, complex systems will trigger log events all over +the place and slow down execution to a crawl at high debug levels. + +Remote-controlling logging in the hierarchical parts of an application +via Log4perl's categories is one of its most distinguished features. +It allows for enabling high debug levels in specified areas without +noticeable performance impact. + +=head2 I want to use UTC instead of the local time! + +If a layout defines a date, Log::Log4perl uses local time to populate it. +If you want UTC instead, set + + log4perl.utcDateTimes = 1 + +in your configuration. Alternatively, you can set + + $Log::Log4perl::DateFormat::GMTIME = 1; + +in your program before the first log statement. + +=head2 Can Log4perl intercept messages written to a filehandle? + +You have a function that prints to a filehandle. You want to tie +into that filehandle and forward all arriving messages to a +Log4perl logger. + +First, let's write a package that ties a file handle and forwards it +to a Log4perl logger: + + package FileHandleLogger; + use Log::Log4perl qw(:levels get_logger); + + sub TIEHANDLE { + my($class, %options) = @_; + + my $self = { + level => $DEBUG, + category => '', + %options + }; + + $self->{logger} = get_logger($self->{category}), + bless $self, $class; + } + + sub PRINT { + my($self, @rest) = @_; + $Log::Log4perl::caller_depth++; + $self->{logger}->log($self->{level}, @rest); + $Log::Log4perl::caller_depth--; + } + + sub PRINTF { + my($self, $fmt, @rest) = @_; + $Log::Log4perl::caller_depth++; + $self->PRINT(sprintf($fmt, @rest)); + $Log::Log4perl::caller_depth--; + } + + 1; + +Now, if you have a function like + + sub function_printing_to_fh { + my($fh) = @_; + printf $fh "Hi there!\n"; + } + +which takes a filehandle and prints something to it, it can be used +with Log4perl: + + use Log::Log4perl qw(:easy); + usa FileHandleLogger; + + Log::Log4perl->easy_init($DEBUG); + + tie *SOMEHANDLE, 'FileHandleLogger' or + die "tie failed ($!)"; + + function_printing_to_fh(*SOMEHANDLE); + # prints "2007/03/22 21:43:30 Hi there!" + +If you want, you can even specify a different log level or category: + + tie *SOMEHANDLE, 'FileHandleLogger', + level => $INFO, category => "Foo::Bar" or die "tie failed ($!)"; + +=head2 I want multiline messages rendered line-by-line! + +With the standard C<PatternLayout>, if you send a multiline message to +an appender as in + + use Log::Log4perl qw(:easy); + Log + +it gets rendered this way: + + 2007/04/04 23:23:39 multi + line + message + +If you want each line to be rendered separately according to +the layout use C<Log::Log4perl::Layout::PatternLayout::Multiline>: + + use Log::Log4perl qw(:easy); + + Log::Log4perl->init(\<<EOT); + log4perl.category = DEBUG, Screen + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = \\ + Log::Log4perl::Layout::PatternLayout::Multiline + log4perl.appender.Screen.layout.ConversionPattern = %d %m %n + EOT + + DEBUG "some\nmultiline\nmessage"; + +and you'll get + + 2007/04/04 23:23:39 some + 2007/04/04 23:23:39 multiline + 2007/04/04 23:23:39 message + +instead. + +=head2 I'm on Windows and I'm getting all these 'redefined' messages! + +If you're on Windows and are getting warning messages like + + Constant subroutine Log::Log4perl::_INTERNAL_DEBUG redefined at + C:/Programme/Perl/lib/constant.pm line 103. + Subroutine import redefined at + C:/Programme/Perl/site/lib/Log/Log4Perl.pm line 69. + Subroutine initialized redefined at + C:/Programme/Perl/site/lib/Log/Log4Perl.pm line 207. + +then chances are that you're using 'Log::Log4Perl' (wrong uppercase P) +instead of the correct 'Log::Log4perl'. Perl on Windows doesn't +handle this error well and spits out a slew of confusing warning +messages. But now you know, just use the correct module name and +you'll be fine. + +=head2 Log4perl complains that no initialization happened during shutdown! + +If you're using Log4perl log commands in DESTROY methods of your objects, +you might see confusing messages like + + Log4perl: Seems like no initialization happened. Forgot to call init()? + Use of uninitialized value in subroutine entry at + /home/y/lib/perl5/site_perl/5.6.1/Log/Log4perl.pm line 134 during global + destruction. (in cleanup) Undefined subroutine &main:: called at + /home/y/lib/perl5/site_perl/5.6.1/Log/Log4perl.pm line 134 during global + destruction. + +when the program shuts down. What's going on? + +This phenomenon happens if you have circular references in your objects, +which perl can't clean up when an object goes out of scope but waits +until global destruction instead. At this time, however, Log4perl has +already shut down, so you can't use it anymore. + +For example, here's a simple class which uses a logger in its DESTROY +method: + + package A; + use Log::Log4perl qw(:easy); + sub new { bless {}, shift } + sub DESTROY { DEBUG "Waaah!"; } + +Now, if the main program creates a self-referencing object, like in + + package main; + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init($DEBUG); + + my $a = A->new(); + $a->{selfref} = $a; + +then you'll see the error message shown above during global destruction. +How to tackle this problem? + +First, you should clean up your circular references before global +destruction. They will not only cause objects to be destroyed in an order +that's hard to predict, but also eat up memory until the program shuts +down. + +So, the program above could easily be fixed by putting + + $a->{selfref} = undef; + +at the end or in an END handler. If that's hard to do, use weak references: + + package main; + use Scalar::Util qw(weaken); + use Log::Log4perl qw(:easy); + Log::Log4perl->easy_init($DEBUG); + + my $a = A->new(); + $a->{selfref} = weaken $a; + +This allows perl to clean up the circular reference when the object +goes out of scope, and doesn't wait until global destruction. + +=head2 How can I access POE heap values from Log4perl's layout? + +POE is a framework for creating multitasked applications running in a +single process and a single thread. POE's threads equivalents are +'sessions' and since they run quasi-simultaneously, you can't use +Log4perl's global NDC/MDC to hold session-specific data. + +However, POE already maintains a data store for every session. It is called +'heap' and is just a hash storing session-specific data in key-value pairs. +To access this per-session heap data from a Log4perl layout, define a +custom cspec and reference it with the newly defined pattern in the layout: + + use strict; + use POE; + use Log::Log4perl qw(:easy); + + Log::Log4perl->init( \ q{ + log4perl.logger = DEBUG, Screen + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.layout = PatternLayout + log4perl.appender.Screen.layout.ConversionPattern = %U %m%n + log4perl.PatternLayout.cspec.U = \ + sub { POE::Kernel->get_active_session->get_heap()->{ user } } + } ); + + for (qw( Huey Lewey Dewey )) { + POE::Session->create( + inline_states => { + _start => sub { + $_[HEAP]->{user} = $_; + POE::Kernel->yield('hello'); + }, + hello => sub { + DEBUG "I'm here now"; + } + } + ); + } + + POE::Kernel->run(); + exit; + +The code snippet above defines a new layout placeholder (called +'cspec' in Log4perl) %U which calls a subroutine, retrieves the active +session, gets its heap and looks up the entry specified ('user'). + +Starting with Log::Log4perl 1.20, cspecs also support parameters in +curly braces, so you can say + + log4perl.appender.Screen.layout.ConversionPattern = %U{user} %U{id} %m%n + log4perl.PatternLayout.cspec.U = \ + sub { POE::Kernel->get_active_session-> \ + get_heap()->{ $_[0]->{curlies} } } + +and print the POE session heap entries 'user' and 'id' with every logged +message. For more details on cpecs, read the PatternLayout manual. + +=head2 I want to print something unconditionally! + +Sometimes it's a script that's supposed to log messages regardless if +Log4perl has been initialized or not. Or there's a logging statement that's +not going to be suppressed under any circumstances -- many people want to +have the final word, make the executive decision, because it seems like +the only logical choice. + +But think about it: +First off, if a messages is supposed to be printed, where is it supposed +to end up at? STDOUT? STDERR? And are you sure you want to set in stone +that this message needs to be printed, while someone else might +find it annoying and wants to get rid of it? + +The truth is, there's always going to be someone who wants to log a +messages at all cost, but also another person who wants to suppress it +with equal vigilance. There's no good way to serve these two conflicting +desires, someone will always want to win at the cost of leaving +the other party disappointed. + +So, the best Log4perl offers is the ALWAYS level for a message that even +fires if the system log level is set to $OFF: + + use Log::Log4perl qw(:easy); + + Log::Log4perl->easy_init( $OFF ); + ALWAYS "This gets logged always. Well, almost always"; + +The logger won't fire, though, if Log4perl hasn't been initialized or +if someone defines a custom log hurdle that's higher than $OFF. + +Bottom line: Leave the setting of the logging level to the initial Perl +script -- let their owners decided what they want, no matter how tempting +it may be to decide it for them. + +=head2 Why doesn't my END handler remove my log file on Win32? + +If you have code like + + use Log::Log4perl qw( :easy ); + Log::Log4perl->easy_init( { level => $DEBUG, file => "my.log" } ); + END { unlink "my.log" or die }; + +then you might be in for a surprise when you're running it on +Windows, because the C<unlink()> call in the END handler will complain that +the file is still in use. + +What happens in Perl if you have something like + + END { print "first end in main\n"; } + use Module; + END { print "second end in main\n"; } + +and + + package Module; + END { print "end in module\n"; } + 1; + +is that you get + + second end in main + end in module + first end in main + +because perl stacks the END handlers in reverse order in which it +encounters them in the compile phase. + +Log4perl defines an END handler that cleans up left-over appenders (e.g. +file appenders which still hold files open), because those appenders have +circular references and therefore aren't cleaned up otherwise. + +Now if you define an END handler after "use Log::Log4perl", it'll +trigger before Log4perl gets a chance to clean up, which isn't a +problem on Unix where you can delete a file even if some process has a +handle to it open, but it's a problem on Win32, where the OS won't +let you do that. + +The solution is easy, just place the END handler I<before> Log4perl +gets loaded, like in + + END { unlink "my.log" or die }; + use Log::Log4perl qw( :easy ); + Log::Log4perl->easy_init( { level => $DEBUG, file => "my.log" } ); + +which will call the END handlers in the intended order. + +=cut + +=head1 SEE ALSO + +Log::Log4perl + +=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. + diff --git a/lib/Log/Log4perl/Filter.pm b/lib/Log/Log4perl/Filter.pm new file mode 100644 index 0000000..1d2ebe8 --- /dev/null +++ b/lib/Log/Log4perl/Filter.pm @@ -0,0 +1,368 @@ +################################################## +package Log::Log4perl::Filter; +################################################## + +use 5.006; +use strict; +use warnings; + +use Log::Log4perl::Level; +use Log::Log4perl::Config; + +use constant _INTERNAL_DEBUG => 0; + +our %FILTERS_DEFINED = (); + +################################################## +sub new { +################################################## + my($class, $name, $action) = @_; + + print "Creating filter $name\n" if _INTERNAL_DEBUG; + + my $self = { name => $name }; + bless $self, $class; + + if(ref($action) eq "CODE") { + # it's a code ref + $self->{ok} = $action; + } else { + # it's something else + die "Code for ($name/$action) not properly defined"; + } + + return $self; +} + +################################################## +sub register { # Register a filter by name + # (Passed on to subclasses) +################################################## + my($self) = @_; + + by_name($self->{name}, $self); +} + +################################################## +sub by_name { # Get/Set a filter object by name +################################################## + my($name, $value) = @_; + + if(defined $value) { + $FILTERS_DEFINED{$name} = $value; + } + + if(exists $FILTERS_DEFINED{$name}) { + return $FILTERS_DEFINED{$name}; + } else { + return undef; + } +} + +################################################## +sub reset { +################################################## + %FILTERS_DEFINED = (); +} + +################################################## +sub ok { +################################################## + my($self, %p) = @_; + + print "Calling $self->{name}'s ok method\n" if _INTERNAL_DEBUG; + + # Force filter classes to define their own + # ok(). Exempt are only sub {..} ok functions, + # defined in the conf file. + die "This is to be overridden by the filter" unless + defined $self->{ok}; + + # What should we set the message in $_ to? The most logical + # approach seems to be to concat all parts together. If some + # filter wants to dissect the parts, it still can examine %p, + # which gets passed to the subroutine and contains the chunks + # in $p{message}. + # Split because of CVS + local($_) = join $ + Log::Log4perl::JOIN_MSG_ARRAY_CHAR, @{$p{message}}; + print "\$_ is '$_'\n" if _INTERNAL_DEBUG; + + my $decision = $self->{ok}->(%p); + + print "$self->{name}'s ok'ed: ", + ($decision ? "yes" : "no"), "\n" if _INTERNAL_DEBUG; + + return $decision; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Filter - Log4perl Custom Filter Base Class + +=head1 SYNOPSIS + + use Log::Log4perl; + + Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, Screen + log4perl.filter.MyFilter = sub { /let this through/ } + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.Filter = MyFilter + log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout + EOT + + # Define a logger + my $logger = Log::Log4perl->get_logger("Some"); + + # Let this through + $logger->info("Here's the info, let this through!"); + + # Suppress this + $logger->info("Here's the info, suppress this!"); + + ################################################################# + # StringMatch Filter: + ################################################################# + log4perl.filter.M1 = Log::Log4perl::Filter::StringMatch + log4perl.filter.M1.StringToMatch = let this through + log4perl.filter.M1.AcceptOnMatch = true + + ################################################################# + # LevelMatch Filter: + ################################################################# + log4perl.filter.M1 = Log::Log4perl::Filter::LevelMatch + log4perl.filter.M1.LevelToMatch = INFO + log4perl.filter.M1.AcceptOnMatch = true + +=head1 DESCRIPTION + +Log4perl allows the use of customized filters in its appenders +to control the output of messages. These filters might grep for +certain text chunks in a message, verify that its priority +matches or exceeds a certain level or that this is the 10th +time the same message has been submitted -- and come to a log/no log +decision based upon these circumstantial facts. + +Filters have names and can be specified in two different ways in the Log4perl +configuration file: As subroutines or as filter classes. Here's a +simple filter named C<MyFilter> which just verifies that the +oncoming message matches the regular expression C</let this through/i>: + + log4perl.filter.MyFilter = sub { /let this through/i } + +It exploits the fact that when the subroutine defined +above is called on a message, +Perl's special C<$_> variable will be set to the message text (prerendered, +i.e. concatenated but not layouted) to be logged. +The subroutine is expected to return a true value +if it wants the message to be logged or a false value if doesn't. + +Also, Log::Log4perl will pass a hash to the subroutine, +containing all key/value pairs that it would pass to the corresponding +appender, as specified in Log::Log4perl::Appender. Here's an +example of a filter checking the priority of the oncoming message: + + log4perl.filter.MyFilter = sub { \ + my %p = @_; \ + if($p{log4p_level} eq "WARN" or \ + $p{log4p_level} eq "INFO") { \ + return 1; \ + } \ + return 0; \ + } + +If the message priority equals C<WARN> or C<INFO>, +it returns a true value, causing +the message to be logged. + +=head2 Predefined Filters + +For common tasks like verifying that the message priority matches +a certain priority, there's already a +set of predefined filters available. To perform an exact level match, it's +much cleaner to use Log4perl's C<LevelMatch> filter instead: + + log4perl.filter.M1 = Log::Log4perl::Filter::LevelMatch + log4perl.filter.M1.LevelToMatch = INFO + log4perl.filter.M1.AcceptOnMatch = true + +This will let the message through if its priority is INFO and suppress +it otherwise. The statement can be negated by saying + + log4perl.filter.M1.AcceptOnMatch = false + +instead. This way, the message will be logged if its priority is +anything but INFO. + +On a similar note, Log4perl's C<StringMatch> filter will check the +oncoming message for strings or regular expressions: + + log4perl.filter.M1 = Log::Log4perl::Filter::StringMatch + log4perl.filter.M1.StringToMatch = bl.. bl.. + log4perl.filter.M1.AcceptOnMatch = true + +This will open the gate for messages like C<blah blah> because the +regular expression in the C<StringToMatch> matches them. Again, +the setting of C<AcceptOnMatch> determines if the filter is defined +in a positive or negative way. + +All class filter entries in the configuration file +have to adhere to the following rule: +Only after a filter has been defined by name and class/subroutine, +its attribute values can be +assigned, just like the C<true> value above gets assigned to the +C<AcceptOnMatch> attribute I<after> the +filter C<M1> has been defined. + +=head2 Attaching a filter to an appender + +Attaching a filter to an appender is as easy as assigning its name to +the appender's C<Filter> attribute: + + log4perl.appender.MyAppender.Filter = MyFilter + +This will cause C<Log::Log4perl> to call the filter subroutine/method +every time a message is supposed to be passed to the appender. Depending +on the filter's return value, C<Log::Log4perl> will either continue as +planned or withdraw immediately. + +=head2 Combining filters with Log::Log4perl::Filter::Boolean + +Sometimes, it's useful to combine the output of various filters to +arrive at a log/no log decision. While Log4j, Log4perl's mother ship, +has chosen to implement this feature as a filter chain, similar to Linux' IP chains, +Log4perl tries a different approach. + +Typically, filter results will not need to be bumped along chains but +combined in a programmatic manner using boolean logic. "Log if +this filter says 'yes' and that filter says 'no'" +is a fairly common requirement, but hard to implement as a chain. + +C<Log::Log4perl::Filter::Boolean> is a specially predefined custom filter +for Log4perl. It combines the results of other custom filters +in arbitrary ways, using boolean expressions: + + log4perl.logger = WARN, AppWarn, AppError + + log4perl.filter.Match1 = sub { /let this through/ } + log4perl.filter.Match2 = sub { /and that, too/ } + log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean + log4perl.filter.MyBoolean.logic = Match1 || Match2 + + log4perl.appender.Screen = Log::Log4perl::Appender::Screen + log4perl.appender.Screen.Filter = MyBoolean + log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout + +C<Log::Log4perl::Filter::Boolean>'s boolean expressions allow for combining +different appenders by name using AND (&& or &), OR (|| or |) and NOT (!) as +logical expressions. Also, parentheses can be used for defining precedences. +Operator precedence follows standard Perl conventions. Here's a bunch of examples: + + Match1 && !Match2 # Match1 and not Match2 + !(Match1 || Match2) # Neither Match1 nor Match2 + (Match1 && Match2) || Match3 # Both Match1 and Match2 or Match3 + +=head2 Writing your own filter classes + +If none of Log::Log4perl's predefined filter classes fits your needs, +you can easily roll your own: Just define a new class, +derive it from the baseclass C<Log::Log4perl::Filter>, +and define its C<new> and C<ok> methods like this: + + package Log::Log4perl::Filter::MyFilter; + + use base Log::Log4perl::Filter; + + sub new { + my ($class, %options) = @_; + + my $self = { %options, + }; + + bless $self, $class; + + return $self; + } + + sub ok { + my ($self, %p) = @_; + + # ... decide and return 1 or 0 + } + + 1; + +Log4perl will call the ok() method to determine if the filter +should let the message pass or not. A true return value indicates +the message will be logged by the appender, a false value blocks it. + +Values you've defined for its attributes in Log4perl's configuration file, +will be received through its C<new> method: + + log4perl.filter.MyFilter = Log::Log4perl::Filter::MyFilter + log4perl.filter.MyFilter.color = red + +will cause C<Log::Log4perl::Filter::MyFilter>'s constructor to be called +like this: + + Log::Log4perl::Filter::MyFilter->new( name => "MyFilter", + color => "red" ); + +The custom filter class should use this to set the object's attributes, +to have them available later to base log/nolog decisions on it. + +C<ok()> is the filter's method to tell if it agrees or disagrees with logging +the message. It will be called by Log::Log4perl whenever it needs the +filter to decide. A false value returned by C<ok()> will block messages, +a true value will let them through. + +=head2 A Practical Example: Level Matching + +See L<Log::Log4perl::FAQ> for this. + +=head1 SEE ALSO + +L<Log::Log4perl::Filter::LevelMatch>, +L<Log::Log4perl::Filter::LevelRange>, +L<Log::Log4perl::Filter::StringRange>, +L<Log::Log4perl::Filter::Boolean> + +=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. + diff --git a/lib/Log/Log4perl/Filter/Boolean.pm b/lib/Log/Log4perl/Filter/Boolean.pm new file mode 100644 index 0000000..21201d4 --- /dev/null +++ b/lib/Log/Log4perl/Filter/Boolean.pm @@ -0,0 +1,211 @@ +################################################## +package Log::Log4perl::Filter::Boolean; +################################################## + +use 5.006; + +use strict; +use warnings; + +use Log::Log4perl::Level; +use Log::Log4perl::Config; + +use constant _INTERNAL_DEBUG => 0; + +use base qw(Log::Log4perl::Filter); + +################################################## +sub new { +################################################## + my ($class, %options) = @_; + + my $self = { params => {}, + %options, + }; + + bless $self, $class; + + print "Compiling '$options{logic}'\n" if _INTERNAL_DEBUG; + + # Set up meta-decider for later + $self->compile_logic($options{logic}); + + return $self; +} + +################################################## +sub ok { +################################################## + my ($self, %p) = @_; + + return $self->eval_logic(\%p); +} + +################################################## +sub compile_logic { +################################################## + my ($self, $logic) = @_; + + # Extract Filter placeholders in logic as defined + # in configuration file. + while($logic =~ /([\w_-]+)/g) { + # Get the corresponding filter object + my $filter = Log::Log4perl::Filter::by_name($1); + die "Filter $filter required by Boolean filter, but not defined" + unless $filter; + + $self->{params}->{$1} = $filter; + } + + # Fabricate a parameter list: A1/A2/A3 => $A1, $A2, $A3 + my $plist = join ', ', map { '$' . $_ } keys %{$self->{params}}; + + # Replace all the (dollar-less) placeholders in the code with + # calls to their respective coderefs. + $logic =~ s/([\w_-]+)/\&\$$1/g; + + # Set up the meta decider, which transforms the config file + # logic into compiled perl code + my $func = <<EOT; + sub { + my($plist) = \@_; + $logic; + } +EOT + + print "func=$func\n" if _INTERNAL_DEBUG; + + my $eval_func = eval $func; + + if(! $eval_func) { + die "Syntax error in Boolean filter logic: $eval_func"; + } + + $self->{eval_func} = $eval_func; +} + +################################################## +sub eval_logic { +################################################## + my($self, $p) = @_; + + my @plist = (); + + # Eval the results of all filters referenced + # in the code (although the order of keys is + # not predictable, it is consistent :) + for my $param (keys %{$self->{params}}) { + # Pass a coderef as a param that will run the filter's ok method and + # return a 1 or 0. + print "Passing filter $param\n" if _INTERNAL_DEBUG; + push(@plist, sub { + return $self->{params}->{$param}->ok(%$p) ? 1 : 0 + }); + } + + # Now pipe the parameters into the canned function, + # have it evaluate the logic and return the final + # decision + print "Passing in (", join(', ', @plist), ")\n" if _INTERNAL_DEBUG; + return $self->{eval_func}->(@plist); +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Filter::Boolean - Special filter to combine the results of others + +=head1 SYNOPSIS + + log4perl.logger = WARN, AppWarn, AppError + + log4perl.filter.Match1 = sub { /let this through/ } + log4perl.filter.Match2 = sub { /and that, too/ } + log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean + log4perl.filter.MyBoolean.logic = Match1 || Match2 + + log4perl.appender.Screen = Log::Dispatch::Screen + log4perl.appender.Screen.Filter = MyBoolean + log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout + +=head1 DESCRIPTION + +Sometimes, it's useful to combine the output of various filters to +arrive at a log/no log decision. While Log4j, Log4perl's mother ship, +chose to implement this feature as a filter chain, similar to Linux' IP chains, +Log4perl tries a different approach. + +Typically, filter results will not need to be passed along in chains but +combined in a programmatic manner using boolean logic. "Log if +this filter says 'yes' and that filter says 'no'" +is a fairly common requirement but hard to implement as a chain. + +C<Log::Log4perl::Filter::Boolean> is a special predefined custom filter +for Log4perl which combines the results of other custom filters +in arbitrary ways, using boolean expressions: + + log4perl.logger = WARN, AppWarn, AppError + + log4perl.filter.Match1 = sub { /let this through/ } + log4perl.filter.Match2 = sub { /and that, too/ } + log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean + log4perl.filter.MyBoolean.logic = Match1 || Match2 + + log4perl.appender.Screen = Log::Dispatch::Screen + log4perl.appender.Screen.Filter = MyBoolean + log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout + +C<Log::Log4perl::Filter::Boolean>'s boolean expressions allow for combining +different appenders by name using AND (&& or &), OR (|| or |) and NOT (!) as +logical expressions. Parentheses are used for grouping. Precedence follows +standard Perl. Here's a bunch of examples: + + Match1 && !Match2 # Match1 and not Match2 + !(Match1 || Match2) # Neither Match1 nor Match2 + (Match1 && Match2) || Match3 # Both Match1 and Match2 or Match3 + +=head1 SEE ALSO + +L<Log::Log4perl::Filter>, +L<Log::Log4perl::Filter::LevelMatch>, +L<Log::Log4perl::Filter::LevelRange>, +L<Log::Log4perl::Filter::MDC>, +L<Log::Log4perl::Filter::StringRange> + +=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. + diff --git a/lib/Log/Log4perl/Filter/LevelMatch.pm b/lib/Log/Log4perl/Filter/LevelMatch.pm new file mode 100644 index 0000000..4aeb014 --- /dev/null +++ b/lib/Log/Log4perl/Filter/LevelMatch.pm @@ -0,0 +1,118 @@ +################################################## +package Log::Log4perl::Filter::LevelMatch; +################################################## + +use 5.006; + +use strict; +use warnings; + +use Log::Log4perl::Level; +use Log::Log4perl::Config; +use Log::Log4perl::Util qw( params_check ); + +use constant _INTERNAL_DEBUG => 0; + +use base qw(Log::Log4perl::Filter); + +################################################## +sub new { +################################################## + my ($class, %options) = @_; + + my $self = { LevelToMatch => '', + AcceptOnMatch => 1, + %options, + }; + + params_check( $self, + [ qw( LevelToMatch ) ], + [ qw( name AcceptOnMatch ) ] + ); + + $self->{AcceptOnMatch} = Log::Log4perl::Config::boolean_to_perlish( + $self->{AcceptOnMatch}); + + bless $self, $class; + + return $self; +} + +################################################## +sub ok { +################################################## + my ($self, %p) = @_; + + if($self->{LevelToMatch} eq $p{log4p_level}) { + print "Levels match\n" if _INTERNAL_DEBUG; + return $self->{AcceptOnMatch}; + } else { + print "Levels don't match\n" if _INTERNAL_DEBUG; + return !$self->{AcceptOnMatch}; + } +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Filter::LevelMatch - Filter to match the log level exactly + +=head1 SYNOPSIS + + log4perl.filter.Match1 = Log::Log4perl::Filter::LevelMatch + log4perl.filter.Match1.LevelToMatch = ERROR + log4perl.filter.Match1.AcceptOnMatch = true + +=head1 DESCRIPTION + +This Log4perl custom filter checks if the currently submitted message +matches a predefined priority, as set in C<LevelToMatch>. +The additional parameter C<AcceptOnMatch> defines if the filter +is supposed to pass or block the message (C<true> or C<false>) +on a match. + +=head1 SEE ALSO + +L<Log::Log4perl::Filter>, +L<Log::Log4perl::Filter::Boolean>, +L<Log::Log4perl::Filter::LevelRange>, +L<Log::Log4perl::Filter::MDC>, +L<Log::Log4perl::Filter::StringMatch> + +=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. + diff --git a/lib/Log/Log4perl/Filter/LevelRange.pm b/lib/Log/Log4perl/Filter/LevelRange.pm new file mode 100644 index 0000000..4e8107b --- /dev/null +++ b/lib/Log/Log4perl/Filter/LevelRange.pm @@ -0,0 +1,126 @@ +################################################## +package Log::Log4perl::Filter::LevelRange; +################################################## + +use 5.006; + +use strict; +use warnings; + +use Log::Log4perl::Level; +use Log::Log4perl::Config; +use Log::Log4perl::Util qw( params_check ); + +use constant _INTERNAL_DEBUG => 0; + +use base "Log::Log4perl::Filter"; + +################################################## +sub new { +################################################## + my ($class, %options) = @_; + + my $self = { LevelMin => 'DEBUG', + LevelMax => 'FATAL', + AcceptOnMatch => 1, + %options, + }; + + params_check( $self, + [ qw( LevelMin LevelMax ) ], + [ qw( name AcceptOnMatch ) ] + ); + + $self->{AcceptOnMatch} = Log::Log4perl::Config::boolean_to_perlish( + $self->{AcceptOnMatch}); + + bless $self, $class; + + return $self; +} + +################################################## +sub ok { +################################################## + my ($self, %p) = @_; + + if(Log::Log4perl::Level::to_priority($self->{LevelMin}) <= + Log::Log4perl::Level::to_priority($p{log4p_level}) and + Log::Log4perl::Level::to_priority($self->{LevelMax}) >= + Log::Log4perl::Level::to_priority($p{log4p_level})) { + return $self->{AcceptOnMatch}; + } else { + return ! $self->{AcceptOnMatch}; + } +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Filter::LevelRange - Filter for a range of log levels + +=head1 SYNOPSIS + + log4perl.filter.Match1 = Log::Log4perl::Filter::LevelRange + log4perl.filter.Match1.LevelMin = INFO + log4perl.filter.Match1.LevelMax = ERROR + log4perl.filter.Match1.AcceptOnMatch = true + +=head1 DESCRIPTION + +This Log4perl custom filter checks if the current message +has a priority matching a predefined range. +The C<LevelMin> and C<LevelMax> parameters define the levels +(choose from C<DEBUG>, C<INFO>, C<WARN>, C<ERROR>, C<FATAL>) marking +the window of allowed messages priorities. + +C<LevelMin> defaults to C<DEBUG>, and C<LevelMax> to C<FATAL>. + +The additional parameter C<AcceptOnMatch> defines if the filter +is supposed to pass or block the message (C<true> or C<false>). + +=head1 SEE ALSO + +L<Log::Log4perl::Filter>, +L<Log::Log4perl::Filter::Boolean>, +L<Log::Log4perl::Filter::LevelMatch>, +L<Log::Log4perl::Filter::MDC>, +L<Log::Log4perl::Filter::StringMatch> + +=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. + diff --git a/lib/Log/Log4perl/Filter/MDC.pm b/lib/Log/Log4perl/Filter/MDC.pm new file mode 100644 index 0000000..ae9211b --- /dev/null +++ b/lib/Log/Log4perl/Filter/MDC.pm @@ -0,0 +1,97 @@ +package Log::Log4perl::Filter::MDC; +use strict; +use warnings; + +use Log::Log4perl::Util qw( params_check ); + +use base "Log::Log4perl::Filter"; + +sub new { + my ( $class, %options ) = @_; + + my $self = {%options}; + + params_check( $self, [qw( KeyToMatch RegexToMatch )] ); + + $self->{RegexToMatch} = qr/$self->{RegexToMatch}/; + + bless $self, $class; + + return $self; +} + +sub ok { + my ( $self, %p ) = @_; + + my $context = Log::Log4perl::MDC->get_context; + + my $value = $context->{ $self->{KeyToMatch} }; + return 1 + if defined $value && $value =~ $self->{RegexToMatch}; + + return 0; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Filter::MDC - Filter to match on values of a MDC key + +=head1 SYNOPSIS + + log4perl.filter.Match1 = Log::Log4perl::Filter::MDC + log4perl.filter.Match1.KeyToMatch = foo + log4perl.filter.Match1.RegexToMatch = bar + +=head1 DESCRIPTION + +This Log4perl filter checks if a predefined MDC key, as set in C<KeyToMatch>, +of the currently submitted message matches a predefined regex, as set in +C<RegexToMatch>. + +=head1 SEE ALSO + +L<Log::Log4perl::Filter>, +L<Log::Log4perl::Filter::Boolean>, +L<Log::Log4perl::Filter::LevelMatch>, +L<Log::Log4perl::Filter::LevelRange>, +L<Log::Log4perl::Filter::MDC>, +L<Log::Log4perl::Filter::StringMatch> + +=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. + diff --git a/lib/Log/Log4perl/Filter/StringMatch.pm b/lib/Log/Log4perl/Filter/StringMatch.pm new file mode 100644 index 0000000..5259da9 --- /dev/null +++ b/lib/Log/Log4perl/Filter/StringMatch.pm @@ -0,0 +1,126 @@ +################################################## +package Log::Log4perl::Filter::StringMatch; +################################################## + +use 5.006; + +use strict; +use warnings; + +use Log::Log4perl::Config; +use Log::Log4perl::Util qw( params_check ); + +use constant _INTERNAL_DEBUG => 0; + +use base "Log::Log4perl::Filter"; + +################################################## +sub new { +################################################## + my ($class, %options) = @_; + + print join('-', %options) if _INTERNAL_DEBUG; + + my $self = { StringToMatch => undef, + AcceptOnMatch => 1, + %options, + }; + + params_check( $self, + [ qw( StringToMatch ) ], + [ qw( name AcceptOnMatch ) ] + ); + + $self->{AcceptOnMatch} = Log::Log4perl::Config::boolean_to_perlish( + $self->{AcceptOnMatch}); + + $self->{StringToMatch} = qr($self->{StringToMatch}); + + bless $self, $class; + + return $self; +} + +################################################## +sub ok { +################################################## + my ($self, %p) = @_; + + local($_) = join $ + Log::Log4perl::JOIN_MSG_ARRAY_CHAR, @{$p{message}}; + + if($_ =~ $self->{StringToMatch}) { + print "Strings match\n" if _INTERNAL_DEBUG; + return $self->{AcceptOnMatch}; + } else { + print "Strings don't match ($_/$self->{StringToMatch})\n" + if _INTERNAL_DEBUG; + return !$self->{AcceptOnMatch}; + } +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Filter::StringMatch - Filter on log message string + +=head1 SYNOPSIS + + log4perl.filter.Match1 = Log::Log4perl::Filter::StringMatch + log4perl.filter.Match1.StringToMatch = blah blah + log4perl.filter.Match1.AcceptOnMatch = true + +=head1 DESCRIPTION + +This Log4perl custom filter checks if the currently submitted message +matches a predefined regular expression, as set in the C<StringToMatch> +parameter. It uses common Perl 5 regexes. + +The additional parameter C<AcceptOnMatch> defines if the filter +is supposed to pass or block the message on a match (C<true> or C<false>). + +=head1 SEE ALSO + +L<Log::Log4perl::Filter>, +L<Log::Log4perl::Filter::Boolean>, +L<Log::Log4perl::Filter::LevelMatch>, +L<Log::Log4perl::Filter::LevelRange>, +L<Log::Log4perl::Filter::MDC> + +=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. + diff --git a/lib/Log/Log4perl/InternalDebug.pm b/lib/Log/Log4perl/InternalDebug.pm new file mode 100644 index 0000000..2cee7d0 --- /dev/null +++ b/lib/Log/Log4perl/InternalDebug.pm @@ -0,0 +1,122 @@ +package Log::Log4perl::InternalDebug; +use warnings; +use strict; + +use File::Temp qw(tempfile); +use File::Spec; + +require Log::Log4perl::Resurrector; + +########################################### +sub enable { +########################################### + unshift @INC, \&internal_debug_loader; +} + +################################################## +sub internal_debug_fh { +################################################## + my($file) = @_; + + local($/) = undef; + open FILE, "<$file" or die "Cannot open $file"; + my $text = <FILE>; + close FILE; + + my($tmp_fh, $tmpfile) = tempfile( UNLINK => 1 ); + + $text =~ s/_INTERNAL_DEBUG(?!\s*=>)/1/g; + + print $tmp_fh $text; + seek $tmp_fh, 0, 0; + + return $tmp_fh; +} + +########################################### +sub internal_debug_loader { +########################################### + my ($code, $module) = @_; + + # Skip non-Log4perl modules + if($module !~ m#^Log/Log4perl#) { + return undef; + } + + my $path = $module; + if(!-f $path) { + $path = Log::Log4perl::Resurrector::pm_search( $module ); + } + + my $fh = internal_debug_fh($path); + + my $abs_path = File::Spec->rel2abs( $path ); + $INC{$module} = $abs_path; + + return $fh; +} + +########################################### +sub resurrector_init { +########################################### + unshift @INC, \&resurrector_loader; +} + +########################################### +sub import { +########################################### + # enable it on import + enable(); +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::InternalDebug - Dark Magic to enable _INTERNAL_DEBUG + +=head1 DESCRIPTION + +When called with + + perl -MLog::Log4perl::InternalDebug t/001Test.t + +scripts will run with _INTERNAL_DEBUG set to a true value and hence +print internal Log4perl debugging information. + +=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. + diff --git a/lib/Log/Log4perl/JavaMap.pm b/lib/Log/Log4perl/JavaMap.pm new file mode 100644 index 0000000..e5cf47c --- /dev/null +++ b/lib/Log/Log4perl/JavaMap.pm @@ -0,0 +1,184 @@ +package Log::Log4perl::JavaMap; + +use Carp; +use strict; + +use constant _INTERNAL_DEBUG => 0; + +our %translate = ( + 'org.apache.log4j.ConsoleAppender' => + 'Log::Log4perl::JavaMap::ConsoleAppender', + 'org.apache.log4j.FileAppender' => + 'Log::Log4perl::JavaMap::FileAppender', + 'org.apache.log4j.RollingFileAppender' => + 'Log::Log4perl::JavaMap::RollingFileAppender', + 'org.apache.log4j.TestBuffer' => + 'Log::Log4perl::JavaMap::TestBuffer', + 'org.apache.log4j.jdbc.JDBCAppender' => + 'Log::Log4perl::JavaMap::JDBCAppender', + 'org.apache.log4j.SyslogAppender' => + 'Log::Log4perl::JavaMap::SyslogAppender', + 'org.apache.log4j.NTEventLogAppender' => + 'Log::Log4perl::JavaMap::NTEventLogAppender', +); + +our %user_defined; + +sub get { + my ($appender_name, $appender_data) = @_; + + print "Trying to map $appender_name\n" if _INTERNAL_DEBUG; + + $appender_data->{value} || + die "ERROR: you didn't tell me how to implement your appender " . + "'$appender_name'"; + + my $perl_class = $translate{$appender_data->{value}} || + $user_defined{$appender_data->{value}} || + die "ERROR: I don't know how to make a '$appender_data->{value}' " . + "to implement your appender '$appender_name', that's not a " . + "supported class\n"; + eval { + eval "require $perl_class"; #see 'perldoc -f require' for why two evals + die $@ if $@; + }; + $@ and die "ERROR: trying to set appender for $appender_name to " . + "$appender_data->{value} using $perl_class failed\n$@ \n"; + + my $app = $perl_class->new($appender_name, $appender_data); + return $app; +} + +#an external api to the two hashes +sub translate { + my $java_class = shift; + + return $translate{$java_class} || + $user_defined{$java_class}; +} + +1; + + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::JavaMap - maps java log4j appenders to Log::Dispatch classes + +=head1 SYNOPSIS + + ############################### + log4j.appender.FileAppndr1 = org.apache.log4j.FileAppender + log4j.appender.FileAppndr1.File = /var/log/onetime.log + log4j.appender.FileAppndr1.Append = false + + log4j.appender.FileAppndr1.layout = org.apache.log4j.PatternLayout + log4j.appender.FileAppndr1.layout.ConversionPattern=%d %4r [%t] %-5p %c %x - %m%n + ############################### + + +=head1 DESCRIPTION + +If somebody wants to create an appender called C<org.apache.log4j.ConsoleAppender>, +we want to translate it to Log::Dispatch::Screen, and then translate +the log4j options into Log::Dispatch parameters.. + +=head2 What's Implemented + +(Note that you can always use the Log::Dispatch::* module. By 'implemented' +I mean having a translation class that translates log4j options into +the Log::Dispatch options so you can use log4j rather than log4perl +syntax in your config file.) + +Here's the list of appenders I see on the current (6/2002) log4j site. + +These are implemented + + ConsoleAppender - Log::Dispatch::Screen + FileAppender - Log::Dispatch::File + RollingFileAppender - Log::Dispatch::FileRotate (by Mark Pfeiffer) + JDBCAppender - Log::Log4perl::Appender::DBI + SyslogAppender - Log::Dispatch::Syslog + NTEventLogAppender - Log::Dispatch::Win32EventLog + + +These should/will/might be implemented + + DailyRollingFileAppender - + SMTPAppender - Log::Dispatch::Email::MailSender + + +These might be implemented but they don't have corresponding classes +in Log::Dispatch (yet): + + NullAppender + TelnetAppender + +These might be simulated + + LF5Appender - use Tk? + ExternallyRolledFileAppender - catch a HUP instead? + +These will probably not be implemented + + AsyncAppender + JMSAppender + SocketAppender - (ships a serialized LoggingEvent to the server side) + SocketHubAppender + +=head1 ROLL YOUR OWN + +Let's say you've in a mixed Java/Perl environment and you've +come up with some custom Java appender with behavior you want to +use in both worlds, C<myorg.customAppender>. You write a +Perl appender with the same behavior C<Myorg::CustomAppender>. You +want to use one config file across both applications, so the +config file will have to say 'myorg.customAppender'. But +the mapping from C<myorg.customAppender> to C<Myorg::CustomAppender> +isn't in this JavaMap class, so what do you do? + +In your Perl code, before you call Log::Log4perl::init(), do this: + + $Log::Log4perl::JavaMap::user_defined{'myorg.customAppender'} = + 'Myorg::CustomAppender'; + +and you can use 'myorg.customAppender' in your config file with +impunity. + +=head1 SEE ALSO + +http://jakarta.apache.org/log4j/docs/ + +=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. + diff --git a/lib/Log/Log4perl/JavaMap/ConsoleAppender.pm b/lib/Log/Log4perl/JavaMap/ConsoleAppender.pm new file mode 100644 index 0000000..4b43378 --- /dev/null +++ b/lib/Log/Log4perl/JavaMap/ConsoleAppender.pm @@ -0,0 +1,95 @@ +package Log::Log4perl::JavaMap::ConsoleAppender; + +use Carp; +use strict; +use Log::Dispatch::Screen; + + +sub new { + my ($class, $appender_name, $data) = @_; + my $stderr; + + if (my $t = $data->{Target}{value}) { + if ($t eq 'System.out') { + $stderr = 0; + }elsif ($t eq 'System.err') { + $stderr = 1; + }else{ + die "ERROR: illegal value '$t' for $data->{value}.Target' in appender $appender_name\n"; + } + }elsif (defined $data->{stderr}{value}){ + $stderr = $data->{stderr}{value}; + }else{ + $stderr = 0; + } + + return Log::Log4perl::Appender->new("Log::Dispatch::Screen", + name => $appender_name, + stderr => $stderr ); +} + + +1; + + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::JavaMap::ConsoleAppender - wraps Log::Dispatch::Screen + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + +Possible config properties for log4j ConsoleAppender are + + Target (System.out, System.err, default is System.out) + +Possible config properties for Log::Dispatch::Screen are + + stderr (0 or 1) + +=head1 SEE ALSO + +http://jakarta.apache.org/log4j/docs/ + +Log::Log4perl::Javamap + +Log::Dispatch::Screen + +=cut + +=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. + diff --git a/lib/Log/Log4perl/JavaMap/FileAppender.pm b/lib/Log/Log4perl/JavaMap/FileAppender.pm new file mode 100644 index 0000000..39f6750 --- /dev/null +++ b/lib/Log/Log4perl/JavaMap/FileAppender.pm @@ -0,0 +1,117 @@ +package Log::Log4perl::JavaMap::FileAppender; + +use Carp; +use strict; +use Log::Dispatch::File; + + +sub new { + my ($class, $appender_name, $data) = @_; + my $stderr; + + my $filename = $data->{File}{value} || + $data->{filename}{value} || + die "'File' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; + + my $mode; + if (defined($data->{Append}{value})){ + if (lc $data->{Append}{value} eq 'true' || $data->{Append}{value} == 1){ + $mode = 'append'; + }elsif (lc $data->{Append}{value} eq 'false' || $data->{Append}{value} == 0) { + $mode = 'write'; + }elsif($data->{Append} =~ /^(write|append)$/){ + $mode = $data->{Append} + }else{ + die "'$data->{Append}' is not a legal value for Append for appender '$appender_name', '$data->{value}'\n"; + } + }else{ + $mode = 'append'; + } + + my $autoflush; + if (defined($data->{BufferedIO}{value})){ + if (lc $data->{BufferedIO}{value} eq 'true' || $data->{BufferedIO}{value}){ + $autoflush = 1; + }elsif (lc $data->{BufferedIO}{value} eq 'true' || ! $data->{BufferedIO}{value}) { + $autoflush = 0; + }else{ + die "'$data->{BufferedIO}' is not a legal value for BufferedIO for appender '$appender_name', '$data->{value}'\n"; + } + }else{ + $autoflush = 1; + } + + + return Log::Log4perl::Appender->new("Log::Dispatch::File", + name => $appender_name, + filename => $filename, + mode => $mode, + autoflush => $autoflush, + ); +} + +1; + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::JavaMap::FileAppender - wraps Log::Dispatch::File + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + +Possible config properties for log4j ConsoleAppender are + + File + Append "true|false|1|0" default=true + BufferedIO "true|false|1|0" default=false (i.e. autoflush is on) + +Possible config properties for Log::Dispatch::File are + + filename + mode "write|append" + autoflush 0|1 + +=head1 SEE ALSO + +http://jakarta.apache.org/log4j/docs/ + +Log::Log4perl::Javamap + +Log::Dispatch::File + +=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. + diff --git a/lib/Log/Log4perl/JavaMap/JDBCAppender.pm b/lib/Log/Log4perl/JavaMap/JDBCAppender.pm new file mode 100644 index 0000000..4b35812 --- /dev/null +++ b/lib/Log/Log4perl/JavaMap/JDBCAppender.pm @@ -0,0 +1,133 @@ +package Log::Log4perl::JavaMap::JDBCAppender; + +use Carp; +use strict; + +sub new { + my ($class, $appender_name, $data) = @_; + my $stderr; + + my $pwd = $data->{password}{value} || + die "'password' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; + + my $username = $data->{user}{value} || + $data->{username}{value} || + die "'user' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; + + + my $sql = $data->{sql}{value} || + die "'sql' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; + + + my $dsn; + + my $databaseURL = $data->{URL}{value}; + if ($databaseURL) { + $databaseURL =~ m|^jdbc:(.+?):(.+?)://(.+?):(.+?);(.+)|; + my $driverName = $1; + my $databaseName = $2; + my $hostname = $3; + my $port = $4; + my $params = $5; + $dsn = "dbi:$driverName:database=$databaseName;host=$hostname;port=$port;$params"; + }elsif ($data->{datasource}{value}){ + $dsn = $data->{datasource}{value}; + }else{ + die "'databaseURL' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; + } + + + #this part isn't supported by log4j, it's my Log4perl + #hack, but I think it's so useful I'm going to implement it + #anyway + my %bind_value_params; + foreach my $p (keys %{$data->{params}}){ + $bind_value_params{$p} = $data->{params}{$p}{value}; + } + + return Log::Log4perl::Appender->new("Log::Log4perl::Appender::DBI", + datasource => $dsn, + username => $username, + password => $pwd, + sql => $sql, + params => \%bind_value_params, + #warp_message also not a log4j thing, but see above + warp_message=> $data->{warp_message}{value}, + ); +} + +1; + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::JavaMap::JDBCAppender - wraps Log::Log4perl::Appender::DBI + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + +Possible config properties for log4j JDBCAppender are + + bufferSize + sql + password + user + URL - attempting to translate a JDBC URL into DBI parameters, + let me know if you find problems + +Possible config properties for Log::Log4perl::Appender::DBI are + + bufferSize + sql + password + username + datasource + + usePreparedStmt 0|1 + + (patternLayout).dontCollapseArrayRefs 0|1 + + +=head1 SEE ALSO + +http://jakarta.apache.org/log4j/docs/ + +Log::Log4perl::Javamap + +Log::Log4perl::Appender::DBI + +=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. + diff --git a/lib/Log/Log4perl/JavaMap/NTEventLogAppender.pm b/lib/Log/Log4perl/JavaMap/NTEventLogAppender.pm new file mode 100755 index 0000000..845d898 --- /dev/null +++ b/lib/Log/Log4perl/JavaMap/NTEventLogAppender.pm @@ -0,0 +1,91 @@ +package Log::Log4perl::JavaMap::NTEventLogAppender; + +use Carp; +use strict; + + + +sub new { + my ($class, $appender_name, $data) = @_; + my $stderr; + + my ($source, # + ); + + if (defined $data->{Source}{value}) { + $source = $data->{Source}{value} + }elsif (defined $data->{source}{value}){ + $source = $data->{source}{value}; + }else{ + $source = 'user'; + } + + + return Log::Log4perl::Appender->new("Log::Dispatch::Win32EventLog", + name => $appender_name, + source => $source, + min_level => 'debug', + ); +} + +1; + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::JavaMap::NTEventLogAppender - wraps Log::Dispatch::Win32EventLog + + +=head1 DESCRIPTION + +This maps log4j's NTEventLogAppender to Log::Dispatch::Win32EventLog + +Possible config properties for log4j NTEventLogAppender are + + Source + +Possible config properties for Log::Dispatch::Win32EventLog are + + source + +Boy, that was hard. + +=head1 SEE ALSO + +http://jakarta.apache.org/log4j/docs/ + +Log::Log4perl::Javamap + +=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. + diff --git a/lib/Log/Log4perl/JavaMap/RollingFileAppender.pm b/lib/Log/Log4perl/JavaMap/RollingFileAppender.pm new file mode 100644 index 0000000..7157e46 --- /dev/null +++ b/lib/Log/Log4perl/JavaMap/RollingFileAppender.pm @@ -0,0 +1,143 @@ +package Log::Log4perl::JavaMap::RollingFileAppender; + +use Carp; +use strict; +use Log::Dispatch::FileRotate 1.10; + + +sub new { + my ($class, $appender_name, $data) = @_; + my $stderr; + + my $filename = $data->{File}{value} || + $data->{filename}{value} || + die "'File' not supplied for appender '$appender_name', required for a '$data->{value}'\n"; + + my $mode; + if (defined($data->{Append}{value})){ + if (lc $data->{Append}{value} eq 'true' || $data->{Append}{value} == 1){ + $mode = 'append'; + }elsif (lc $data->{Append}{value} eq 'false' || $data->{Append}{value} == 0) { + $mode = 'write'; + }elsif($data->{Append} =~ /^(write|append)$/){ + $mode = $data->{Append} + }else{ + die "'$data->{Append}' is not a legal value for Append for appender '$appender_name', '$data->{value}'\n"; + } + }else{ + $mode = 'append'; + } + + my $autoflush; + if (defined($data->{BufferedIO}{value})){ + if (lc $data->{BufferedIO}{value} eq 'true' || $data->{BufferedIO}{value}){ + $autoflush = 1; + }elsif (lc $data->{BufferedIO}{value} eq 'true' || ! $data->{BufferedIO}{value}) { + $autoflush = 0; + }else{ + die "'$data->{BufferedIO}' is not a legal value for BufferedIO for appender '$appender_name', '$data->{value}'\n"; + } + }else{ + $autoflush = 1; + } + + my $max; + if (defined $data->{MaxBackupIndex}{value}) { + $max = $data->{MaxBackupIndex}{value}; + }elsif (defined $data->{max}{value}){ + $max = $data->{max}{value}; + }else{ + $max = 1; + + } + + my $size; + if (defined $data->{MaxFileSize}{value}) { + $size = $data->{MaxFileSize}{value} + }elsif (defined $data->{size}{value}){ + $size = $data->{size}{value}; + }else{ + $size = 10_000_000; + } + + + return Log::Log4perl::Appender->new("Log::Dispatch::FileRotate", + name => $appender_name, + filename => $filename, + mode => $mode, + autoflush => $autoflush, + size => $size, + max => $max, + ); +} + +1; + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::JavaMap::RollingFileAppender - wraps Log::Dispatch::FileRotate + +=head1 SYNOPSIS + + +=head1 DESCRIPTION + +This maps log4j's RollingFileAppender to Log::Dispatch::FileRotate +by Mark Pfeiffer, <markpf@mlp-consulting.com.au>. + +Possible config properties for log4j ConsoleAppender are + + File + Append "true|false|1|0" default=true + BufferedIO "true|false|1|0" default=false (i.e. autoflush is on) + MaxFileSize default 10_000_000 + MaxBackupIndex default is 1 + +Possible config properties for Log::Dispatch::FileRotate are + + filename + mode "write|append" + autoflush 0|1 + size + max + +=head1 SEE ALSO + +http://jakarta.apache.org/log4j/docs/ + +Log::Log4perl::Javamap + +=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. + diff --git a/lib/Log/Log4perl/JavaMap/SyslogAppender.pm b/lib/Log/Log4perl/JavaMap/SyslogAppender.pm new file mode 100755 index 0000000..2794bd2 --- /dev/null +++ b/lib/Log/Log4perl/JavaMap/SyslogAppender.pm @@ -0,0 +1,109 @@ +package Log::Log4perl::JavaMap::SyslogAppender; + +use Carp; +use strict; +use Log::Dispatch::Syslog; + + +sub new { + my ($class, $appender_name, $data) = @_; + my $stderr; + + my ($ident, #defaults to $0 + $logopt, #Valid options are 'cons', 'pid', 'ndelay', and 'nowait'. + $facility, #Valid options are 'auth', 'authpriv', + # 'cron', 'daemon', 'kern', 'local0' through 'local7', + # 'mail, 'news', 'syslog', 'user', 'uucp'. Defaults to + # 'user' + $socket, #Valid options are 'unix' or 'inet'. Defaults to 'inet' + ); + + if (defined $data->{Facility}{value}) { + $facility = $data->{Facility}{value} + }elsif (defined $data->{facility}{value}){ + $facility = $data->{facility}{value}; + }else{ + $facility = 'user'; + } + + if (defined $data->{Ident}{value}) { + $ident = $data->{Ident}{value} + }elsif (defined $data->{ident}{value}){ + $ident = $data->{ident}{value}; + }else{ + $ident = $0; + } + + return Log::Log4perl::Appender->new("Log::Dispatch::Syslog", + name => $appender_name, + facility => $facility, + ident => $ident, + min_level => 'debug', + ); +} + +1; + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::JavaMap::SysLogAppender - wraps Log::Dispatch::Syslog + + +=head1 DESCRIPTION + +This maps log4j's SyslogAppender to Log::Dispatch::Syslog + +Possible config properties for log4j SyslogAppender are + + SyslogHost (Log::Dispatch::Syslog only accepts 'localhost') + Facility + +Possible config properties for Log::Dispatch::Syslog are + + min_level (debug) + max_level + ident (defaults to $0) + logopt + facility + socket (defaults to 'inet') + +=head1 SEE ALSO + +http://jakarta.apache.org/log4j/docs/ + +Log::Log4perl::Javamap + +=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. + diff --git a/lib/Log/Log4perl/JavaMap/TestBuffer.pm b/lib/Log/Log4perl/JavaMap/TestBuffer.pm new file mode 100644 index 0000000..5a33f7d --- /dev/null +++ b/lib/Log/Log4perl/JavaMap/TestBuffer.pm @@ -0,0 +1,70 @@ +package Log::Log4perl::JavaMap::TestBuffer; + +use Carp; +use strict; +use Log::Log4perl::Appender::TestBuffer; + +use constant _INTERNAL_DEBUG => 0; + +sub new { + my ($class, $appender_name, $data) = @_; + my $stderr; + + return Log::Log4perl::Appender->new("Log::Log4perl::Appender::TestBuffer", + name => $appender_name); +} + +1; + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::JavaMap::TestBuffer - wraps Log::Log4perl::Appender::TestBuffer + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +Just for testing the Java mapping. + +=head1 SEE ALSO + +http://jakarta.apache.org/log4j/docs/ + +Log::Log4perl::Javamap + +Log::Dispatch::Screen + +=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. + diff --git a/lib/Log/Log4perl/Layout.pm b/lib/Log/Log4perl/Layout.pm new file mode 100644 index 0000000..bcb5f38 --- /dev/null +++ b/lib/Log/Log4perl/Layout.pm @@ -0,0 +1,92 @@ +package Log::Log4perl::Layout; + + +use Log::Log4perl::Layout::SimpleLayout; +use Log::Log4perl::Layout::PatternLayout; +use Log::Log4perl::Layout::PatternLayout::Multiline; + + +#################################################### +sub appender_name { +#################################################### + my ($self, $arg) = @_; + + if ($arg) { + die "setting appender_name unimplemented until it makes sense"; + } + return $self->{appender_name}; +} + + +################################################## +sub define { +################################################## + ; #subclasses may implement +} + + +################################################## +sub render { +################################################## + die "subclass must implement render"; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Layout - Log4perl Layout Virtual Base Class + +=head1 SYNOPSIS + + # Not to be used directly, see below + +=head1 DESCRIPTION + +C<Log::Log4perl::Layout> is a virtual base class for the two currently +implemented layout types + + Log::Log4perl::Layout::SimpleLayout + Log::Log4perl::Layout::PatternLayout + +Unless you're implementing a new layout class for Log4perl, you shouldn't +use this class directly, but rather refer to +L<Log::Log4perl::Layout::SimpleLayout> or +L<Log::Log4perl::Layout::PatternLayout>. + +=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. + diff --git a/lib/Log/Log4perl/Layout/NoopLayout.pm b/lib/Log/Log4perl/Layout/NoopLayout.pm new file mode 100644 index 0000000..185d8ca --- /dev/null +++ b/lib/Log/Log4perl/Layout/NoopLayout.pm @@ -0,0 +1,81 @@ +################################################## +package Log::Log4perl::Layout::NoopLayout; +################################################## + + +################################################## +sub new { +################################################## + my $class = shift; + $class = ref ($class) || $class; + + my $self = { + format => undef, + info_needed => {}, + stack => [], + }; + + bless $self, $class; + + return $self; +} + +################################################## +sub render { +################################################## + #my($self, $message, $category, $priority, $caller_level) = @_; + return $_[1];; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Layout::NoopLayout - Pass-thru Layout + +=head1 SYNOPSIS + + use Log::Log4perl::Layout::NoopLayout; + my $layout = Log::Log4perl::Layout::NoopLayout->new(); + +=head1 DESCRIPTION + +This is a no-op layout, returns the logging message unaltered, +useful for implementing the DBI logger. + +=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. + diff --git a/lib/Log/Log4perl/Layout/PatternLayout.pm b/lib/Log/Log4perl/Layout/PatternLayout.pm new file mode 100644 index 0000000..94854db --- /dev/null +++ b/lib/Log/Log4perl/Layout/PatternLayout.pm @@ -0,0 +1,888 @@ +################################################## +package Log::Log4perl::Layout::PatternLayout; +################################################## + +use 5.006; +use strict; +use warnings; + +use constant _INTERNAL_DEBUG => 0; + +use Carp; +use Log::Log4perl::Util; +use Log::Log4perl::Level; +use Log::Log4perl::DateFormat; +use Log::Log4perl::NDC; +use Log::Log4perl::MDC; +use Log::Log4perl::Util::TimeTracker; +use File::Spec; +use File::Basename; + +our $TIME_HIRES_AVAILABLE_WARNED = 0; +our $HOSTNAME; +our %GLOBAL_USER_DEFINED_CSPECS = (); + +our $CSPECS = 'cCdFHIlLmMnpPrRtTxX%'; + +BEGIN { + # Check if we've got Sys::Hostname. If not, just punt. + $HOSTNAME = "unknown.host"; + if(Log::Log4perl::Util::module_available("Sys::Hostname")) { + require Sys::Hostname; + $HOSTNAME = Sys::Hostname::hostname(); + } +} + +use base qw(Log::Log4perl::Layout); + +no strict qw(refs); + +################################################## +sub new { +################################################## + my $class = shift; + $class = ref ($class) || $class; + + my $options = ref $_[0] eq "HASH" ? shift : {}; + my $layout_string = @_ ? shift : '%m%n'; + + my $self = { + format => undef, + info_needed => {}, + stack => [], + CSPECS => $CSPECS, + dontCollapseArrayRefs => $options->{dontCollapseArrayRefs}{value}, + last_time => undef, + undef_column_value => + (exists $options->{ undef_column_value } + ? $options->{ undef_column_value } + : "[undef]"), + }; + + $self->{timer} = Log::Log4perl::Util::TimeTracker->new( + time_function => $options->{time_function} + ); + + if(exists $options->{ConversionPattern}->{value}) { + $layout_string = $options->{ConversionPattern}->{value}; + } + + if(exists $options->{message_chomp_before_newline}) { + $self->{message_chomp_before_newline} = + $options->{message_chomp_before_newline}->{value}; + } else { + $self->{message_chomp_before_newline} = 1; + } + + bless $self, $class; + + #add the global user-defined cspecs + foreach my $f (keys %GLOBAL_USER_DEFINED_CSPECS){ + #add it to the list of letters + $self->{CSPECS} .= $f; + #for globals, the coderef is already evaled, + $self->{USER_DEFINED_CSPECS}{$f} = $GLOBAL_USER_DEFINED_CSPECS{$f}; + } + + #add the user-defined cspecs local to this appender + foreach my $f (keys %{$options->{cspec}}){ + $self->add_layout_cspec($f, $options->{cspec}{$f}{value}); + } + + # non-portable line breaks + $layout_string =~ s/\\n/\n/g; + $layout_string =~ s/\\r/\r/g; + + $self->define($layout_string); + + return $self; +} + +################################################## +sub define { +################################################## + my($self, $format) = @_; + + # If the message contains a %m followed by a newline, + # make a note of that so that we can cut a superfluous + # \n off the message later on + if($self->{message_chomp_before_newline} and $format =~ /%m%n/) { + $self->{message_chompable} = 1; + } else { + $self->{message_chompable} = 0; + } + + # Parse the format + $format =~ s/%(-?\d*(?:\.\d+)?) + ([$self->{CSPECS}]) + (?:{(.*?)})*/ + rep($self, $1, $2, $3); + /gex; + + $self->{printformat} = $format; +} + +################################################## +sub rep { +################################################## + my($self, $num, $op, $curlies) = @_; + + return "%%" if $op eq "%"; + + # If it's a %d{...} construct, initialize a simple date + # format formatter, so that we can quickly render later on. + # If it's just %d, assume %d{yyyy/MM/dd HH:mm:ss} + if($op eq "d") { + if(defined $curlies) { + $curlies = Log::Log4perl::DateFormat->new($curlies); + } else { + $curlies = Log::Log4perl::DateFormat->new("yyyy/MM/dd HH:mm:ss"); + } + } elsif($op eq "m") { + $curlies = $self->curlies_csv_parse($curlies); + } + + push @{$self->{stack}}, [$op, $curlies]; + + $self->{info_needed}->{$op}++; + + return "%${num}s"; +} + +########################################### +sub curlies_csv_parse { +########################################### + my($self, $curlies) = @_; + + my $data = {}; + + if(defined $curlies and length $curlies) { + $curlies =~ s/\s//g; + + for my $field (split /,/, $curlies) { + my($key, $value) = split /=/, $field; + $data->{$key} = $value; + } + } + + return $data; +} + +################################################## +sub render { +################################################## + my($self, $message, $category, $priority, $caller_level) = @_; + + $caller_level = 0 unless defined $caller_level; + + my %info = (); + + $info{m} = $message; + # See 'define' + chomp $info{m} if $self->{message_chompable}; + + my @results = (); + + my $caller_offset = Log::Log4perl::caller_depth_offset( $caller_level ); + + if($self->{info_needed}->{L} or + $self->{info_needed}->{F} or + $self->{info_needed}->{C} or + $self->{info_needed}->{l} or + $self->{info_needed}->{M} or + $self->{info_needed}->{T} or + 0 + ) { + + my ($package, $filename, $line, + $subroutine, $hasargs, + $wantarray, $evaltext, $is_require, + $hints, $bitmask) = caller($caller_offset); + + # If caller() choked because of a whacko caller level, + # correct undefined values to '[undef]' in order to prevent + # warning messages when interpolating later + unless(defined $bitmask) { + for($package, + $filename, $line, + $subroutine, $hasargs, + $wantarray, $evaltext, $is_require, + $hints, $bitmask) { + $_ = '[undef]' unless defined $_; + } + } + + $info{L} = $line; + $info{F} = $filename; + $info{C} = $package; + + if($self->{info_needed}->{M} or + $self->{info_needed}->{l} or + 0) { + # To obtain the name of the subroutine which triggered the + # logger, we need to go one additional level up. + my $levels_up = 1; + { + my @callinfo = caller($caller_offset+$levels_up); + + if(_INTERNAL_DEBUG) { + callinfo_dump( $caller_offset, \@callinfo ); + } + + $subroutine = $callinfo[3]; + # If we're inside an eval, go up one level further. + if(defined $subroutine and + $subroutine eq "(eval)") { + print "Inside an eval, one up\n" if _INTERNAL_DEBUG; + $levels_up++; + redo; + } + } + $subroutine = "main::" unless $subroutine; + print "Subroutine is '$subroutine'\n" if _INTERNAL_DEBUG; + $info{M} = $subroutine; + $info{l} = "$subroutine $filename ($line)"; + } + } + + $info{X} = "[No curlies defined]"; + $info{x} = Log::Log4perl::NDC->get() if $self->{info_needed}->{x}; + $info{c} = $category; + $info{d} = 1; # Dummy value, corrected later + $info{n} = "\n"; + $info{p} = $priority; + $info{P} = $$; + $info{H} = $HOSTNAME; + + my $current_time; + + if($self->{info_needed}->{r} or $self->{info_needed}->{R}) { + if(!$TIME_HIRES_AVAILABLE_WARNED++ and + !$self->{timer}->hires_available()) { + warn "Requested %r/%R pattern without installed Time::HiRes\n"; + } + $current_time = [$self->{timer}->gettimeofday()]; + } + + if($self->{info_needed}->{r}) { + $info{r} = $self->{timer}->milliseconds( $current_time ); + } + if($self->{info_needed}->{R}) { + $info{R} = $self->{timer}->delta_milliseconds( $current_time ); + } + + # Stack trace wanted? + if($self->{info_needed}->{T}) { + local $Carp::CarpLevel = + $Carp::CarpLevel + $caller_offset; + my $mess = Carp::longmess(); + chomp($mess); + # $mess =~ s/(?:\A\s*at.*\n|^\s*Log::Log4perl.*\n|^\s*)//mg; + $mess =~ s/(?:\A\s*at.*\n|^\s*)//mg; + $mess =~ s/\n/, /g; + $info{T} = $mess; + } + + # As long as they're not implemented yet .. + $info{t} = "N/A"; + + # Iterate over all info fields on the stack + for my $e (@{$self->{stack}}) { + my($op, $curlies) = @$e; + + my $result; + + if(exists $self->{USER_DEFINED_CSPECS}->{$op}) { + next unless $self->{info_needed}->{$op}; + $self->{curlies} = $curlies; + $result = $self->{USER_DEFINED_CSPECS}->{$op}->($self, + $message, $category, $priority, + $caller_offset+1); + } elsif(exists $info{$op}) { + $result = $info{$op}; + if($curlies) { + $result = $self->curly_action($op, $curlies, $info{$op}, + $self->{printformat}, \@results); + } else { + # just for %d + if($op eq 'd') { + $result = $info{$op}->format($self->{timer}->gettimeofday()); + } + } + } else { + warn "Format %'$op' not implemented (yet)"; + $result = "FORMAT-ERROR"; + } + + $result = $self->{undef_column_value} unless defined $result; + push @results, $result; + } + + # dbi appender needs that + if( scalar @results == 1 and + !defined $results[0] ) { + return undef; + } + + return (sprintf $self->{printformat}, @results); +} + +################################################## +sub curly_action { +################################################## + my($self, $ops, $curlies, $data, $printformat, $results) = @_; + + if($ops eq "c") { + $data = shrink_category($data, $curlies); + } elsif($ops eq "C") { + $data = shrink_category($data, $curlies); + } elsif($ops eq "X") { + $data = Log::Log4perl::MDC->get($curlies); + } elsif($ops eq "d") { + $data = $curlies->format( $self->{timer}->gettimeofday() ); + } elsif($ops eq "M") { + $data = shrink_category($data, $curlies); + } elsif($ops eq "m") { + if(exists $curlies->{chomp}) { + chomp $data; + } + if(exists $curlies->{indent}) { + if(defined $curlies->{indent}) { + # fixed indent + $data =~ s/\n/ "\n" . (" " x $curlies->{indent})/ge; + } else { + # indent on the lead-in + no warnings; # trailing array elements are undefined + my $indent = length sprintf $printformat, @$results; + $data =~ s/\n/ "\n" . (" " x $indent)/ge; + } + } + } elsif($ops eq "F") { + my @parts = File::Spec->splitdir($data); + # Limit it to max curlies entries + if(@parts > $curlies) { + splice @parts, 0, @parts - $curlies; + } + $data = File::Spec->catfile(@parts); + } elsif($ops eq "p") { + $data = substr $data, 0, $curlies; + } + + return $data; +} + +################################################## +sub shrink_category { +################################################## + my($category, $len) = @_; + + my @components = split /\.|::/, $category; + + if(@components > $len) { + splice @components, 0, @components - $len; + $category = join '.', @components; + } + + return $category; +} + +################################################## +sub add_global_cspec { +################################################## +# This is a Class method. +# Accepts a coderef or text +################################################## + + unless($Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE) { + die "\$Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE setting " . + "prohibits user defined cspecs"; + } + + my ($letter, $perlcode) = @_; + + croak "Illegal value '$letter' in call to add_global_cspec()" + unless ($letter =~ /^[a-zA-Z]$/); + + croak "Missing argument for perlcode for 'cspec.$letter' ". + "in call to add_global_cspec()" + unless $perlcode; + + croak "Please don't redefine built-in cspecs [$CSPECS]\n". + "like you do for \"cspec.$letter\"\n " + if ($CSPECS =~/$letter/); + + if (ref $perlcode eq 'CODE') { + $GLOBAL_USER_DEFINED_CSPECS{$letter} = $perlcode; + + }elsif (! ref $perlcode){ + + $GLOBAL_USER_DEFINED_CSPECS{$letter} = + Log::Log4perl::Config::compile_if_perl($perlcode); + + if ($@) { + die qq{Compilation failed for your perl code for }. + qq{"log4j.PatternLayout.cspec.$letter":\n}. + qq{This is the error message: \t$@\n}. + qq{This is the code that failed: \n$perlcode\n}; + } + + croak "eval'ing your perlcode for 'log4j.PatternLayout.cspec.$letter' ". + "doesn't return a coderef \n". + "Here is the perl code: \n\t$perlcode\n " + unless (ref $GLOBAL_USER_DEFINED_CSPECS{$letter} eq 'CODE'); + + }else{ + croak "I don't know how to handle perlcode=$perlcode ". + "for 'cspec.$letter' in call to add_global_cspec()"; + } +} + +################################################## +sub add_layout_cspec { +################################################## +# object method +# adds a cspec just for this layout +################################################## + my ($self, $letter, $perlcode) = @_; + + unless($Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE) { + die "\$Log::Log4perl::ALLOW_CODE_IN_CONFIG_FILE setting " . + "prohibits user defined cspecs"; + } + + croak "Illegal value '$letter' in call to add_layout_cspec()" + unless ($letter =~ /^[a-zA-Z]$/); + + croak "Missing argument for perlcode for 'cspec.$letter' ". + "in call to add_layout_cspec()" + unless $perlcode; + + croak "Please don't redefine built-in cspecs [$CSPECS] \n". + "like you do for 'cspec.$letter'" + if ($CSPECS =~/$letter/); + + if (ref $perlcode eq 'CODE') { + + $self->{USER_DEFINED_CSPECS}{$letter} = $perlcode; + + }elsif (! ref $perlcode){ + + $self->{USER_DEFINED_CSPECS}{$letter} = + Log::Log4perl::Config::compile_if_perl($perlcode); + + if ($@) { + die qq{Compilation failed for your perl code for }. + qq{"cspec.$letter":\n}. + qq{This is the error message: \t$@\n}. + qq{This is the code that failed: \n$perlcode\n}; + } + croak "eval'ing your perlcode for 'cspec.$letter' ". + "doesn't return a coderef \n". + "Here is the perl code: \n\t$perlcode\n " + unless (ref $self->{USER_DEFINED_CSPECS}{$letter} eq 'CODE'); + + + }else{ + croak "I don't know how to handle perlcode=$perlcode ". + "for 'cspec.$letter' in call to add_layout_cspec()"; + } + + $self->{CSPECS} .= $letter; +} + +########################################### +sub callinfo_dump { +########################################### + my($level, $info) = @_; + + my @called_by = caller(0); + + # Just for internal debugging + $called_by[1] = basename $called_by[1]; + print "caller($level) at $called_by[1]-$called_by[2] returned "; + + my @by_idx; + + # $info->[1] = basename $info->[1] if defined $info->[1]; + + my $i = 0; + for my $field (qw(package filename line subroutine hasargs + wantarray evaltext is_require hints bitmask)) { + $by_idx[$i] = $field; + $i++; + } + + $i = 0; + for my $value (@$info) { + my $field = $by_idx[ $i ]; + print "$field=", + (defined $info->[$i] ? $info->[$i] : "[undef]"), + " "; + $i++; + } + + print "\n"; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Layout::PatternLayout - Pattern Layout + +=head1 SYNOPSIS + + use Log::Log4perl::Layout::PatternLayout; + + my $layout = Log::Log4perl::Layout::PatternLayout->new( + "%d (%F:%L)> %m"); + + +=head1 DESCRIPTION + +Creates a pattern layout according to +http://jakarta.apache.org/log4j/docs/api/org/apache/log4j/PatternLayout.html +and a couple of Log::Log4perl-specific extensions. + +The C<new()> method creates a new PatternLayout, specifying its log +format. The format +string can contain a number of placeholders which will be +replaced by the logging engine when it's time to log the message: + + %c Category of the logging event. + %C Fully qualified package (or class) name of the caller + %d Current date in yyyy/MM/dd hh:mm:ss format + %d{...} Current date in customized format (see below) + %F File where the logging event occurred + %H Hostname (if Sys::Hostname is available) + %l Fully qualified name of the calling method followed by the + callers source the file name and line number between + parentheses. + %L Line number within the file where the log statement was issued + %m The message to be logged + %m{chomp} Log message, stripped off a trailing newline + %m{indent} Log message, multi-lines indented so they line up with first + %m{indent=n} Log message, multi-lines indented by n spaces + %M Method or function where the logging request was issued + %n Newline (OS-independent) + %p Priority of the logging event (%p{1} shows the first letter) + %P pid of the current process + %r Number of milliseconds elapsed from program start to logging + event + %R Number of milliseconds elapsed from last logging event to + current logging event + %T A stack trace of functions called + %x The topmost NDC (see below) + %X{key} The entry 'key' of the MDC (see below) + %% A literal percent (%) sign + +NDC and MDC are explained in L<Log::Log4perl/"Nested Diagnostic Context (NDC)"> +and L<Log::Log4perl/"Mapped Diagnostic Context (MDC)">. + +The granularity of time values is milliseconds if Time::HiRes is available. +If not, only full seconds are used. + +Every once in a while, someone uses the "%m%n" pattern and +additionally provides an extra newline in the log message (e.g. +C<-E<gt>log("message\n")>. To avoid printing an extra newline in +this case, the PatternLayout will chomp the message, printing only +one newline. This option can be controlled by PatternLayout's +C<message_chomp_before_newline> option. See L<Advanced options> +for details. + +=head2 Quantify placeholders + +All placeholders can be extended with formatting instructions, +just like in I<printf>: + + %20c Reserve 20 chars for the category, right-justify and fill + with blanks if it is shorter + %-20c Same as %20c, but left-justify and fill the right side + with blanks + %09r Zero-pad the number of milliseconds to 9 digits + %.8c Specify the maximum field with and have the formatter + cut off the rest of the value + +=head2 Fine-tuning with curlies + +Some placeholders have special functions defined if you add curlies +with content after them: + + %c{1} Just show the right-most category compontent, useful in large + class hierarchies (Foo::Baz::Bar -> Bar) + %c{2} Just show the two right most category components + (Foo::Baz::Bar -> Baz::Bar) + + %F Display source file including full path + %F{1} Just display filename + %F{2} Display filename and last path component (dir/test.log) + %F{3} Display filename and last two path components (d1/d2/test.log) + + %M Display fully qualified method/function name + %M{1} Just display method name (foo) + %M{2} Display method name and last path component (main::foo) + +In this way, you're able to shrink the displayed category or +limit file/path components to save space in your logs. + +=head2 Fine-tune the date + +If you're not happy with the default %d format for the date which +looks like + + yyyy/MM/DD HH:mm:ss + +(which is slightly different from Log4j which uses C<yyyy-MM-dd HH:mm:ss,SSS>) +you're free to fine-tune it in order to display only certain characteristics +of a date, according to the SimpleDateFormat in the Java World +(http://java.sun.com/j2se/1.3/docs/api/java/text/SimpleDateFormat.html): + + %d{HH:mm} "23:45" -- Just display hours and minutes + %d{yy, EEEE} "02, Monday" -- Just display two-digit year + and spelled-out weekday +Here's the symbols and their meaning, according to the SimpleDateFormat +specification: + + Symbol Meaning Presentation Example + ------ ------- ------------ ------- + G era designator (Text) AD + y year (Number) 1996 + M month in year (Text & Number) July & 07 + d day in month (Number) 10 + h hour in am/pm (1-12) (Number) 12 + H hour in day (0-23) (Number) 0 + m minute in hour (Number) 30 + s second in minute (Number) 55 + E day in week (Text) Tuesday + D day in year (Number) 189 + a am/pm marker (Text) PM + e epoch seconds (Number) 1315011604 + + (Text): 4 or more pattern letters--use full form, < 4--use short or + abbreviated form if one exists. + + (Number): the minimum number of digits. Shorter numbers are + zero-padded to this amount. Year is handled + specially; that is, if the count of 'y' is 2, the + Year will be truncated to 2 digits. + + (Text & Number): 3 or over, use text, otherwise use number. + +There's also a bunch of pre-defined formats: + + %d{ABSOLUTE} "HH:mm:ss,SSS" + %d{DATE} "dd MMM yyyy HH:mm:ss,SSS" + %d{ISO8601} "yyyy-MM-dd HH:mm:ss,SSS" + +=head2 Custom cspecs + +First of all, "cspecs" is short for "conversion specifiers", which is +the log4j and the printf(3) term for what Mike is calling "placeholders." +I suggested "cspecs" for this part of the api before I saw that Mike was +using "placeholders" consistently in the log4perl documentation. Ah, the +joys of collaboration ;=) --kg + +If the existing corpus of placeholders/cspecs isn't good enough for you, +you can easily roll your own: + + #'U' a global user-defined cspec + log4j.PatternLayout.cspec.U = sub { return "UID: $< "} + + #'K' cspec local to appndr1 (pid in hex) + log4j.appender.appndr1.layout.cspec.K = sub { return sprintf "%1x", $$} + + #and now you can use them + log4j.appender.appndr1.layout.ConversionPattern = %K %U %m%n + +The benefit of this approach is that you can define and use the cspecs +right next to each other in the config file. + +If you're an API kind of person, there's also this call: + + Log::Log4perl::Layout::PatternLayout:: + add_global_cspec('Z', sub {'zzzzzzzz'}); #snooze? + +When the log message is being put together, your anonymous sub +will be called with these arguments: + + ($layout, $message, $category, $priority, $caller_level); + + layout: the PatternLayout object that called it + message: the logging message (%m) + category: e.g. groceries.beverages.adult.beer.schlitz + priority: e.g. DEBUG|WARN|INFO|ERROR|FATAL + caller_level: how many levels back up the call stack you have + to go to find the caller + +Please note that the subroutines you're defining in this way are going +to be run in the C<main> namespace, so be sure to fully qualify functions +and variables if they're located in different packages. I<Also make sure +these subroutines aren't using Log4perl, otherwise Log4perl will enter +an infinite recursion.> + +With Log4perl 1.20 and better, cspecs can be written with parameters in +curly braces. Writing something like + + log4perl.appender.Screen.layout.ConversionPattern = %U{user} %U{id} %m%n + +will cause the cspec function defined for %U to be called twice, once +with the parameter 'user' and then again with the parameter 'id', +and the placeholders in the cspec string will be replaced with +the respective return values. + +The parameter value is available in the 'curlies' entry of the first +parameter passed to the subroutine (the layout object reference). +So, if you wanted to map %U{xxx} to entries in the POE session hash, +you'd write something like: + + log4perl.PatternLayout.cspec.U = sub { \ + POE::Kernel->get_active_session->get_heap()->{ $_[0]->{curlies} } } + +B<SECURITY NOTE> + +This feature means arbitrary perl code can be embedded in the config file. +In the rare case where the people who have access to your config file are +different from the people who write your code and shouldn't have execute +rights, you might want to set + + $Log::Log4perl::Config->allow_code(0); + +before you call init(). Alternatively you can supply a restricted set of +Perl opcodes that can be embedded in the config file as described in +L<Log::Log4perl/"Restricting what Opcodes can be in a Perl Hook">. + +=head2 Advanced Options + +The constructor of the C<Log::Log4perl::Layout::PatternLayout> class +takes an optional hash reference as a first argument to specify +additional options in order to (ab)use it in creative ways: + + my $layout = Log::Log4perl::Layout::PatternLayout->new( + { time_function => \&my_time_func, + }, + "%d (%F:%L)> %m"); + +Here's a list of parameters: + +=over 4 + +=item time_function + +Takes a reference to a function returning the time for the time/date +fields, either in seconds +since the epoch or as an array, carrying seconds and +microseconds, just like C<Time::HiRes::gettimeofday> does. + +=item message_chomp_before_newline + +If a layout contains the pattern "%m%n" and the message ends with a newline, +PatternLayout will chomp the message, to prevent printing two newlines. +If this is not desired, and you want two newlines in this case, +the feature can be turned off by setting the +C<message_chomp_before_newline> option to a false value: + + my $layout = Log::Log4perl::Layout::PatternLayout->new( + { message_chomp_before_newline => 0 + }, + "%d (%F:%L)> %m%n"); + +In a Log4perl configuration file, the feature can be turned off like this: + + log4perl.appender.App.layout = PatternLayout + log4perl.appender.App.layout.ConversionPattern = %d %m%n + # Yes, I want two newlines + log4perl.appender.App.layout.message_chomp_before_newline = 0 + +=back + +=head2 Getting rid of newlines + +If your code contains logging statements like + + # WRONG, don't do that! + $logger->debug("Some message\n"); + +then it's usually best to strip the newlines from these calls. As explained +in L<Log::Log4perl/Logging newlines>, logging statements should never contain +newlines, but rely on appender layouts to add necessary newlines instead. + +If changing the code is not an option, use the special PatternLayout +placeholder %m{chomp} to refer to the message excluding a trailing +newline: + + log4perl.appender.App.layout.ConversionPattern = %d %m{chomp}%n + +This will add a single newline to every message, regardless if it +complies with the Log4perl newline guidelines or not (thanks to +Tim Bunce for this idea). + +=head2 Multi Lines + +If a log message consists of several lines, like + + $logger->debug("line1\nline2\nline3"); + +then by default, they get logged like this (assuming the the layout is +set to "%d>%m%n"): + + # layout %d>%m%n + 2014/07/27 12:46:16>line1 + line2 + line3 + +If you'd rather have the messages aligned like + + # layout %d>%m{indent}%n + 2014/07/27 12:46:16>line1 + line2 + line3 + +then use the C<%m{indent}> option for the %m specifier. This option +can also take a fixed value, as in C<%m{indent=2}>, which indents +subsequent lines by two spaces: + + # layout %d>%m{indent=2}%n + 2014/07/27 12:46:16>line1 + line2 + line3 + +Note that you can still add the C<chomp> option for the C<%m> specifier +in this case (see above what it does), simply add it after a +separating comma, like in C<%m{indent=2,chomp}>. + +=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. + diff --git a/lib/Log/Log4perl/Layout/PatternLayout/Multiline.pm b/lib/Log/Log4perl/Layout/PatternLayout/Multiline.pm new file mode 100755 index 0000000..7f8ca16 --- /dev/null +++ b/lib/Log/Log4perl/Layout/PatternLayout/Multiline.pm @@ -0,0 +1,93 @@ +#!/usr/bin/perl + +package Log::Log4perl::Layout::PatternLayout::Multiline; +use base qw(Log::Log4perl::Layout::PatternLayout); + +########################################### +sub render { +########################################### + my($self, $message, $category, $priority, $caller_level) = @_; + + my @messages = split /\r?\n/, $message; + + $caller_level = 0 unless defined $caller_level; + + my $result = ''; + + for my $msg ( @messages ) { + $result .= $self->SUPER::render( + $msg, $category, $priority, $caller_level + 1 + ); + } + return $result; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + + Log::Log4perl::Layout::PatternLayout::Multiline + +=head1 SYNOPSIS + + use Log::Log4perl::Layout::PatternLayout::Multiline; + + my $layout = Log::Log4perl::Layout::PatternLayout::Multiline->new( + "%d (%F:%L)> %m"); + +=head1 DESCRIPTION + +C<Log::Log4perl::Layout::PatternLayout::Multiline> is a subclass +of Log4perl's PatternLayout and is helpful if you send multiline +messages to your appenders which appear as + + 2007/04/04 23:59:01 This is + a message with + multiple lines + +and you want them to appear as + + 2007/04/04 23:59:01 This is + 2007/04/04 23:59:01 a message with + 2007/04/04 23:59:01 multiple lines + +instead. This layout class simply splits up the incoming message into +several chunks split by line breaks and renders them with PatternLayout +just as if it had arrived in separate chunks in the first place. + +=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. + diff --git a/lib/Log/Log4perl/Layout/SimpleLayout.pm b/lib/Log/Log4perl/Layout/SimpleLayout.pm new file mode 100644 index 0000000..7393d5f --- /dev/null +++ b/lib/Log/Log4perl/Layout/SimpleLayout.pm @@ -0,0 +1,97 @@ +################################################## +package Log::Log4perl::Layout::SimpleLayout; +################################################## +# as documented in +# http://jakarta.apache.org/log4j/docs/api/org/apache/log4j/SimpleLayout.html +################################################## + +use 5.006; +use strict; +use warnings; +use Log::Log4perl::Level; + +no strict qw(refs); +use base qw(Log::Log4perl::Layout); + +################################################## +sub new { +################################################## + my $class = shift; + $class = ref ($class) || $class; + + my $self = { + format => undef, + info_needed => {}, + stack => [], + }; + + bless $self, $class; + + return $self; +} + +################################################## +sub render { +################################################## + my($self, $message, $category, $priority, $caller_level) = @_; + + return "$priority - $message\n"; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Layout::SimpleLayout - Simple Layout + +=head1 SYNOPSIS + + use Log::Log4perl::Layout::SimpleLayout; + my $layout = Log::Log4perl::Layout::SimpleLayout->new(); + +=head1 DESCRIPTION + +This class implements the C<log4j> simple layout format -- it basically +just prints the message priority and the message, that's all. +Check +http://jakarta.apache.org/log4j/docs/api/org/apache/log4j/SimpleLayout.html +for details. + +=head1 SEE ALSO + +=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. + diff --git a/lib/Log/Log4perl/Level.pm b/lib/Log/Log4perl/Level.pm new file mode 100644 index 0000000..00168ca --- /dev/null +++ b/lib/Log/Log4perl/Level.pm @@ -0,0 +1,358 @@ +###############r################################### +package Log::Log4perl::Level; +################################################## + +use 5.006; +use strict; +use warnings; +use Carp; + +# log4j, for whatever reason, puts 0 as all and MAXINT as OFF. +# this seems less optimal, as more logging would imply a higher +# level. But oh well. Probably some brokenness that has persisted. :) +use constant ALL_INT => 0; +use constant TRACE_INT => 5000; +use constant DEBUG_INT => 10000; +use constant INFO_INT => 20000; +use constant WARN_INT => 30000; +use constant ERROR_INT => 40000; +use constant FATAL_INT => 50000; +use constant OFF_INT => (2 ** 31) - 1; + +no strict qw(refs); +use vars qw(%PRIORITY %LEVELS %SYSLOG %L4P_TO_LD); + +%PRIORITY = (); # unless (%PRIORITY); +%LEVELS = () unless (%LEVELS); +%SYSLOG = () unless (%SYSLOG); +%L4P_TO_LD = () unless (%L4P_TO_LD); + +sub add_priority { + my ($prio, $intval, $syslog, $log_dispatch_level) = @_; + $prio = uc($prio); # just in case; + + $PRIORITY{$prio} = $intval; + $LEVELS{$intval} = $prio; + + # Set up the mapping between Log4perl integer levels and + # Log::Dispatch levels + # Note: Log::Dispatch uses the following levels: + # 0 debug + # 1 info + # 2 notice + # 3 warning + # 4 error + # 5 critical + # 6 alert + # 7 emergency + + # The equivalent Log::Dispatch level is optional, set it to + # the highest value (7=emerg) if it's not provided. + $log_dispatch_level = 7 unless defined $log_dispatch_level; + + $L4P_TO_LD{$prio} = $log_dispatch_level; + + $SYSLOG{$prio} = $syslog if defined($syslog); +} + +# create the basic priorities +add_priority("OFF", OFF_INT, -1, 7); +add_priority("FATAL", FATAL_INT, 0, 7); +add_priority("ERROR", ERROR_INT, 3, 4); +add_priority("WARN", WARN_INT, 4, 3); +add_priority("INFO", INFO_INT, 6, 1); +add_priority("DEBUG", DEBUG_INT, 7, 0); +add_priority("TRACE", TRACE_INT, 8, 0); +add_priority("ALL", ALL_INT, 8, 0); + +# we often sort numerically, so a helper func for readability +sub numerically {$a <=> $b} + +########################################### +sub import { +########################################### + my($class, $namespace) = @_; + + if(defined $namespace) { + # Export $OFF, $FATAL, $ERROR etc. to + # the given namespace + $namespace .= "::" unless $namespace =~ /::$/; + } else { + # Export $OFF, $FATAL, $ERROR etc. to + # the caller's namespace + $namespace = caller(0) . "::"; + } + + for my $key (keys %PRIORITY) { + my $name = "$namespace$key"; + my $value = $PRIORITY{$key}; + *{"$name"} = \$value; + my $nameint = "$namespace${key}_INT"; + my $func = uc($key) . "_INT"; + *{"$nameint"} = \&$func; + } +} + +################################################## +sub new { +################################################## + # We don't need any of this class nonsense + # in Perl, because we won't allow subclassing + # from this. We're optimizing for raw speed. +} + +################################################## +sub to_priority { +# changes a level name string to a priority numeric +################################################## + my($string) = @_; + + if(exists $PRIORITY{$string}) { + return $PRIORITY{$string}; + }else{ + croak "level '$string' is not a valid error level (".join ('|', keys %PRIORITY),')'; + } +} + +################################################## +sub to_level { +# changes a priority numeric constant to a level name string +################################################## + my ($priority) = @_; + if (exists $LEVELS{$priority}) { + return $LEVELS{$priority} + }else { + croak("priority '$priority' is not a valid error level number (", + join("|", sort numerically keys %LEVELS), " + )"); + } + +} + +################################################## +sub to_LogDispatch_string { +# translates into strings that Log::Dispatch recognizes +################################################## + my($priority) = @_; + + confess "do what? no priority?" unless defined $priority; + + my $string; + + if(exists $LEVELS{$priority}) { + $string = $LEVELS{$priority}; + } + + # Log::Dispatch idiosyncrasies + if($priority == $PRIORITY{WARN}) { + $string = "WARNING"; + } + + if($priority == $PRIORITY{FATAL}) { + $string = "EMERGENCY"; + } + + return $string; +} + +################################################### +sub is_valid { +################################################### + my $q = shift; + + if ($q =~ /[A-Z]/) { + return exists $PRIORITY{$q}; + }else{ + return $LEVELS{$q}; + } + +} + +sub get_higher_level { + my ($old_priority, $delta) = @_; + + $delta ||= 1; + + my $new_priority = 0; + + foreach (1..$delta){ + #so the list is TRACE, DEBUG, INFO, WARN, ERROR, FATAL + # but remember, the numbers go in reverse order! + foreach my $p (sort numerically keys %LEVELS){ + if ($p > $old_priority) { + $new_priority = $p; + last; + } + } + $old_priority = $new_priority; + } + return $new_priority; +} + +sub get_lower_level { + my ($old_priority, $delta) = @_; + + $delta ||= 1; + + my $new_priority = 0; + + foreach (1..$delta){ + #so the list is FATAL, ERROR, WARN, INFO, DEBUG, TRACE + # but remember, the numbers go in reverse order! + foreach my $p (reverse sort numerically keys %LEVELS){ + if ($p < $old_priority) { + $new_priority = $p; + last; + } + } + $old_priority = $new_priority; + } + return $new_priority; +} + +sub isGreaterOrEqual { + my $lval = shift; + my $rval = shift; + + # in theory, we should check if the above really ARE valid levels. + # but we just use numeric comparison, since they aren't really classes. + + # oh, yeah, and 'cuz level ints go from 0 .. N with 0 being highest, + # these are reversed. + return $lval <= $rval; +} + +###################################################################### +# +# since the integer representation of levels is reversed from what +# we normally want, we don't want to use < and >... instead, we +# want to use this comparison function + + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Level - Predefined log levels + +=head1 SYNOPSIS + + use Log::Log4perl::Level; + print $ERROR, "\n"; + + # -- or -- + + use Log::Log4perl qw(:levels); + print $ERROR, "\n"; + +=head1 DESCRIPTION + +C<Log::Log4perl::Level> simply exports a predefined set of I<Log4perl> log +levels into the caller's name space. It is used internally by +C<Log::Log4perl>. The following scalars are defined: + + $OFF + $FATAL + $ERROR + $WARN + $INFO + $DEBUG + $TRACE + $ALL + +C<Log::Log4perl> also exports these constants into the caller's namespace +if you pull it in providing the C<:levels> tag: + + use Log::Log4perl qw(:levels); + +This is the preferred way, there's usually no need to call +C<Log::Log4perl::Level> explicitly. + +The numerical values assigned to these constants are purely virtual, +only used by Log::Log4perl internally and can change at any time, +so please don't make any assumptions. You can test for numerical equality +by directly comparing two level values, that's ok: + + if( get_logger()->level() == $DEBUG ) { + print "The logger's level is DEBUG\n"; + } + +But if you want to figure out which of two levels is more verbose, use +Log4perl's own comparator: + + if( Log::Log4perl::Level::isGreaterOrEqual( $level1, $level2 ) ) { + print Log::Log4perl::Level::to_level( $level1 ), + " is equal or more verbose than ", + Log::Log4perl::Level::to_level( $level2 ), "\n"; + } + +If the caller wants to import level constants into a different namespace, +it can be provided with the C<use> command: + + use Log::Log4perl::Level qw(MyNameSpace); + +After this C<$MyNameSpace::ERROR>, C<$MyNameSpace::INFO> etc. +will be defined accordingly. + +=head2 Numeric levels and Strings + +Level variables like $DEBUG or $WARN have numeric values that are +internal to Log4perl. Transform them to strings that can be used +in a Log4perl configuration file, use the c<to_level()> function +provided by Log::Log4perl::Level: + + use Log::Log4perl qw(:easy); + use Log::Log4perl::Level; + + # prints "DEBUG" + print Log::Log4perl::Level::to_level( $DEBUG ), "\n"; + +To perform the reverse transformation, which takes a string like +"DEBUG" and converts it into a constant like C<$DEBUG>, use the +to_priority() function: + + use Log::Log4perl qw(:easy); + use Log::Log4perl::Level; + + my $numval = Log::Log4perl::Level::to_priority( "DEBUG" ); + +after which $numval could be used where a numerical value is required: + + Log::Log4perl->easy_init( $numval ); + +=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. + diff --git a/lib/Log/Log4perl/Logger.pm b/lib/Log/Log4perl/Logger.pm new file mode 100644 index 0000000..682c689 --- /dev/null +++ b/lib/Log/Log4perl/Logger.pm @@ -0,0 +1,1165 @@ +################################################## +package Log::Log4perl::Logger; +################################################## + +use 5.006; +use strict; +use warnings; + +use Log::Log4perl; +use Log::Log4perl::Level; +use Log::Log4perl::Layout; +use Log::Log4perl::Appender; +use Log::Log4perl::Appender::String; +use Log::Log4perl::Filter; +use Carp; + +$Carp::Internal{"Log::Log4perl"}++; +$Carp::Internal{"Log::Log4perl::Logger"}++; + +use constant _INTERNAL_DEBUG => 0; + + # Initialization +our $ROOT_LOGGER; +our $LOGGERS_BY_NAME = {}; +our %APPENDER_BY_NAME = (); +our $INITIALIZED = 0; +our $NON_INIT_WARNED; +our $DIE_DEBUG = 0; +our $DIE_DEBUG_BUFFER = ""; + # Define the default appender that's used for formatting + # warn/die/croak etc. messages. +our $STRING_APP_NAME = "_l4p_warn"; +our $STRING_APP = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::String", + name => $STRING_APP_NAME); +$STRING_APP->layout(Log::Log4perl::Layout::PatternLayout->new("%m")); +our $STRING_APP_CODEREF = generate_coderef([[$STRING_APP_NAME, $STRING_APP]]); + +__PACKAGE__->reset(); + +########################################### +sub warning_render { +########################################### + my($logger, @message) = @_; + + $STRING_APP->string(""); + $STRING_APP_CODEREF->($logger, + @message, + Log::Log4perl::Level::to_level($ALL)); + return $STRING_APP->string(); +} + +################################################## +sub cleanup { +################################################## + # warn "Logger cleanup"; + + # Nuke all convenience loggers to avoid them causing cleanup to + # be delayed until global destruction. Problem is that something like + # *{"DEBUG"} = sub { $logger->debug }; + # ties up a reference to $logger until global destruction, so we + # need to clean up all :easy shortcuts, hence freeing the last + # logger references, to then rely on the garbage collector for cleaning + # up the loggers. + Log::Log4perl->easy_closure_global_cleanup(); + + # Delete all loggers + $LOGGERS_BY_NAME = {}; + + # Delete the root logger + undef $ROOT_LOGGER; + + # Delete all appenders + %APPENDER_BY_NAME = (); + + undef $INITIALIZED; +} + +################################################## +sub DESTROY { +################################################## + CORE::warn "Destroying logger $_[0] ($_[0]->{category})" + if $Log::Log4perl::CHATTY_DESTROY_METHODS; +} + +################################################## +sub reset { +################################################## + $ROOT_LOGGER = __PACKAGE__->_new("", $OFF); +# $LOGGERS_BY_NAME = {}; #leave this alone, it's used by + #reset_all_output_methods when + #the config changes + + %APPENDER_BY_NAME = (); + undef $INITIALIZED; + undef $NON_INIT_WARNED; + Log::Log4perl::Appender::reset(); + + #clear out all the existing appenders + foreach my $logger (values %$LOGGERS_BY_NAME){ + $logger->{appender_names} = []; + + #this next bit deals with an init_and_watch case where a category + #is deleted from the config file, we need to zero out the existing + #loggers so ones not in the config file not continue with their old + #behavior --kg + next if $logger eq $ROOT_LOGGER; + $logger->{level} = undef; + $logger->level(); #set it from the hierarchy + } + + # Clear all filters + Log::Log4perl::Filter::reset(); +} + +################################################## +sub _new { +################################################## + my($class, $category, $level) = @_; + + print("_new: $class/$category/", defined $level ? $level : "undef", + "\n") if _INTERNAL_DEBUG; + + die "usage: __PACKAGE__->_new(category)" unless + defined $category; + + $category =~ s/::/./g; + + # Have we created it previously? + if(exists $LOGGERS_BY_NAME->{$category}) { + print "_new: exists already\n" if _INTERNAL_DEBUG; + return $LOGGERS_BY_NAME->{$category}; + } + + my $self = { + category => $category, + num_appenders => 0, + additivity => 1, + level => $level, + layout => undef, + }; + + bless $self, $class; + + $level ||= $self->level(); + + # Save it in global structure + $LOGGERS_BY_NAME->{$category} = $self; + + $self->set_output_methods; + + print("Created logger $self ($category)\n") if _INTERNAL_DEBUG; + + return $self; +} + +################################################## +sub category { +################################################## + my ($self) = @_; + + return $self->{ category }; +} + +################################################## +sub reset_all_output_methods { +################################################## + print "reset_all_output_methods: \n" if _INTERNAL_DEBUG; + + foreach my $loggername ( keys %$LOGGERS_BY_NAME){ + $LOGGERS_BY_NAME->{$loggername}->set_output_methods; + } + $ROOT_LOGGER->set_output_methods; +} + +################################################## +sub set_output_methods { +# Here's a big performance increase. Instead of having the logger +# calculate whether to log and whom to log to every time log() is called, +# we calculate it once when the logger is created, and recalculate +# it if the config information ever changes. +# +################################################## + my ($self) = @_; + + my (@appenders, %seen); + + my ($level) = $self->level(); + + print "set_output_methods: $self->{category}/$level\n" if _INTERNAL_DEBUG; + + #collect the appenders in effect for this category + + for(my $logger = $self; $logger; $logger = parent_logger($logger)) { + + foreach my $appender_name (@{$logger->{appender_names}}){ + + #only one message per appender, (configurable) + next if $seen{$appender_name} ++ && + $Log::Log4perl::one_message_per_appender; + + push (@appenders, + [$appender_name, + $APPENDER_BY_NAME{$appender_name}, + ] + ); + } + last unless $logger->{additivity}; + } + + #make a no-op coderef for inactive levels + my $noop = generate_noop_coderef(); + + #make a coderef + my $coderef = (! @appenders ? $noop : &generate_coderef(\@appenders)); + + my %priority = %Log::Log4perl::Level::PRIORITY; #convenience and cvs + + # changed to >= from <= as level ints were reversed + foreach my $levelname (keys %priority){ + if (Log::Log4perl::Level::isGreaterOrEqual($level, + $priority{$levelname} + )) { + print " ($priority{$levelname} <= $level)\n" + if _INTERNAL_DEBUG; + $self->{$levelname} = $coderef; + $self->{"is_$levelname"} = generate_is_xxx_coderef("1"); + print "Setting is_$levelname to 1\n" if _INTERNAL_DEBUG; + }else{ + print " ($priority{$levelname} > $level)\n" if _INTERNAL_DEBUG; + $self->{$levelname} = $noop; + $self->{"is_$levelname"} = generate_is_xxx_coderef("0"); + print "Setting is_$levelname to 0\n" if _INTERNAL_DEBUG; + } + + print(" Setting [$self] $self->{category}.$levelname to ", + ($self->{$levelname} == $noop ? "NOOP" : + ("Coderef [$coderef]: " . scalar @appenders . " appenders")), + "\n") if _INTERNAL_DEBUG; + } +} + +################################################## +sub generate_coderef { +################################################## + my $appenders = shift; + + print "generate_coderef: ", scalar @$appenders, + " appenders\n" if _INTERNAL_DEBUG; + + my $watch_check_code = generate_watch_code("logger", 1); + + return sub { + my $logger = shift; + my $level = pop; + + my $message; + my $appenders_fired = 0; + + # Evaluate all parameters that need to be evaluated. Two kinds: + # + # (1) It's a hash like { filter => "filtername", + # value => "value" } + # => filtername(value) + # + # (2) It's a code ref + # => coderef() + # + + $message = [map { ref $_ eq "HASH" && + exists $_->{filter} && + ref $_->{filter} eq 'CODE' ? + $_->{filter}->($_->{value}) : + ref $_ eq "CODE" ? + $_->() : $_ + } @_]; + + print("coderef: $logger->{category}\n") if _INTERNAL_DEBUG; + + if(defined $Log::Log4perl::Config::WATCHER) { + return unless $watch_check_code->($logger, @_, $level); + } + + foreach my $a (@$appenders) { #note the closure here + my ($appender_name, $appender) = @$a; + + print(" Sending message '<$message->[0]>' ($level) " . + "to $appender_name\n") if _INTERNAL_DEBUG; + + $appender->log( + #these get passed through to Log::Dispatch + { name => $appender_name, + level => $Log::Log4perl::Level::L4P_TO_LD{ + $level}, + message => $message, + }, + #these we need + $logger->{category}, + $level, + ) and $appenders_fired++; + # Only counting it if it returns a true value. Otherwise + # the appender threshold might have suppressed it after all. + + } #end foreach appenders + + return $appenders_fired; + + }; #end coderef +} + +################################################## +sub generate_noop_coderef { +################################################## + my $watch_delay_code; + + # This might seem crazy at first, but even in a Log4perl noop, we + # need to check if the configuration changed in a init_and_watch + # situation. Why? Say, an application is running in a loop that + # constantly tries to issue debug() messages, but they're suppressed by + # the current Log4perl configuration. If debug() (which is a noop + # here) wasn't watching the configuration for changes, it would never + # catch the case where someone bumps up the log level and expects + # the application to pick it up and start logging debug() statements. + + my $watch_check_code = generate_watch_code("logger", 1); + + my $coderef; + + if(defined $Log::Log4perl::Config::WATCHER) { + $coderef = $watch_check_code; + } else { + $coderef = sub { undef }; + } + + return $coderef; +} + +################################################## +sub generate_is_xxx_coderef { +################################################## + my($return_token) = @_; + + return generate_watch_code("checker", $return_token); +} + +################################################## +sub generate_watch_code { +################################################## + my($type, $return_token) = @_; + + print "generate_watch_code:\n" if _INTERNAL_DEBUG; + + # No watcher configured, return a no-op as watch code. + if(! defined $Log::Log4perl::Config::WATCHER) { + return sub { $return_token }; + } + + my $cond = generate_watch_conditional(); + + return sub { + print "exe_watch_code:\n" if _INTERNAL_DEBUG; + + if(_INTERNAL_DEBUG) { + print "Next check: ", + "$Log::Log4perl::Config::Watch::NEXT_CHECK_TIME ", + " Now: ", time(), " Mod: ", + (stat($Log::Log4perl::Config::WATCHER->file()))[9], + "\n"; + } + + if( $cond->() ) { + my $init_permitted = 1; + + if(exists $Log::Log4perl::Config::OPTS->{ preinit_callback } ) { + print "Calling preinit_callback\n" if _INTERNAL_DEBUG; + $init_permitted = + $Log::Log4perl::Config::OPTS->{ preinit_callback }->( + Log::Log4perl::Config->watcher()->file() ); + print "Callback returned $init_permitted\n" if _INTERNAL_DEBUG; + } + + if( $init_permitted ) { + Log::Log4perl->init_and_watch(); + } else { + # It was time to reinit, but init wasn't permitted. + # Return true, so that the logger continues as if + # it wasn't time to reinit. + return 1; + } + + my $logger = shift; + my $level = pop; + + # Forward call to new configuration + if($type eq "checker") { + return $logger->$level(); + + } elsif( $type eq "logger") { + my $methodname = lc($level); + + # Bump up the caller level by three, since + # we've artificially introduced additional levels. + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 3; + + # Get a new logger for the same category (the old + # logger might be obsolete because of the re-init) + $logger = Log::Log4perl::get_logger( $logger->{category} ); + + $logger->$methodname(@_); # send the message + # to the new configuration + return undef; # Return false, so the logger finishes + # prematurely and doesn't log the same + # message again. + } else { + die "internal error: unknown type"; + } + } else { + if(_INTERNAL_DEBUG) { + print "Conditional returned false\n"; + } + return $return_token; + } + }; +} + +################################################## +sub generate_watch_conditional { +################################################## + + if(defined $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT) { + # In this mode, we just check for the variable indicating + # that the signal has been caught + return sub { + return $Log::Log4perl::Config::Watch::SIGNAL_CAUGHT; + }; + } + + return sub { + return + ( time() > $Log::Log4perl::Config::Watch::NEXT_CHECK_TIME and + $Log::Log4perl::Config::WATCHER->change_detected() ); + }; +} + +################################################## +sub parent_string { +################################################## + my($string) = @_; + + if($string eq "") { + return undef; # root doesn't have a parent. + } + + my @components = split /\./, $string; + + if(@components == 1) { + return ""; + } + + pop @components; + + return join('.', @components); +} + +################################################## +sub level { +################################################## + my($self, $level, $dont_reset_all) = @_; + + # 'Set' function + if(defined $level) { + croak "invalid level '$level'" + unless Log::Log4perl::Level::is_valid($level); + if ($level =~ /\D/){ + $level = Log::Log4perl::Level::to_priority($level); + } + $self->{level} = $level; + + &reset_all_output_methods + unless $dont_reset_all; #keep us from getting overworked + #if it's the config file calling us + + return $level; + } + + # 'Get' function + if(defined $self->{level}) { + return $self->{level}; + } + + for(my $logger = $self; $logger; $logger = parent_logger($logger)) { + + # Does the current logger have the level defined? + + if($logger->{category} eq "") { + # It's the root logger + return $ROOT_LOGGER->{level}; + } + + if(defined $LOGGERS_BY_NAME->{$logger->{category}}->{level}) { + return $LOGGERS_BY_NAME->{$logger->{category}}->{level}; + } + } + + # We should never get here because at least the root logger should + # have a level defined + die "We should never get here."; +} + +################################################## +sub parent_logger { +# Get the parent of the current logger or undef +################################################## + my($logger) = @_; + + # Is it the root logger? + if($logger->{category} eq "") { + # Root has no parent + return undef; + } + + # Go to the next defined (!) parent + my $parent_class = parent_string($logger->{category}); + + while($parent_class ne "" and + ! exists $LOGGERS_BY_NAME->{$parent_class}) { + $parent_class = parent_string($parent_class); + $logger = $LOGGERS_BY_NAME->{$parent_class}; + } + + if($parent_class eq "") { + $logger = $ROOT_LOGGER; + } else { + $logger = $LOGGERS_BY_NAME->{$parent_class}; + } + + return $logger; +} + +################################################## +sub get_root_logger { +################################################## + my($class) = @_; + return $ROOT_LOGGER; +} + +################################################## +sub additivity { +################################################## + my($self, $onoff, $no_reinit) = @_; + + if(defined $onoff) { + $self->{additivity} = $onoff; + } + + if( ! $no_reinit ) { + $self->set_output_methods(); + } + + return $self->{additivity}; +} + +################################################## +sub get_logger { +################################################## + my($class, $category) = @_; + + unless(defined $ROOT_LOGGER) { + Carp::confess "Internal error: Root Logger not initialized."; + } + + return $ROOT_LOGGER if $category eq ""; + + my $logger = $class->_new($category); + return $logger; +} + +################################################## +sub add_appender { +################################################## + my($self, $appender, $dont_reset_all) = @_; + + # We take this as an indicator that we're initialized. + $INITIALIZED = 1; + + my $appender_name = $appender->name(); + + $self->{num_appenders}++; #should this be inside the unless? + + # Add newly created appender to the end of the appender array + unless (grep{$_ eq $appender_name} @{$self->{appender_names}}){ + $self->{appender_names} = [sort @{$self->{appender_names}}, + $appender_name]; + } + + $APPENDER_BY_NAME{$appender_name} = $appender; + + reset_all_output_methods + unless $dont_reset_all; # keep us from getting overworked + # if it's the config file calling us + + # For chaining calls ... + return $appender; +} + +################################################## +sub remove_appender { +################################################## + my($self, $appender_name, $dont_reset_all, $sloppy) = @_; + + my %appender_names = map { $_ => 1 } @{$self->{appender_names}}; + + if(!exists $appender_names{$appender_name}) { + die "No such appender: $appender_name" unless $sloppy; + return undef; + } + + delete $appender_names{$appender_name}; + $self->{num_appenders}--; + $self->{appender_names} = [sort keys %appender_names]; + + &reset_all_output_methods + unless $dont_reset_all; +} + +################################################## +sub eradicate_appender { +################################################## + # If someone calls Logger->... and not Logger::... + shift if $_[0] eq __PACKAGE__; + + my($appender_name, $dont_reset_all) = @_; + + return 0 unless exists + $APPENDER_BY_NAME{$appender_name}; + + # Remove the given appender from all loggers + # and delete all references to it, causing + # its DESTROY method to be called. + foreach my $logger (values %$LOGGERS_BY_NAME){ + $logger->remove_appender($appender_name, 0, 1); + } + # Also remove it from the root logger + $ROOT_LOGGER->remove_appender($appender_name, 0, 1); + + delete $APPENDER_BY_NAME{$appender_name}; + + &reset_all_output_methods + unless $dont_reset_all; + + return 1; +} + +################################################## +sub has_appenders { +################################################## + my($self) = @_; + + return $self->{num_appenders}; +} + +################################################## +sub log { +# external api +################################################## + my ($self, $priority, @messages) = @_; + + confess("log: No priority given!") unless defined($priority); + + # Just in case of 'init_and_watch' -- see Changes 0.21 + $_[0] = $LOGGERS_BY_NAME->{$_[0]->{category}} if + defined $Log::Log4perl::Config::WATCHER; + + init_warn() unless $INITIALIZED or $NON_INIT_WARNED; + + croak "priority $priority isn't numeric" if ($priority =~ /\D/); + + my $which = Log::Log4perl::Level::to_level($priority); + + $self->{$which}->($self, @messages, + Log::Log4perl::Level::to_level($priority)); +} + +###################################################################### +# +# create_custom_level +# creates a custom level +# in theory, could be used to create the default ones +###################################################################### +sub create_custom_level { +###################################################################### + my $level = shift || die("create_custom_level: " . + "forgot to pass in a level string!"); + my $after = shift || die("create_custom_level: " . + "forgot to pass in a level after which to " . + "place the new level!"); + my $syslog_equiv = shift; # can be undef + my $log_dispatch_level = shift; # optional + + ## only let users create custom levels before initialization + + die("create_custom_level must be called before init or " . + "first get_logger() call") if ($INITIALIZED); + + my %PRIORITY = %Log::Log4perl::Level::PRIORITY; #convenience + + die("create_custom_level: no such level \"$after\"! Use one of: ", + join(", ", sort keys %PRIORITY)) unless $PRIORITY{$after}; + + # figure out new int value by AFTER + (AFTER+ 1) / 2 + + my $next_prio = Log::Log4perl::Level::get_lower_level($PRIORITY{$after}, 1); + my $cust_prio = int(($PRIORITY{$after} + $next_prio) / 2); + + die(qq{create_custom_level: Calculated level of $cust_prio already exists! + This should only happen if you've made some insane number of custom + levels (like 15 one after another) + You can usually fix this by re-arranging your code from: + create_custom_level("cust1", X); + create_custom_level("cust2", X); + create_custom_level("cust3", X); + create_custom_level("cust4", X); + create_custom_level("cust5", X); + into: + create_custom_level("cust3", X); + create_custom_level("cust5", X); + create_custom_level("cust4", 4); + create_custom_level("cust2", cust3); + create_custom_level("cust1", cust2); + }) if (${Log::Log4perl::Level::LEVELS{$cust_prio}}); + + Log::Log4perl::Level::add_priority($level, $cust_prio, $syslog_equiv, + $log_dispatch_level); + + print("Adding prio $level at $cust_prio\n") if _INTERNAL_DEBUG; + + # get $LEVEL into namespace of Log::Log4perl::Logger to + # create $logger->foo nd $logger->is_foo + my $name = "Log::Log4perl::Logger::"; + my $key = $level; + + no strict qw(refs); + # be sure to use ${Log...} as CVS adds log entries for Log + *{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}}; + + # now, stick it in the caller's namespace + $name = caller(0) . "::"; + *{"$name$key"} = \${Log::Log4perl::Level::PRIORITY{$level}}; + use strict qw(refs); + + create_log_level_methods($level); + + return 0; + +} + +######################################## +# +# if we were hackin' lisp (or scheme), we'd be returning some lambda +# expressions. But we aren't. :) So we'll just create some strings and +# eval them. +######################################## +sub create_log_level_methods { +######################################## + my $level = shift || die("create_log_level_methods: " . + "forgot to pass in a level string!"); + my $lclevel = lc($level); + my $levelint = uc($level) . "_INT"; + my $initial_cap = ucfirst($lclevel); + + no strict qw(refs); + + # This is a bit better way to create code on the fly than eval'ing strings. + # -erik + + *{__PACKAGE__ . "::$lclevel"} = sub { + if(_INTERNAL_DEBUG) { + my $level_disp = (defined $_[0]->{level} ? $_[0]->{level} + : "[undef]"); + print "$lclevel: ($_[0]->{category}/$level_disp) [@_]\n"; + } + init_warn() unless $INITIALIZED or $NON_INIT_WARNED; + $_[0]->{$level}->(@_, $level) if defined $_[0]->{$level}; + }; + + # Added these to have is_xxx functions as fast as xxx functions + # -ms + + my $islevel = "is_" . $level; + my $islclevel = "is_" . $lclevel; + + *{__PACKAGE__ . "::is_$lclevel"} = sub { + $_[0]->{$islevel}->($_[0], $islclevel); + }; + + # Add the isXxxEnabled() methods as identical to the is_xxx + # functions. - dviner + + *{__PACKAGE__ . "::is".$initial_cap."Enabled"} = + \&{__PACKAGE__ . "::is_$lclevel"}; + + use strict qw(refs); + + return 0; +} + +#now lets autogenerate the logger subs based on the defined priorities +foreach my $level (keys %Log::Log4perl::Level::PRIORITY){ + create_log_level_methods($level); +} + +################################################## +sub init_warn { +################################################## + CORE::warn "Log4perl: Seems like no initialization happened. " . + "Forgot to call init()?\n"; + # Only tell this once; + $NON_INIT_WARNED = 1; +} + +####################################################### +# call me from a sub-func to spew the sub-func's caller +####################################################### +sub callerline { + my $message = join ('', @_); + + my $caller_offset = + Log::Log4perl::caller_depth_offset( + $Log::Log4perl::caller_depth + 1 ); + + my ($pack, $file, $line) = caller($caller_offset); + + if (not chomp $message) { # no newline + $message .= " at $file line $line"; + + # Someday, we'll use Threads. Really. + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $message .= " thread $tid" if $tid; + } + } + + return ($message, "\n"); +} + +####################################################### +sub and_warn { +####################################################### + my $self = shift; + CORE::warn(callerline($self->warning_render(@_))); +} + +####################################################### +sub and_die { +####################################################### + my $self = shift; + my $arg = $_[0]; + + my($msg) = callerline($self->warning_render(@_)); + + if($DIE_DEBUG) { + $DIE_DEBUG_BUFFER = "DIE_DEBUG: $msg"; + } else { + if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) { + die("$msg\n"); + } + die $arg; + } +} + +################################################## +sub logwarn { +################################################## + my $self = shift; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + if ($self->is_warn()) { + # Since we're one caller level off now, compensate for that. + my @chomped = @_; + chomp($chomped[-1]); + $self->warn(@chomped); + } + + $self->and_warn(@_); +} + +################################################## +sub logdie { +################################################## + my $self = shift; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + if ($self->is_fatal()) { + # Since we're one caller level off now, compensate for that. + my @chomped = @_; + chomp($chomped[-1]); + $self->fatal(@chomped); + } + + $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? + $self->and_die(@_) : + exit($Log::Log4perl::LOGEXIT_CODE); +} + +################################################## +sub logexit { +################################################## + my $self = shift; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + if ($self->is_fatal()) { + # Since we're one caller level off now, compensate for that. + my @chomped = @_; + chomp($chomped[-1]); + $self->fatal(@chomped); + } + + exit $Log::Log4perl::LOGEXIT_CODE; +} + +################################################## +# clucks and carps are WARN level +sub logcluck { +################################################## + my $self = shift; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + local $Carp::CarpLevel = + $Carp::CarpLevel + 1; + + my $msg = $self->warning_render(@_); + + if ($self->is_warn()) { + my $message = Carp::longmess($msg); + foreach (split(/\n/, $message)) { + $self->warn("$_\n"); + } + } + + Carp::cluck($msg); +} + +################################################## +sub logcarp { +################################################## + my $self = shift; + + local $Carp::CarpLevel = $Carp::CarpLevel + 1; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + my $msg = $self->warning_render(@_); + + if ($self->is_warn()) { + my $message = Carp::shortmess($msg); + foreach (split(/\n/, $message)) { + $self->warn("$_\n"); + } + } + + Carp::carp($msg); +} + +################################################## +# croaks and confess are FATAL level +################################################## +sub logcroak { +################################################## + my $self = shift; + my $arg = $_[0]; + + my $msg = $self->warning_render(@_); + + local $Carp::CarpLevel = + $Carp::CarpLevel + 1; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + if ($self->is_fatal()) { + my $message = Carp::shortmess($msg); + foreach (split(/\n/, $message)) { + $self->fatal("$_\n"); + } + } + + my $croak_msg = $arg; + + if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) { + $croak_msg = $msg; + } + + $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? + Carp::croak($croak_msg) : + exit($Log::Log4perl::LOGEXIT_CODE); +} + +################################################## +sub logconfess { +################################################## + my $self = shift; + my $arg = $_[0]; + + local $Carp::CarpLevel = + $Carp::CarpLevel + 1; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + my $msg = $self->warning_render(@_); + + if ($self->is_fatal()) { + my $message = Carp::longmess($msg); + foreach (split(/\n/, $message)) { + $self->fatal("$_\n"); + } + } + + my $confess_msg = $arg; + + if( $Log::Log4perl::STRINGIFY_DIE_MESSAGE ) { + $confess_msg = $msg; + } + + $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? + confess($confess_msg) : + exit($Log::Log4perl::LOGEXIT_CODE); +} + +################################################## +# in case people prefer to use error for warning +################################################## +sub error_warn { +################################################## + my $self = shift; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + if ($self->is_error()) { + $self->error(@_); + } + + $self->and_warn(@_); +} + +################################################## +sub error_die { +################################################## + my $self = shift; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + my $msg = $self->warning_render(@_); + + if ($self->is_error()) { + $self->error($msg); + } + + $Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ? + $self->and_die($msg) : + exit($Log::Log4perl::LOGEXIT_CODE); +} + +################################################## +sub more_logging { +################################################## + my ($self) = shift; + return $self->dec_level(@_); +} + +################################################## +sub inc_level { +################################################## + my ($self, $delta) = @_; + + $delta ||= 1; + + $self->level(Log::Log4perl::Level::get_higher_level($self->level(), + $delta)); + + $self->set_output_methods; +} + +################################################## +sub less_logging { +################################################## + my ($self) = shift; + return $self->inc_level(@_); +} + +################################################## +sub dec_level { +################################################## + my ($self, $delta) = @_; + + $delta ||= 1; + + $self->level(Log::Log4perl::Level::get_lower_level($self->level(), $delta)); + + $self->set_output_methods; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Logger - Main Logger Class + +=head1 SYNOPSIS + + # It's not here + +=head1 DESCRIPTION + +While everything that makes Log4perl tick is implemented here, +please refer to L<Log::Log4perl> for documentation. + +=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. + diff --git a/lib/Log/Log4perl/MDC.pm b/lib/Log/Log4perl/MDC.pm new file mode 100644 index 0000000..ea4d63a --- /dev/null +++ b/lib/Log/Log4perl/MDC.pm @@ -0,0 +1,136 @@ +################################################## +package Log::Log4perl::MDC; +################################################## + +use 5.006; +use strict; +use warnings; + +our %MDC_HASH = (); + +########################################### +sub get { +########################################### + my($class, $key) = @_; + + if($class ne __PACKAGE__) { + # Somebody called us with Log::Log4perl::MDC::get($key) + $key = $class; + } + + if(exists $MDC_HASH{$key}) { + return $MDC_HASH{$key}; + } else { + return undef; + } +} + +########################################### +sub put { +########################################### + my($class, $key, $value) = @_; + + if($class ne __PACKAGE__) { + # Somebody called us with Log::Log4perl::MDC::put($key, $value) + $value = $key; + $key = $class; + } + + $MDC_HASH{$key} = $value; +} + +########################################### +sub remove { +########################################### + %MDC_HASH = (); + + 1; +} + +########################################### +sub get_context { +########################################### + return \%MDC_HASH; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::MDC - Mapped Diagnostic Context + +=head1 DESCRIPTION + +Log::Log4perl allows loggers to maintain global thread-specific data, +called the Nested Diagnostic Context (NDC) and +Mapped Diagnostic Context (MDC). + +The MDC is a simple thread-specific hash table, in which the application +can stuff values under certain keys and retrieve them later +via the C<"%X{key}"> placeholder in +C<Log::Log4perl::Layout::PatternLayout>s. + +=over 4 + +=item Log::Log4perl::MDC->put($key, $value); + +Store a value C<$value> under key C<$key> in the map. + +=item my $value = Log::Log4perl::MDC->get($key); + +Retrieve the content of the map under the specified key. +Typically done by C<%X{key}> in +C<Log::Log4perl::Layout::PatternLayout>. +If no value exists to the given key, C<undef> is returned. + +=item my $text = Log::Log4perl::MDC->remove(); + +Delete all entries from the map. + +=item Log::Log4perl::MDC->get_context(); + +Returns a reference to the hash table. + +=back + +Please note that all of the methods above are class methods, there's no +instances of this class. Since the thread model in perl 5.8.0 is +"no shared data unless explicitly requested" the data structures +used are just global (and therefore thread-specific). + +=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. + diff --git a/lib/Log/Log4perl/NDC.pm b/lib/Log/Log4perl/NDC.pm new file mode 100644 index 0000000..d8cf9e2 --- /dev/null +++ b/lib/Log/Log4perl/NDC.pm @@ -0,0 +1,151 @@ +################################################## +package Log::Log4perl::NDC; +################################################## + +use 5.006; +use strict; +use warnings; + +our @NDC_STACK = (); +our $MAX_SIZE = 5; + +########################################### +sub get { +########################################### + if(@NDC_STACK) { + # Return elements blank separated + return join " ", @NDC_STACK; + } else { + return "[undef]"; + } +} + +########################################### +sub pop { +########################################### + if(@NDC_STACK) { + return pop @NDC_STACK; + } else { + return undef; + } +} + +########################################### +sub push { +########################################### + my($self, $text) = @_; + + unless(defined $text) { + # Somebody called us via Log::Log4perl::NDC::push("blah") ? + $text = $self; + } + + if(@NDC_STACK >= $MAX_SIZE) { + CORE::pop(@NDC_STACK); + } + + return push @NDC_STACK, $text; +} + +########################################### +sub remove { +########################################### + @NDC_STACK = (); +} + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::NDC - Nested Diagnostic Context + +=head1 DESCRIPTION + +Log::Log4perl allows loggers to maintain global thread-specific data, +called the Nested Diagnostic Context (NDC). + +At some point, the application might decide to push a piece of +data onto the NDC stack, which other parts of the application might +want to reuse. For example, at the beginning of a web request in a server, +the application might decide to push the IP address of the client +onto the stack to provide it for other loggers down the road without +having to pass the data from function to function. + +The Log::Log4perl::Layout::PatternLayout class even provides the handy +C<%x> placeholder which is replaced by the blank-separated list +of elements currently on the stack. + +This module maintains a simple stack which you can push data on to, query +what's on top, pop it off again or delete the entire stack. + +Its purpose is to provide a thread-specific context which all +Log::Log4perl loggers can refer to without the application having to +pass around the context data between its functions. + +Since in 5.8.0 perl's threads don't share data only upon request, +global data is by definition thread-specific. + +=over 4 + +=item Log::Log4perl::NDC->push($text); + +Push an item onto the stack. If the stack grows beyond the defined +limit (C<$Log::Log4perl::NDC::MAX_SIZE>), just the topmost element +will be replated. + +This is typically done when a context is entered. + +=item Log::Log4perl::NDC->pop(); + +Discard the upmost element of the stack. This is typically done when +a context is left. + +=item my $text = Log::Log4perl::NDC->get(); + +Retrieve the content of the stack as a string of blank-separated values +without disrupting the stack structure. Typically done by C<%x>. +If the stack is empty the value C<"[undef]"> is being returned. + +=item Log::Log4perl::NDC->remove(); + +Reset the stack, remove all items. + +=back + +Please note that all of the methods above are class methods, there's no +instances of this class. + +=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. + diff --git a/lib/Log/Log4perl/Resurrector.pm b/lib/Log/Log4perl/Resurrector.pm new file mode 100644 index 0000000..0eee01a --- /dev/null +++ b/lib/Log/Log4perl/Resurrector.pm @@ -0,0 +1,214 @@ +package Log::Log4perl::Resurrector; +use warnings; +use strict; + +# [rt.cpan.org #84818] +use if $^O eq "MSWin32", "Win32"; + +use File::Temp qw(tempfile); +use File::Spec; + +use constant INTERNAL_DEBUG => 0; + +our $resurrecting = ''; + +########################################### +sub import { +########################################### + resurrector_init(); +} + +################################################## +sub resurrector_fh { +################################################## + my($file) = @_; + + local($/) = undef; + open FILE, "<$file" or die "Cannot open $file"; + my $text = <FILE>; + close FILE; + + print "Read ", length($text), " bytes from $file\n" if INTERNAL_DEBUG; + + my($tmp_fh, $tmpfile) = tempfile( UNLINK => 1 ); + print "Opened tmpfile $tmpfile\n" if INTERNAL_DEBUG; + + $text =~ s/^\s*###l4p//mg; + + print "Text=[$text]\n" if INTERNAL_DEBUG; + + print $tmp_fh $text; + seek $tmp_fh, 0, 0; + + return $tmp_fh; +} + +########################################### +sub resurrector_loader { +########################################### + my ($code, $module) = @_; + + print "resurrector_loader called with $module\n" if INTERNAL_DEBUG; + + # Avoid recursion + if($resurrecting eq $module) { + print "ignoring $module (recursion)\n" if INTERNAL_DEBUG; + return undef; + } + + local $resurrecting = $module; + + + # Skip Log4perl appenders + if($module =~ m#^Log/Log4perl/Appender#) { + print "Ignoring $module (Log4perl-internal)\n" if INTERNAL_DEBUG; + return undef; + } + + my $path = $module; + + # Skip unknown files + if(!-f $module) { + # We might have a 'use lib' statement that modified the + # INC path, search again. + $path = pm_search($module); + if(! defined $path) { + print "File $module not found\n" if INTERNAL_DEBUG; + return undef; + } + print "File $module found in $path\n" if INTERNAL_DEBUG; + } + + print "Resurrecting module $path\n" if INTERNAL_DEBUG; + + my $fh = resurrector_fh($path); + + my $abs_path = File::Spec->rel2abs( $path ); + print "Setting %INC entry of $module to $abs_path\n" if INTERNAL_DEBUG; + $INC{$module} = $abs_path; + + return $fh; +} + +########################################### +sub pm_search { +########################################### + my($pmfile) = @_; + + for(@INC) { + # Skip subrefs + next if ref($_); + my $path = File::Spec->catfile($_, $pmfile); + return $path if -f $path; + } + + return undef; +} + +########################################### +sub resurrector_init { +########################################### + unshift @INC, \&resurrector_loader; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Resurrector - Dark Magic to resurrect hidden L4p statements + +=head1 DESCRIPTION + +Loading C<use Log::Log4perl::Resurrector> causes subsequently loaded +modules to have their hidden + + ###l4p use Log::Log4perl qw(:easy); + + ###l4p DEBUG(...) + ###l4p INFO(...) + ... + +statements uncommented and therefore 'resurrected', i.e. activated. + +This allows for a module C<Foobar.pm> to be written with Log4perl +statements commented out and running at full speed in normal mode. +When loaded via + + use Foobar; + +all hidden Log4perl statements will be ignored. + +However, if a script loads the module C<Foobar> I<after> loading +C<Log::Log4perl::Resurrector>, as in + + use Log::Log4perl::Resurrector; + use Foobar; + +then C<Log::Log4perl::Resurrector> will have put a source filter in place +that will extract all hidden Log4perl statements in C<Foobar> before +C<Foobar> actually gets loaded. + +Therefore, C<Foobar> will then behave as if the + + ###l4p use Log::Log4perl qw(:easy); + + ###l4p DEBUG(...) + ###l4p INFO(...) + ... + +statements were actually written like + + use Log::Log4perl qw(:easy); + + DEBUG(...) + INFO(...) + ... + +and the module C<Foobar> will indeed be Log4perl-enabled. Whether any +activated Log4perl statement will actually trigger log +messages, is up to the Log4perl configuration, of course. + +There's a startup cost to using C<Log::Log4perl::Resurrector> (all +subsequently loaded modules are examined) but once the compilation +phase has finished, the perl program will run at full speed. + +Some of the techniques used in this module have been stolen from the +C<Acme::Incorporated> CPAN module, written by I<chromatic>. Long +live CPAN! + +=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. + diff --git a/lib/Log/Log4perl/Util.pm b/lib/Log/Log4perl/Util.pm new file mode 100644 index 0000000..8bb3040 --- /dev/null +++ b/lib/Log/Log4perl/Util.pm @@ -0,0 +1,118 @@ +package Log::Log4perl::Util; + +require Exporter; +our @EXPORT_OK = qw( params_check ); +our @ISA = qw( Exporter ); + +use File::Spec; + +########################################### +sub params_check { +########################################### + my( $hash, $required, $optional ) = @_; + + my $pkg = caller(); + my %hash_copy = %$hash; + + if( defined $required ) { + for my $p ( @$required ) { + if( !exists $hash->{ $p } or + !defined $hash->{ $p } ) { + die "$pkg: Required parameter $p missing."; + } + delete $hash_copy{ $p }; + } + } + + if( defined $optional ) { + for my $p ( @$optional ) { + delete $hash_copy{ $p }; + } + if( scalar keys %hash_copy ) { + die "$pkg: Unknown parameter: ", join( ",", keys %hash_copy ); + } + } +} + +################################################## +sub module_available { # Check if a module is available +################################################## + my($full_name) = @_; + + # Weird cases like "strict;" (including the semicolon) would + # succeed with the eval below, so check those up front. + # I can't believe Perl doesn't have a proper way to check if a + # module is available or not! + return 0 if $full_name =~ /[^\w:]/; + + local $SIG{__DIE__} = sub {}; + + eval "require $full_name"; + + if($@) { + return 0; + } + + return 1; +} + +################################################## +sub tmpfile_name { # File::Temp without the bells and whistles +################################################## + + my $name = File::Spec->catfile(File::Spec->tmpdir(), + 'l4p-tmpfile-' . + "$$-" . + int(rand(9999999))); + + # Some crazy versions of File::Spec use backslashes on Win32 + $name =~ s#\\#/#g; + return $name; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Util - Internal utility functions + +=head1 DESCRIPTION + +Only internal functions here. Don't peek. + +=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. + diff --git a/lib/Log/Log4perl/Util/Semaphore.pm b/lib/Log/Log4perl/Util/Semaphore.pm new file mode 100644 index 0000000..e88e39b --- /dev/null +++ b/lib/Log/Log4perl/Util/Semaphore.pm @@ -0,0 +1,264 @@ +#////////////////////////////////////////// +package Log::Log4perl::Util::Semaphore; +#////////////////////////////////////////// +use IPC::SysV qw(IPC_RMID IPC_CREAT IPC_EXCL SEM_UNDO IPC_NOWAIT + IPC_SET IPC_STAT SETVAL); +use IPC::Semaphore; +use POSIX qw(EEXIST); +use strict; +use warnings; +use constant INTERNAL_DEBUG => 0; + +########################################### +sub new { +########################################### + my($class, %options) = @_; + + my $self = { + key => undef, + mode => undef, + uid => undef, + gid => undef, + destroy => undef, + semop_wait => .1, + semop_retries => 1, + creator => $$, + %options, + }; + + $self->{ikey} = unpack("i", pack("A4", $self->{key})); + + # Accept usernames in the uid field as well + if(defined $self->{uid} and + $self->{uid} =~ /\D/) { + $self->{uid} = (getpwnam $self->{uid})[2]; + } + + bless $self, $class; + $self->init(); + + my @values = (); + for my $param (qw(mode uid gid)) { + push @values, $param, $self->{$param} if defined $self->{$param}; + } + $self->semset(@values) if @values; + + return $self; +} + +########################################### +sub init { +########################################### + my($self) = @_; + + print "Semaphore init '$self->{key}'/'$self->{ikey}'\n" if INTERNAL_DEBUG; + + $self->{id} = semget( $self->{ikey}, + 1, + &IPC_EXCL|&IPC_CREAT|($self->{mode}||0777), + ); + + if(! defined $self->{id} and + $! == EEXIST) { + print "Semaphore '$self->{key}' already exists\n" if INTERNAL_DEBUG; + $self->{id} = semget( $self->{ikey}, 1, 0 ) + or die "semget($self->{ikey}) failed: $!"; + } elsif($!) { + die "Cannot create semaphore $self->{key}/$self->{ikey} ($!)"; + } +} + +########################################### +sub status_as_string { +########################################### + my($self, @values) = @_; + + my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); + + my $values = join('/', $sem->getall()); + my $ncnt = $sem->getncnt(0); + my $pidlast = $sem->getpid(0); + my $zcnt = $sem->getzcnt(0); + my $id = $sem->id(); + + return <<EOT; +Semaphore Status +Key ...................................... $self->{key} +iKey ..................................... $self->{ikey} +Id ....................................... $id +Values ................................... $values +Processes waiting for counter increase ... $ncnt +Processes waiting for counter to hit 0 ... $zcnt +Last process to perform an operation ..... $pidlast +EOT +} + +########################################### +sub semsetval { +########################################### + my($self, %keyvalues) = @_; + + my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); + $sem->setval(%keyvalues); +} + +########################################### +sub semset { +########################################### + my($self, @values) = @_; + + print "Setting values for semaphore $self->{key}/$self->{ikey}\n" if + INTERNAL_DEBUG; + + my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); + $sem->set(@values); +} + +########################################### +sub semlock { +########################################### + my($self) = @_; + + my $operation = pack("s!*", + # wait until it's 0 + 0, 0, 0, + # increment by 1 + 0, 1, SEM_UNDO + ); + + print "Locking semaphore '$self->{key}'\n" if INTERNAL_DEBUG; + $self->semop($self->{id}, $operation); +} + +########################################### +sub semunlock { +########################################### + my($self) = @_; + +# my $operation = pack("s!*", +# # decrement by 1 +# 0, -1, SEM_UNDO +# ); +# + print "Unlocking semaphore '$self->{key}'\n" if INTERNAL_DEBUG; + +# # ignore errors, as they might result from trying to unlock an +# # already unlocked semaphore. +# semop($self->{id}, $operation); + + semctl $self->{id}, 0, SETVAL, 0; +} + +########################################### +sub remove { +########################################### + my($self) = @_; + + print "Removing semaphore '$self->{key}'\n" if INTERNAL_DEBUG; + + semctl ($self->{id}, 0, &IPC_RMID, 0) or + die "Removing semaphore $self->{key} failed: $!"; +} + +########################################### +sub DESTROY { +########################################### + my($self) = @_; + + if($self->{destroy} && $$==$self->{creator}) { + $self->remove(); + } +} + +########################################### +sub semop { +########################################### + my($self, @args) = @_; + + my $retries = $self->{semop_retries}; + + my $rc; + + { + $rc = semop($args[0], $args[1]); + + if(!$rc and + $! =~ /temporarily unavailable/ and + $retries-- > 0) { + $rc = 'undef' unless defined $rc; + print "semop failed (rc=$rc), retrying\n", + $self->status_as_string if INTERNAL_DEBUG; + select undef, undef, undef, $self->{semop_wait}; + redo; + } + } + + $rc or die "semop(@args) failed: $! "; + $rc; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Util::Semaphore - Easy to use semaphores + +=head1 SYNOPSIS + + use Log::Log4perl::Util::Semaphore; + my $sem = Log::Log4perl::Util::Semaphore->new( key => "abc" ); + + $sem->semlock(); + # ... critical section + $sem->semunlock(); + + $sem->semset( uid => (getpwnam("hugo"))[2], + gid => 102, + mode => 0644 + ); + +=head1 DESCRIPTION + +Log::Log4perl::Util::Semaphore provides the synchronisation mechanism +for the Synchronized.pm appender in Log4perl, but can be used independently +of Log4perl. + +As a convenience, the C<uid> field accepts user names as well, which it +translates into the corresponding uid by running C<getpwnam>. + +=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. + diff --git a/lib/Log/Log4perl/Util/TimeTracker.pm b/lib/Log/Log4perl/Util/TimeTracker.pm new file mode 100644 index 0000000..35847c6 --- /dev/null +++ b/lib/Log/Log4perl/Util/TimeTracker.pm @@ -0,0 +1,259 @@ +################################################## +package Log::Log4perl::Util::TimeTracker; +################################################## + +use 5.006; +use strict; +use warnings; +use Log::Log4perl::Util; +use Carp; + +our $TIME_HIRES_AVAILABLE; + +BEGIN { + # Check if we've got Time::HiRes. If not, don't make a big fuss, + # just set a flag so we know later on that we can't have fine-grained + # time stamps + $TIME_HIRES_AVAILABLE = 0; + if(Log::Log4perl::Util::module_available("Time::HiRes")) { + require Time::HiRes; + $TIME_HIRES_AVAILABLE = 1; + } +} + +################################################## +sub new { +################################################## + my $class = shift; + $class = ref ($class) || $class; + + my $self = { + reset_time => undef, + @_, + }; + + $self->{time_function} = \&_gettimeofday unless + defined $self->{time_function}; + + bless $self, $class; + + $self->reset(); + + return $self; +} + +################################################## +sub hires_available { +################################################## + return $TIME_HIRES_AVAILABLE; +} + +################################################## +sub _gettimeofday { +################################################## + # Return secs and optionally msecs if we have Time::HiRes + if($TIME_HIRES_AVAILABLE) { + return (Time::HiRes::gettimeofday()); + } else { + return (time(), 0); + } +} + +################################################## +sub gettimeofday { +################################################## + my($self) = @_; + + my($seconds, $microseconds) = $self->{time_function}->(); + + $microseconds = 0 if ! defined $microseconds; + return($seconds, $microseconds); +} + +################################################## +sub reset { +################################################## + my($self) = @_; + + my $current_time = [$self->gettimeofday()]; + $self->{reset_time} = $current_time; + $self->{last_call_time} = $current_time; + + return $current_time; +} + +################################################## +sub time_diff { +################################################## + my($time_from, $time_to) = @_; + + my $seconds = $time_to->[0] - + $time_from->[0]; + + my $milliseconds = int(( $time_to->[1] - + $time_from->[1] ) / 1000); + + if($milliseconds < 0) { + $milliseconds = 1000 + $milliseconds; + $seconds--; + } + + return($seconds, $milliseconds); +} + +################################################## +sub milliseconds { +################################################## + my($self, $current_time) = @_; + + $current_time = [ $self->gettimeofday() ] unless + defined $current_time; + + my($seconds, $milliseconds) = time_diff( + $self->{reset_time}, + $current_time); + + return $seconds*1000 + $milliseconds; +} + +################################################## +sub delta_milliseconds { +################################################## + my($self, $current_time) = @_; + + $current_time = [ $self->gettimeofday() ] unless + defined $current_time; + + my($seconds, $milliseconds) = time_diff( + $self->{last_call_time}, + $current_time); + + $self->{last_call_time} = $current_time; + + return $seconds*1000 + $milliseconds; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Util::TimeTracker - Track time elapsed + +=head1 SYNOPSIS + + use Log::Log4perl::Util::TimeTracker; + + my $timer = Log::Log4perl::Util::TimeTracker->new(); + + # equivalent to Time::HiRes::gettimeofday(), regardless + # if Time::HiRes is present or not. + my($seconds, $microseconds) = $timer->gettimeofday(); + + # reset internal timer + $timer->reset(); + + # return milliseconds since last reset + $msecs = $timer->milliseconds(); + + # return milliseconds since last call + $msecs = $timer->delta_milliseconds(); + +=head1 DESCRIPTION + +This utility module helps tracking time elapsed for PatternLayout's +date and time placeholders. Its accuracy depends on the availability +of the Time::HiRes module. If it's available, its granularity is +milliseconds, if not, seconds. + +The most common use of this module is calling the gettimeofday() +method: + + my($seconds, $microseconds) = $timer->gettimeofday(); + +It returns seconds and microseconds of the current epoch time. If +Time::HiRes is installed, it will simply defer to its gettimeofday() +function, if it's missing, time() will be called instead and $microseconds +will always be 0. + +To measure time elapsed in milliseconds, use the reset() method to +reset the timer to the current time, followed by one or more calls to +the milliseconds() method: + + # reset internal timer + $timer->reset(); + + # return milliseconds since last reset + $msecs = $timer->milliseconds(); + +On top of the time span between the last reset and the current time, +the module keeps track of the time between calls to delta_milliseconds(): + + $msecs = $timer->delta_milliseconds(); + +On the first call, this will return the number of milliseconds since the +last reset(), on subsequent calls, it will return the time elapsed in +milliseconds since the last call to delta_milliseconds() instead. Note +that reset() also resets the time of the last call. + +The internal timer of this module gets its time input from the POSIX time() +function, or, if the Time::HiRes module is available, from its +gettimeofday() function. To figure out which one it is, use + + if( $timer->hires_available() ) { + print "Hooray, we get real milliseconds!\n"; + } else { + print "Milliseconds are just bogus\n"; + } + +For testing purposes, a different time source can be provided, so test +suites can simulate time passing by without actually having to wait: + + my $start_time = time(); + + my $timer = Log::Log4perl::Util::TimeTracker->new( + time_function => sub { + return $start_time++; + }, + ); + +Every call to $timer->epoch() will then return a time value that is one +second ahead of the value returned on the previous call. This also means +that every call to delta_milliseconds() will return a value that exceeds +the value returned on the previous call by 1000. + +=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. + diff --git a/t/001Level.t b/t/001Level.t new file mode 100644 index 0000000..381d3f1 --- /dev/null +++ b/t/001Level.t @@ -0,0 +1,61 @@ +########################################### +# Test Suite for Log::Log4perl::Level +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +use strict; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +BEGIN { plan tests => 34 }; +use Log::Log4perl::Level; +BEGIN { + Log::Log4perl::Level->import("Level"); + Log::Log4perl::Level->import("My::Level"); +} +ok(1); # If we made it this far, we're ok. + +# Import them into the 'main' namespace; +foreach ($TRACE, $DEBUG, $INFO, $WARN, $ERROR, $FATAL) { + ok(Log::Log4perl::Level::to_level($_)); +} + +# Import them into the 'Level' namespace; +foreach ($Level::TRACE, $Level::DEBUG, $Level::INFO, $Level::WARN, $Level::ERROR, $Level::FATAL) { + ok(Log::Log4perl::Level::to_level($_)); +} + +# Import them into the 'My::Level' namespace; +foreach ($My::Level::DEBUG, $My::Level::DEBUG, $My::Level::INFO, $My::Level::WARN, $My::Level::ERROR, $My::Level::FATAL) { + ok(Log::Log4perl::Level::to_level($_)); +} + +# ok, now let's check to make sure the relative order is correct. + +ok(Log::Log4perl::Level::isGreaterOrEqual($TRACE, $DEBUG)); +ok(Log::Log4perl::Level::isGreaterOrEqual($DEBUG, $INFO)); +ok(Log::Log4perl::Level::isGreaterOrEqual($INFO, $WARN)); +ok(Log::Log4perl::Level::isGreaterOrEqual($WARN, $ERROR)); +ok(Log::Log4perl::Level::isGreaterOrEqual($ERROR, $FATAL)); + +ok(Log::Log4perl::Level::isGreaterOrEqual($Level::TRACE, $Level::DEBUG)); +ok(Log::Log4perl::Level::isGreaterOrEqual($Level::DEBUG, $Level::INFO)); +ok(Log::Log4perl::Level::isGreaterOrEqual($Level::INFO, $Level::WARN)); +ok(Log::Log4perl::Level::isGreaterOrEqual($Level::WARN, $Level::ERROR)); +ok(Log::Log4perl::Level::isGreaterOrEqual($Level::ERROR, $Level::FATAL)); + +ok(Log::Log4perl::Level::isGreaterOrEqual($My::Level::TRACE, + $My::Level::DEBUG)); +ok(Log::Log4perl::Level::isGreaterOrEqual($My::Level::DEBUG, $My::Level::INFO)); +ok(Log::Log4perl::Level::isGreaterOrEqual($My::Level::INFO, $My::Level::WARN)); +ok(Log::Log4perl::Level::isGreaterOrEqual($My::Level::WARN, $My::Level::ERROR)); +ok(Log::Log4perl::Level::isGreaterOrEqual($My::Level::ERROR, $My::Level::FATAL)); diff --git a/t/002Logger.t b/t/002Logger.t new file mode 100755 index 0000000..fd6df46 --- /dev/null +++ b/t/002Logger.t @@ -0,0 +1,403 @@ +########################################### +# Test Suite for Log::Log4perl::Logger +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +#use Data::Dump qw(dump); + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +######################### +# used Test::Simple to help debug the test script +use Test::More tests => 74; + +use Log::Log4perl; +use Log::Log4perl::Level; +use Log::Log4perl::Util; + +ok(1); # If we made it this far, we're ok. + +# Check unintialized case +my $logger = Log::Log4perl::get_logger(""); +is $logger->is_trace, 0, "is_trace false when L4p is uninitialized"; +is $logger->is_debug, 0, "is_debug false when L4p is uninitialized"; +is $logger->is_error, 0, "is_error false when L4p is uninitialized"; + +my $log0 = Log::Log4perl->get_logger("abc.def"); +is $log0->category(), "abc.def", "category accessor"; +my $log1 = Log::Log4perl->get_logger("abc.def"); +my $log2 = Log::Log4perl->get_logger("abc.def"); +my $log3 = Log::Log4perl->get_logger("abc.def.ghi"); +my $log4 = Log::Log4perl->get_logger("def.abc.def"); +my $log5 = Log::Log4perl->get_logger("def.abc.def"); +my $log6 = Log::Log4perl->get_logger(""); +my $log7 = Log::Log4perl->get_logger(""); +my $log8 = Log::Log4perl->get_logger("abc.def"); +my $log9 = Log::Log4perl->get_logger("abc::def::ghi"); + +# Loggers for the same namespace have to be identical +ok($log1 == $log2, "Log1 same as Log2"); +ok($log4 == $log5, "Log4 same as Log5"); +ok($log6 == $log7, "Log6 same as Log7"); +ok($log1 == $log8, "Log1 same as Log8"); +ok($log3 == $log9, "log3 same as Log9"); + +# Loggers for different namespaces have to be different +ok($log1 != $log3, "Log1 not Log3"); +ok($log3 != $log4, "Log3 not Log4"); +ok($log1 != $log6, "Log1 not Log6"); +ok($log3 != $log6, "Log3 not Log6"); +ok($log5 != $log6, "Log5 not Log6"); +ok($log5 != $log7, "Log5 not Log7"); +ok($log5 != $log1, "Log5 not Log1"); +ok($log7 != $log8, "Log7 not Log8"); +ok($log8 != $log9, "Log8 not Log9"); + +my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +################################################## +# Suppress debug +################################################## +$log1->add_appender($app); +$log1->level($ERROR); + +# warn "level is: ", $log1->level(), "\n"; + +my $ret; + +$ret = $log1->error("Error Message"); +ok($ret == 1); + +$ret = $log1->debug("Debug Message"); +ok(!defined $ret); + +ok($app->buffer() eq "ERROR - Error Message\n", "log1 app buffer contains ERROR - Error Message"); + +# warn "app buffer is: \"", $app->buffer(), "\"\n"; + +################################################## +# Allow debug +################################################## +$log1->level($DEBUG); +$app->buffer(""); +$log1->error("Error Message"); +$log1->debug("Debug Message"); +ok($app->buffer() eq "ERROR - Error Message\nDEBUG - Debug Message\n", + "app buffer contains both ERROR and DEBUG message"); + +# warn "app buffer is: \"", $app->buffer(), "\"\n"; + +################################################## +# Multiple Appenders +################################################## +my $app2 = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); +my $app3 = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +$app->buffer(""); +$app2->buffer(""); + # 2nd appender to $log1 +$log1->add_appender($app2); +$log1->level($ERROR); +$log1->error("Error Message"); +#TODO +ok($app->buffer() eq "ERROR - Error Message\n", "app buffer contains ERROR only"); +ok($app2->buffer() eq "ERROR - Error Message\n", "app2 buffer contains ERROR only"); + +################################################## +# Multiple Appenders in different hierarchy levels +################################################## +$app->buffer(""); +$app2->buffer(""); +$app3->buffer(""); + +$log1 = Log::Log4perl->get_logger("xxx.yyy.zzz"); +$log2 = Log::Log4perl->get_logger("xxx"); +$log3 = Log::Log4perl->get_logger(""); + + # Root logger +$log3->add_appender($app3); + +$log3->level($ERROR); + + ################################################## + # Log to lower level, check if gets propagated up to root + ################################################## +$log1->error("Error Message"); + + # Should be distributed to root +ok($app3->buffer() eq "ERROR - Error Message\n", "app3 buffer contains ERROR"); + ################################################## + # Log in lower levels and propagate to root + ################################################## +$app->buffer(""); +$app2->buffer(""); +$app3->buffer(""); + +$log1->add_appender($app); +$log2->add_appender($app2); +# log3 already has app3 attached +$ret = $log1->error("Error Message"); +ok($ret == 3); +ok($app->buffer() eq "ERROR - Error Message\n", "app buffer contains ERROR"); +ok($app2->buffer() eq "ERROR - Error Message\n", "app2 buffer contains ERROR"); +ok($app3->buffer() eq "ERROR - Error Message\n", "app3 buffer contains ERROR"); + + ################################################## + # Block appenders via priority + ################################################## +$app->buffer(""); +$app2->buffer(""); +$app3->buffer(""); + +$log1->level($ERROR); +$log2->level($DEBUG); +$log3->level($DEBUG); + +$log1->debug("Debug Message"); +ok($app->buffer() eq "", "app buffer is empty"); +ok($app2->buffer() eq "", "app2 buffer is empty"); +ok($app3->buffer() eq "", "app3 buffer is empty"); + + ################################################## + # Block via 'false' additivity + ################################################## +$app->buffer(""); +$app2->buffer(""); +$app3->buffer(""); + +$log1->level($DEBUG); +$log2->additivity(0); +$log2->level($DEBUG); +$log3->level($DEBUG); + +$log1->debug("Debug Message"); +ok($app->buffer() eq "DEBUG - Debug Message\n", "app buffer contains DEBUG"); +ok($app2->buffer() eq "DEBUG - Debug Message\n", "app2 buffer contains DEBUG"); +ok($app3->buffer() eq "", "app3 buffer is empty"); + + ################################################## + # Check is_*() functions + ################################################## +$log0->level($TRACE); +$log1->level($DEBUG); +$log2->level($ERROR); +$log3->level($INFO); + +ok($log0->is_trace(), "log0 is_trace == 1"); +ok($log0->is_error(), "log0 is_error == 1"); + +ok($log1->is_error(), "log1 is_error == 1"); +ok($log1->is_info(), "log1 is_info == 1"); +ok($log1->is_fatal(), "log1 is_fatal == 1"); +ok($log1->is_debug(), "log1 is_debug == 1"); + +ok($log2->is_error(), "log2 is_error == 1"); +ok(!$log2->is_info(), "log2 is_info == 0"); +ok($log2->is_fatal(), "log2 is_fatal == 1"); +ok(!$log2->is_debug(), "log2 is_debug == 0"); + +ok($log3->is_error(), "log3 is_error == 1"); +ok($log3->is_info(), "log3 is_info == 1"); +ok($log3->is_fatal(), "log3 is_fatal == 1"); +ok(!$log3->is_debug(), "log3 is_debug == 0"); + + + ################################################## + # Check is_*() functions with text + ################################################## +$log3->level('DEBUG'); +$log2->level('ERROR'); +$log1->level('INFO'); + +ok($log3->is_error(), "log3 is_error == 1"); +ok($log3->is_info(), "log3 is_info == 1"); +ok($log3->is_fatal(), "log3 is_fatal == 1"); +ok($log3->is_debug(), "log3 is_debug == 1"); + +ok($log2->is_error(), "log2 is_error == 1"); +ok(!$log2->is_info(), "log2 is_info == 0"); +ok($log2->is_fatal(), "log2 is_fatal == 1"); +ok(!$log2->is_debug(), "log2 is_debug == 0"); + +ok($log1->is_error(), "log1 is_error == 1"); +ok($log1->is_info(), "log1 is_info == 1"); +ok($log1->is_fatal(), "log1 is_fatal == 1"); +ok(!$log1->is_debug(), "log1 is_debug == 0"); + + + ################################################## + # Check log->(<level_const>,<msg>) + ################################################## +$app->buffer(""); +$app2->buffer(""); +$app3->buffer(""); + +$log1->level($DEBUG); +$log2->level($ERROR); +$log3->level($INFO); + +$log1->log($DEBUG, "debug message"); +$log1->log($INFO, "info message "); + +$log2->log($DEBUG, "debug message"); +$log2->log($INFO, "info message "); + +$log3->log($DEBUG, "debug message"); +$log3->log($INFO, "info message "); + +ok($app->buffer() eq "DEBUG - debug message\nINFO - info message \n", + "app buffer contains DEBUG and INFO"); +ok($app2->buffer() eq "DEBUG - debug message\nINFO - info message \n", + "app2 buffer contains DEBUG"); +ok($app3->buffer() eq "INFO - info message \n", + "app3 buffer contains INFO"); + + ################################################## + # Check several messages concatenated + ################################################## +$app->buffer(""); + +$log1->level($DEBUG); + +$log1->log($DEBUG, "1", " ", "2", " "); +$log1->debug("3 ", "4 "); +$log1->info("5 ", "6 "); +$log1->warn("7 ", "8 "); +$log1->error("9 ", "10 "); +$log1->fatal("11 ", "12 ", "13 "); + +my $got = $app->buffer(); +my $expected = <<EOT; +DEBUG - 1 2 +DEBUG - 3 4 +INFO - 5 6 +WARN - 7 8 +ERROR - 9 10 +FATAL - 11 12 13 +EOT + +ok($got eq $expected) || print STDERR "got $got\n expected $expected"; + + +#ok($app->buffer() eq <<EOT, "app buffer six lines"); +#DEBUG - 1 2 +#DEBUG - 3 4 +#INFO - 5 6 +#WARN - 7 8 +#ERROR - 9 10 +#FATAL - 11 12 13 +#EOT + + ################################################## + # Check several messages concatenated + ################################################## +$app->buffer(""); + +$log1->level($DEBUG); + +$log1->log($DEBUG, sub { "1" . " " . "2" } ); +$log1->info( + sub { "3 " . "4 " }, # subroutine + # filter (throw out blanks) + { filter => sub { my $v = shift; + $v =~ s/\s+//g; + return $v; + }, + value => " 5 6 " }, + " 7" ); + +is($app->buffer(), <<EOT, "app buffer contains 2 lines"); +DEBUG - 1 2 +INFO - 3 4 56 7 +EOT + +# warn("app buffer is: ", $app->buffer(), "\n"); + +############################################################ +# testing multiple parameters, nested hashes +############################################################ + +our $stub_hook; + +# ----------------------------------- +# here/s a stub +package Log::Log4perl::AppenderTester; +sub new { + my($class, %params) = @_; + my $self = {}; + bless $self, $class; + + $self->{P} = \%params; + + $main::stub_hook = $self; + + return $self; +} +package main; +# ----------------------------------- + +$app = Log::Log4perl::Appender->new( + "Log::Log4perl::AppenderTester", + name => 'dumpy', + login => { hostname => 'a.jabber.server', + port => 5222, + username => "bugs", + password => "bunny", + resource => "logger" }, + to => [ 'elmer@a.jabber.server', 'sam@another.jabber.server' ], +); + +ok($stub_hook->{P}{login}{hostname}, 'a.jabber.server'); +ok($stub_hook->{P}{login}{password}, 'bunny'); +ok($stub_hook->{P}{to}[0], 'elmer@a.jabber.server'); +ok($stub_hook->{P}{to}[1], 'sam@another.jabber.server'); + +# ------------------------------------ +# Check if we get all appenders + +my $href = Log::Log4perl->appenders(); +my $result = ""; + +for(sort keys %$href) { + $result .= "$_ => " . ref($href->{$_}->{appender}); +} + +like($result, qr/(app\d+.*?Log::Log4perl::Appender::TestBuffer){3}/, + "all appenders"); + + +################################################## +# Bug reported by Brian Edwards: add_appender() +# with screen/file appender fails because of missing +# base class declaration +################################################## +my $log10 = Log::Log4perl->get_logger("xxx.yyy.zzz"); + +use Log::Log4perl::Appender::Screen; +use Log::Log4perl::Appender::File; + +my $app_screen = Log::Log4perl::Appender::Screen->new(); + +my $tmpfile = Log::Log4perl::Util::tmpfile_name(); +END { unlink $tmpfile if defined $tmpfile }; + +my $app_file = Log::Log4perl::Appender::File->new( + filename => $tmpfile +); + +eval { $log10->add_appender($app_file); }; +is($@, "", "Adding file appender"); +eval { $log10->add_appender($app_screen); }; +is($@, "", "Adding screen appender"); + diff --git a/t/003Layout-Rr.t b/t/003Layout-Rr.t new file mode 100644 index 0000000..ba2b564 --- /dev/null +++ b/t/003Layout-Rr.t @@ -0,0 +1,154 @@ +#!/usr/bin/perl + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use strict; +use warnings; + +use Test::More tests => 2; +use File::Spec; + +use Log::Log4perl; +use Log::Log4perl::Layout::PatternLayout; +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; + +my ($SECONDS, $MICRO_SECONDS) = ($^T, 100_000); # Script's startup time +my $DEBUG = 0; + + +# Pretend that the script was at sleep +sub fake_sleep ($) { + my ($seconds) = @_; + $SECONDS += $seconds; + $MICRO_SECONDS = ($MICRO_SECONDS + 1_000) % 1_000_000; +} + +sub fake_time { + return ($SECONDS, $MICRO_SECONDS); +} + + + +my $logger = create_logger(); + + +# Start some logging +$logger->info("Start"); + +fake_sleep(1); +$logger->debug("Pause: 1 sec"); + +fake_sleep(2); +$logger->info("Pause: 2 secs"); + +fake_sleep(1); +$logger->debug("Pause: 1 sec"); + +$logger->warn("End"); + +# Debug traces to be turned on when troubleshooting +if ($DEBUG) { + # Get the contents of the buffers + foreach my $appender (qw(A B)) { + my $buffer = Log::Log4perl::Appender::TestBuffer->by_name($appender)->buffer(); + diag("========= $appender =========="); + diag($buffer); + } +} + +# Get the elapsed times so far +my @a = get_all_elapsed_ms('A'); +my @b = get_all_elapsed_ms('B'); + +is_deeply( + \@a, + [ + 'A 0ms Start [0ms]', + 'A 1001ms Pause: 1 sec [1001ms]', + 'A 2001ms Pause: 2 secs [3002ms]', + 'A 1001ms Pause: 1 sec [4003ms]', + 'A 0ms End [4003ms]', + ] +); + +is_deeply( + \@b, + [ + 'B 0ms Start [0ms]', + 'B 3002ms Pause: 2 secs [3002ms]', + 'B 1001ms End [4003ms]', + ] +); + + +# +# Returns the elapsed times logged so far. +# +sub get_all_elapsed_ms { + my ($categoty) = @_; + + return split /\n/, + Log::Log4perl::Appender::TestBuffer->by_name($categoty)->buffer() + ; +} + + +# +# Initialize the logging system with a twist. Here we inject our own time +# function into the appenders. This way we will be able to control time and +# ensure a deterministic behaviour that can always be reproduced which is ideal +# for unit tests. +# +# We need to create the appenders by hand in order to add a custom time +# function. The final outcome should be something similar to the following +# configuration: +# +# log4perl.logger.test = ALL, A, B +# +# log4perl.appender.A = Log::Log4perl::Appender::TestBuffer +# log4perl.appender.A.layout = Log::Log4perl::Layout::PatternLayout +# log4perl.appender.A.layout.ConversionPattern = A %Rms %m [%rms]%n +# log4perl.appender.A.Threshold = ALL +# +# log4perl.appender.B = Log::Log4perl::Appender::TestBuffer +# log4perl.appender.B.layout = Log::Log4perl::Layout::PatternLayout +# log4perl.appender.B.layout.ConversionPattern = B %Rms %m [%rms]%n +# log4perl.appender.B.Threshold = INFO +# +sub create_logger { + + my $logger = Log::Log4perl->get_logger("test"); + $logger->level($ALL); + + my %appenders = ( + A => $ALL, + B => $INFO, + ); + + # Inject the time function into the appenders + while (my ($name, $threshold) = each %appenders) { + my $appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer", + name => $name, + ); + if ($name eq 'B') { + $appender->threshold($INFO); + } + + my $layout = Log::Log4perl::Layout::PatternLayout->new( + {time_function => \&fake_time}, + "$name %Rms %m [%rms]%n" + ); + $appender->layout($layout); + $logger->add_appender($appender); + } + + return $logger; +} + diff --git a/t/003Layout.t b/t/003Layout.t new file mode 100755 index 0000000..0b4db86 --- /dev/null +++ b/t/003Layout.t @@ -0,0 +1,285 @@ +########################################### +# Test Suite for Log::Log4perl +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test::More; +BEGIN { plan tests => 24 }; + +use Log::Log4perl; +use Log::Log4perl::Layout; + +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +ok(1); # If we made it this far, we/re ok. + +my $logger = Log::Log4perl->get_logger("abc.def.ghi"); +$logger->level($DEBUG); +$logger->add_appender($app); +my $layout = Log::Log4perl::Layout::PatternLayout->new( + "bugo %% %c{2} %-17F{2} %L hugo"); +$app->layout($layout); +my $line = __LINE__ + 1; +$logger->debug("That's the message"); + +is($app->buffer(), "bugo % def.ghi " . + File::Spec->catfile(qw(t 003Layout.t)) . + " $line hugo"); + +############################################################ +# Log the message +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new( + "The message is here: %m"); +$app->layout($layout); +$logger->debug("That's the message"); + +is($app->buffer(), "The message is here: That's the message"); + +############################################################ +# Log the time +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("[%r] %m"); +$app->layout($layout); +$logger->debug("That's the message"); + +like($app->buffer(), qr/^\[\d+\] That's the message$/); + +############################################################ +# Log the date/time +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%d> %m"); +$app->layout($layout); +$logger->debug("That's the message"); + +like($app->buffer(), + qr#^\d{4}/\d\d/\d\d \d\d:\d\d:\d\d> That\'s the message$#); + +############################################################ +# Log the date/time with own timer function +############################################################ +sub mytimer1 { + # 2 days after 1/1/1970 to compensate for time zones + return 180000; +} + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new( + { time_function => \&mytimer1 }, "%d{MM/yyyy}> %m"); +$app->layout($layout); +$logger->debug("That's the message"); +like($app->buffer(), qr{01/1970}); + + # epoch format +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new( + { time_function => \&mytimer1 }, "%d{e}> %m"); +$app->layout($layout); +$logger->debug("That's the message"); +like($app->buffer(), qr/^180000/); + +############################################################ +# Check SimpleLayout +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::SimpleLayout->new(); +$app->layout($layout); +$logger->debug("That's the message"); + +is($app->buffer(), "DEBUG - That\'s the message\n"); + +############################################################ +# Check depth level of %M - with debug(...) +############################################################ + +sub mysubroutine { + $app->buffer(""); + $layout = Log::Log4perl::Layout::PatternLayout->new("%M: %m"); + $app->layout($layout); + $logger->debug("That's the message"); +} + +mysubroutine(); +is($app->buffer(), 'main::mysubroutine: That\'s the message'); + +############################################################ +# Check depth level of %M - with debug(...) +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%M: %m"); +$app->layout($layout); +$logger->debug("That's the message"); + +is($app->buffer(), 'main::: That\'s the message'); + +############################################################ +# Check Filename and Line # +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%F-%L %m"); +$app->layout($layout); +$line = __LINE__ + 1; +$logger->debug("That's the message"); + +like($app->buffer(), qr/003Layout.t-$line That's the message/); + +############################################################ +# Don't append a newline if the message already contains one +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%m%n"); +$app->layout($layout); +$logger->debug("That's the message\n"); + +is($app->buffer(), "That\'s the message\n"); + +############################################################ +# But don't suppress other %ns +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("a%nb%n%m%n"); +$app->layout($layout); +$logger->debug("That's the message\n"); + +is($app->buffer(), "a\nb\nThat\'s the message\n"); + +############################################################ +# Test if the process ID works +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%P:%m"); +$app->layout($layout); +$logger->debug("That's the message\n"); + +like($app->buffer(), qr/^\d+:That's the message$/); + +############################################################ +# Test if the hostname placeholder %H works +############################################################ +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%H:%m"); +$app->layout($layout); +$logger->debug("That's the message\n"); + +like($app->buffer(), qr/^[^:]+:That's the message$/); + +############################################################ +# Test max width in the format specifiers +############################################################ +#min width +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%5.5m"); +$app->layout($layout); +$logger->debug("123"); +is($app->buffer(), ' 123'); + +#max width +$app->buffer(""); +$logger->debug("1234567"); +is($app->buffer(), '12345'); + +#left justify +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%-5.5m"); +$app->layout($layout); +$logger->debug("123"); +is($app->buffer(), '123 '); + +############################################################ +# Check depth level of %M - with eval {...} +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%M: %m"); +$app->layout($layout); +sub foo { + eval { + $logger->debug("Thats the message"); + }; +} +foo(); +is($app->buffer(), 'main::foo: Thats the message'); + +############################################################ +# Check two levels of %M - with eval {...} +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%M: %m"); +$app->layout($layout); +sub foo2 { + eval { + eval { + $logger->debug("Thats the message"); + }; + }; +} +foo2(); +is($app->buffer(), 'main::foo2: Thats the message'); + +############################################################ +# Check depth level of %M - with eval {...} +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%M: %m"); +$app->layout($layout); +eval { + $logger->debug("Thats the message"); +}; +is($app->buffer(), 'main::: Thats the message'); + +############################################################ +# Non-portable line breaks +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%m\\n"); +$app->layout($layout); +eval { + $logger->debug("Thats the message"); +}; +is($app->buffer(), "Thats the message\n"); + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout->new("%m\\r\\n"); +$app->layout($layout); +eval { + $logger->debug("Thats the message"); +}; +is($app->buffer(), "Thats the message\r\n"); + +############################################################ +# Render a multiline message +############################################################ + +$app->buffer(""); +$layout = Log::Log4perl::Layout::PatternLayout::Multiline->new("%M: %m%n"); +$app->layout($layout); +eval { + $logger->debug("Thats the\nmultiline\nmessage"); +}; +is($app->buffer(), "main::: Thats the\nmain::: multiline\nmain::: message\n"); + diff --git a/t/004Config.t b/t/004Config.t new file mode 100644 index 0000000..9f1b615 --- /dev/null +++ b/t/004Config.t @@ -0,0 +1,406 @@ +########################################### +# Test Suite for Log::Log4perl +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test::More; +BEGIN { plan tests => 28 }; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +my $TMP_FILE = File::Spec->catfile($EG_DIR, "warnings"); + +ok(1, "Startup"); # If we made it this far, we are ok. + +###################################################################### +# Test the root logger on a configuration file defining a file appender +###################################################################### +Log::Log4perl->init("$EG_DIR/log4j-manual-1.conf"); + +my $logger = Log::Log4perl->get_logger(""); +$logger->debug("Gurgel"); + + +like(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + qr#^\d+\s+\[N/A\] DEBUG N/A - Gurgel$#, "Root logger"); + +###################################################################### +# Test the root logger via inheritance (discovered by Kevin Goess) +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init("$EG_DIR/log4j-manual-1.conf"); + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +like(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + qr#^\d+\s+\[N/A\] DEBUG foo N/A - Gurgel$#, "Root logger inherited"); + +###################################################################### +# Test init with a string +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init(\ <<EOT); +log4j.rootLogger=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%-4r [%t] %-5p %c - %m%n +EOT + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +like(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + qr#^\d+\s+\[N/A\] DEBUG foo - Gurgel$#, "Init via string"); + +###################################################################### +# Test init with a hashref +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +my %hash = ( + "log4j.rootLogger" => "DEBUG, A1", + "log4j.appender.A1" => "Log::Log4perl::Appender::TestBuffer", + "log4j.appender.A1.layout" => "org.apache.log4j.PatternLayout", + "log4j.appender.A1.layout.ConversionPattern" => + "%-4r [%t] %-5p %c - %m%n" + ); + +Log::Log4perl->init(\%hash); + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +like(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + qr#^\d+\s+\[N/A\] DEBUG foo - Gurgel$#, "Init via hashref"); + + +############################################################ +# testing multiple parameters, nested hashes +############################################################ + +our $stub_hook; + +# ----------------------------------- +# here is a stub +package Log::Log4perl::AppenderTester; +sub new { + my($class, %params) = @_; + my $self = {}; + bless $self, $class; + + $self->{P} = \%params; + + $main::stub_hook = $self; + + return $self; +} +package main; +# ----------------------------------- + +Log::Log4perl->init(\ <<'EOT'); +#here is an example of using Log::Dispatch::Jabber + +log4j.category.animal.dog = INFO, jabbender + +log4j.appender.jabbender = Log::Log4perl::AppenderTester +log4j.appender.jabbender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.jabbender.login.hostname = a.jabber.server +log4j.appender.jabbender.login.port = 5222 +log4j.appender.jabbender.login.username = bugs +log4j.appender.jabbender.login.password = bunny +log4j.appender.jabbender.login.resource = logger +log4j.appender.jabbender.to = elmer@a.jabber.server +log4j.appender.jabbender.to = sam@another.jabber.server + +EOT + +#should produce this: +#{ +# login => { +# hostname => "a.jabber.server", +# password => "bunny", +# port => 5222, +# resource => "logger", +# username => "bugs", +# }, +# to => ["elmer\@a.jabber.server", "sam\@another.jabber.server"], +# }, + + +is($stub_hook->{P}{login}{hostname}, 'a.jabber.server', "Config and Jabber"); +is($stub_hook->{P}{login}{password}, 'bunny', "Config and Jabber"); +is($stub_hook->{P}{to}[0], 'elmer@a.jabber.server', "Config and Jabber"); +is($stub_hook->{P}{to}[1], 'sam@another.jabber.server', "Config and Jabber"); + +########################################################################## +# Test what happens if we define a PatternLayout without ConversionPattern +########################################################################## +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = <<EOT; + log4perl.logger.Twix.Bar = DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=PatternLayout + #log4perl.appender.A1.layout.ConversionPattern=%d-%c %m%n +EOT + +eval { Log::Log4perl->init(\$conf); }; + + +#actually, it turns out that log4j handles this, if no ConversionPattern +#specified is uses DEFAULT_LAYOUT_PATTERN, %m%n +#ok($@, '/No ConversionPattern given for PatternLayout/'); +is($@, '', 'PatternLayout without ConversionPattern'); + +###################################################################### +# Test with $/ set to undef +###################################################################### +$/ = undef; +Log::Log4perl->init("$EG_DIR/log4j-manual-1.conf"); + +$logger = Log::Log4perl->get_logger(""); +$logger->debug("Gurgel"); + +like(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + qr#^\d+\s+\[N/A\] DEBUG N/A - Gurgel$#, "Config in slurp mode"); + +###################################################################### +# Test init with a config parser object +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +my $parser = Log::Log4perl::Config::PropertyConfigurator->new(); +my @lines = split "\n", <<EOT; +log4j.rootLogger = DEBUG, A1 +log4j.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout = org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern = object%m%n +EOT +$parser->text(\@lines); + +Log::Log4perl->init($parser); + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "objectGurgel\n", "Init with parser object"); + +###################################################################### +# Test integrity check +###################################################################### +open STDERR, ">$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; +sub readwarn { return (scalar <IN>) || ''; } +END { close IN } + +Log::Log4perl->init(\ <<EOT); + # Just an empty configuration +EOT + +like(readwarn(), qr/looks suspicious: No loggers/, + "Test integrity check on empty conf file"); + +close STDERR; +close IN; +unlink $TMP_FILE; + +###################################################################### +# Misspelled 'rootlogger' (needs to be rootLogger) +###################################################################### +open STDERR, ">$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; + +Log::Log4perl->reset(); +$Log::Log4perl::Logger::LOGGERS_BY_NAME = {}; + +Log::Log4perl->init(\ <<EOT); + log4perl.rootlogger=ERROR, LOGFILE + + log4perl.appender.LOGFILE=Log::Log4perl::Appender::Screen + log4perl.appender.LOGFILE.layout=PatternLayout + log4perl.appender.LOGFILE.layout.ConversionPattern=[%r] %F %L %c - %m %n +EOT + +is(readwarn(), "", "Autocorrecting rootLogger/rootlogger typo"); + +close STDERR; +close IN; +unlink $TMP_FILE; + +###################################################################### +# Totally misspelled rootLogger +###################################################################### +open STDERR, ">$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; + +Log::Log4perl->reset(); +$Log::Log4perl::Logger::LOGGERS_BY_NAME = {}; + +Log::Log4perl->init(\ <<EOT); + log4perl.schtonk=ERROR, LOGFILE + + log4perl.appender.LOGFILE=Log::Log4perl::Appender::Screen + log4perl.appender.LOGFILE.layout=PatternLayout + log4perl.appender.LOGFILE.layout.ConversionPattern=[%r] %F %L %c - %m %n +EOT + +like(readwarn(), qr/looks suspicious: No loggers/, + "Test integrity check on totally misspelled rootLogger typo"); + +close STDERR; +close IN; +unlink $TMP_FILE; + +###################################################################### +# PatternLayout %m{} +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init(\ <<EOT); +log4j.logger.foo=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%M%m +EOT + +########################################### +sub somefunc { +########################################### + $logger = Log::Log4perl->get_logger("foo"); + $logger->debug("Gurgel"); +} + +package SomePackage; +########################################### +sub somepackagefunc { +########################################### + $logger = Log::Log4perl->get_logger("foo"); + $logger->debug("Gurgel"); +} +package main; + +somefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "main::somefuncGurgel", "%M main"); + +Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(""); +SomePackage::somepackagefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "SomePackage::somepackagefuncGurgel", "%M in package"); + +###################################################################### +# PatternLayout %m{1} +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init(\ <<EOT); +log4j.logger.foo=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%M{1}%m +EOT + +somefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "somefuncGurgel", "%M{1} main"); + +Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(""); +SomePackage::somepackagefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "somepackagefuncGurgel", "%M{1} package"); + +###################################################################### +# PatternLayout %p{1} +###################################################################### +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init(\ <<EOT); +log4j.logger.foo=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=-%p{1}- %m +EOT + +somefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "-D- Gurgel", "%p{1} main"); + +Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(""); +SomePackage::somepackagefunc(); +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "-D- Gurgel", "%p{1} package"); + +###################################################################### +# Test accessors +###################################################################### +$parser = Log::Log4perl::Config::PropertyConfigurator->new(); +@lines = split "\n", <<EOT; +log4j.rootLogger = DEBUG, A1 +log4j.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout = org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern = object%m%n +EOT +$parser->text(\@lines); +$parser->parse(); +is($parser->value("log4j.rootLogger"), "DEBUG, A1", "value() accessor"); +is($parser->value("log4j.foobar"), undef, "value() accessor undef"); + +is($parser->value("log4j.appender.A1"), + "Log::Log4perl::Appender::TestBuffer", "value() accessor"); + +is($parser->value("log4perl.appender.A1.layout.ConversionPattern"), + "object%m%n", "value() accessor log4perl"); + +###################################################################### +# Test accessors +###################################################################### +my $conf = q{ +log4perl.category.pf.trigger = DEBUG +log4j.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout = org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern = object%m%n +}; + +eval { Log::Log4perl->init( \$conf ); }; + +is $@, "", "'trigger' category [rt.cpan.org #50495]"; + +###################################################################### +# Test alternate comment syntax +###################################################################### + +$conf = <<'END_CONF'; +log4perl.MyParam = MyVal +; log4perl.MyParam = AnotherVal +END_CONF + +eval { Log::Log4perl->init( \$conf ); }; +is $@, "", "support semi-colon comment character [github.com #24]"; + +$conf = <<'END_CONF'; +log4perl.MyParam = MyVal +! log4perl.MyParam = AnotherVal +END_CONF + +eval { Log::Log4perl->init( \$conf ); }; +is $@, "", "support exclamation comment character [github.com #24]"; + diff --git a/t/005Config-Perl.t b/t/005Config-Perl.t new file mode 100644 index 0000000..88ac4fb --- /dev/null +++ b/t/005Config-Perl.t @@ -0,0 +1,58 @@ +########################################### +# Test Suite for Log::Log4perl::Config +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test::More; +BEGIN { plan tests => 3 }; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +ok(1); # If we made it this far, we're ok. + +my $LOGFILE = "example-perl.log"; +unlink $LOGFILE; + +Log::Log4perl->init(File::Spec->catfile($EG_DIR, 'log4j-file-append-perl.conf')); + +my $logger = Log::Log4perl->get_logger(""); +my $line = __LINE__ + 1; +$logger->debug("Gurgel"); + +open LOG, "<$LOGFILE" or die "Cannot open $LOGFILE"; +my $data = <LOG>; + +END { close LOG; unlink $LOGFILE; } + +is($data, "005Config-Perl.t $line DEBUG N/A - Gurgel\n"); + +############################################### +# Check reading a config file via a file handle +############################################### +Log::Log4perl->reset(); +open FILE, File::Spec->catfile($EG_DIR, 'log4j-file-append-perl.conf') or + die "cannot open log4j-file-append-perl.conf"; +Log::Log4perl->init(\*FILE); + +$logger = Log::Log4perl->get_logger(""); +$line = __LINE__ + 1; +$logger->debug("Gurgel"); + +$data = <LOG>; + +is($data, "005Config-Perl.t $line DEBUG N/A - Gurgel\n"); diff --git a/t/006Config-Java.t b/t/006Config-Java.t new file mode 100644 index 0000000..bf252fe --- /dev/null +++ b/t/006Config-Java.t @@ -0,0 +1,74 @@ +########################################### +# Test Suite for Log::Log4perl::Config +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test::More; + +our $LOG_DISPATCH_PRESENT = 0; + +BEGIN { + eval { require Log::Dispatch; }; + if($@) { + plan skip_all => "only with Log::Dispatch"; + } else { + $LOG_DISPATCH_PRESENT = 1; + plan tests => 2; + } +}; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +ok(1); # If we made it this far, we're ok. + +my $LOGFILE = "example-java.log"; +unlink $LOGFILE; + +#Log::Log4perl->init( +# File::Spec->catfile($EG_DIR, 'log4j-file-append-java.conf')); +Log::Log4perl->init("$EG_DIR/log4j-file-append-java.conf"); + + +my $logger = Log::Log4perl->get_logger(""); +my $lines = (); +my $line = __LINE__ + 1; +push @lines, $line++; $logger->debug("Gurgel"); +push @lines, $line++; $logger->info("Gurgel"); +push @lines, $line++; $logger->warn("Gurgel"); +push @lines, $line++; $logger->error("Gurgel"); +push @lines, $line++; $logger->fatal("Gurgel"); + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +my $data = join '', <FILE>; +close FILE; + +my $file = "t/006Config-Java.t"; + +my $exp = <<EOT; +$file $lines[0] DEBUG N/A - Gurgel +$file $lines[1] INFO N/A - Gurgel +$file $lines[2] WARN N/A - Gurgel +$file $lines[3] ERROR N/A - Gurgel +$file $lines[4] FATAL N/A - Gurgel +EOT + + # Adapt Win32 paths +$data =~ s#\\#/#g; + +unlink $LOGFILE; +is($data, "$exp"); diff --git a/t/007LogPrio.t b/t/007LogPrio.t new file mode 100644 index 0000000..76834cd --- /dev/null +++ b/t/007LogPrio.t @@ -0,0 +1,67 @@ +########################################### +# Test Suite for Log::Log4perl +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +BEGIN { plan tests => 2 }; + + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +ok(1); # If we made it this far, we're ok. + +my $LOGFILE = "example-perl2.log"; +unlink $LOGFILE; + +Log::Log4perl->init( \ <<EOT ); +log4j.rootLogger=DEBUG, LOGFILE + +log4j.appender.LOGFILE=Log::Log4perl::Appender::File +log4j.appender.LOGFILE.filename=$LOGFILE +log4j.appender.LOGFILE.mode=append + +log4j.appender.LOGFILE.layout=org.apache.log4j.PatternLayout +log4j.appender.LOGFILE.layout.ConversionPattern=%F{1} %L %p %t %c - %m%n +EOT + +my $logger = Log::Log4perl->get_logger(""); +my @lines = (); +my $line = __LINE__ + 1; +push @lines, $line++; $logger->debug("Gurgel"); +push @lines, $line++; $logger->info("Gurgel"); +push @lines, $line++; $logger->warn("Gurgel"); +push @lines, $line++; $logger->error("Gurgel"); +push @lines, $line++; $logger->fatal("Gurgel"); + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +my $data = join '', <FILE>; +close FILE; + +my $file = "007LogPrio.t"; + +my $exp = <<EOT; +$file $lines[0] DEBUG N/A - Gurgel +$file $lines[1] INFO N/A - Gurgel +$file $lines[2] WARN N/A - Gurgel +$file $lines[3] ERROR N/A - Gurgel +$file $lines[4] FATAL N/A - Gurgel +EOT + +unlink $LOGFILE; +ok($data, "$exp"); diff --git a/t/008ConfCat.t b/t/008ConfCat.t new file mode 100644 index 0000000..98afbca --- /dev/null +++ b/t/008ConfCat.t @@ -0,0 +1,56 @@ +########################################### +# Test Suite for Log::Log4perl::Config +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +BEGIN { plan tests => 3 }; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +my $date_regex = qr(\d{4}/\d\d/\d\d \d\d:\d\d:\d\d); + +ok(1); # If we made it this far, we're ok. + +###################################################################### +# Test a 'foo.bar.baz' logger which inherits level from foo.bar +# and calls both "foo.bar" and "root" appenders with their respective +# formats +# on a configuration file defining a file appender +###################################################################### +Log::Log4perl->init("$EG_DIR/log4j-manual-2.conf"); + +my $logger = Log::Log4perl->get_logger("foo.bar.baz"); +$logger->debug("Gurgel"); + +ok(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "m#$date_regex \\[N/A\\] DEBUG foo.bar.baz - Gurgel#"); + +###################################################################### +# Test the root logger via inheritance (discovered by Kevin Goess) +###################################################################### +Log::Log4perl->reset(); + +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init("$EG_DIR/log4j-manual-2.conf"); + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +ok(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "m#$date_regex \\[N/A\\] DEBUG foo - Gurgel#"); diff --git a/t/009Deuce.t b/t/009Deuce.t new file mode 100644 index 0000000..b8116ac --- /dev/null +++ b/t/009Deuce.t @@ -0,0 +1,55 @@ +########################################### +# Test Suite for Log::Log4perl +# Test two appenders in one category +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +BEGIN { plan tests => 5 }; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +ok(1); # If we made it this far, we're ok. + +###################################################################### +# Test the root logger on a configuration file defining a file appender +###################################################################### +Log::Log4perl->init("$EG_DIR/log4j-manual-3.conf"); + +my $logger = Log::Log4perl->get_logger(""); +$logger->debug("Gurgel"); + +ok(Log::Log4perl::Appender::TestBuffer->by_name("stdout")->buffer(), + 'm#^\S+\s+\[N/A\] \(\S+?:\d+\) - Gurgel$#'); +ok(Log::Log4perl::Appender::TestBuffer->by_name("R")->buffer(), + 'm#^\S+\s+N/A\s+\'\' - Gurgel$#'); + +###################################################################### +# Test the root logger via inheritance (discovered by Kevin Goess) +###################################################################### +Log::Log4perl->reset(); +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init("$EG_DIR/log4j-manual-3.conf"); + +$logger = Log::Log4perl->get_logger("foo"); +$logger->debug("Gurgel"); + +ok(Log::Log4perl::Appender::TestBuffer->by_name("stdout")->buffer(), + 'm#^\S+\s+\[N/A\] \(\S+?:\d+\) - Gurgel$#'); +ok(Log::Log4perl::Appender::TestBuffer->by_name("R")->buffer(), + 'm#^\S+\s+N/A \'foo\' - Gurgel$#'); diff --git a/t/010JConsole.t b/t/010JConsole.t new file mode 100644 index 0000000..532cf47 --- /dev/null +++ b/t/010JConsole.t @@ -0,0 +1,93 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use Log::Log4perl::Appender::File; +use File::Spec; +use Test::More; + +our $LOG_DISPATCH_PRESENT = 0; + +BEGIN { + eval { require Log::Dispatch; }; + if($@) { + plan skip_all => "only with Log::Dispatch"; + } else { + $LOG_DISPATCH_PRESENT = 1; + plan tests => 1; + } +}; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +use vars qw(@outfiles $test_logfile); +$test_logfile = File::Spec->catfile($WORK_DIR,'test1.log'); +@outfiles = ($test_logfile,); +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + + +my $conf = <<CONF; +log4j.category.cat1 = INFO, myAppender + +log4j.appender.myAppender=org.apache.log4j.ConsoleAppender +log4j.appender.myAppender.Target=System.out +log4j.appender.myAppender.layout=org.apache.log4j.PatternLayout +log4j.appender.myAppender.layout.ConversionPattern=%-5p %c - %m%n +CONF + +Log::Log4perl->init(\$conf); + +my $logger = Log::Log4perl->get_logger('cat1'); + +#hmm, I wonder how portable this is, maybe check $^O first? +use vars qw($OLDOUT); #for -w +open(OLDOUT, ">&STDOUT"); +open (TOUCH, ">>$test_logfile");# `touch $test_logfile`; +close TOUCH; +open(STDOUT, ">$test_logfile") || die "Can't redirect stdout $test_logfile $!"; +select(STDOUT); $| = 1; # make unbuffered + + + +$logger->debug("debugging message 1 "); +$logger->info("info message 1 "); +$logger->warn("warning message 1 "); +$logger->fatal("fatal message 1 "); + + +close(STDOUT); +open(STDOUT, ">&OLDOUT"); + + +my ($result, $expected); + +$expected = <<EOL; +INFO cat1 - info message 1 +WARN cat1 - warning message 1 +FATAL cat1 - fatal message 1 +EOL + +{local $/ = undef; + open (F, "$test_logfile") || die $!; + $result = <F>; + close F; +} +is ($result, $expected); + +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + diff --git a/t/011JFile.t b/t/011JFile.t new file mode 100644 index 0000000..869102a --- /dev/null +++ b/t/011JFile.t @@ -0,0 +1,77 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test::More; +use File::Spec; + +our $LOG_DISPATCH_PRESENT = 0; + +BEGIN { + eval { require Log::Dispatch; }; + if($@) { + plan skip_all => "only with Log::Dispatch"; + } else { + $LOG_DISPATCH_PRESENT = 1; + plan tests => 1; + } +}; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +use vars qw(@outfiles $test_logfile); +$test_logfile = File::Spec->catfile($WORK_DIR, 'test2.log'); +@outfiles = ($test_logfile); +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + + +my $conf = <<CONF; +log4j.category.cat1 = INFO, myAppender + +log4j.appender.myAppender=org.apache.log4j.FileAppender +log4j.appender.myAppender.File=$test_logfile +log4j.appender.myAppender.layout=org.apache.log4j.PatternLayout +log4j.appender.myAppender.layout.ConversionPattern=%-5p %c - %m%n +CONF + +Log::Log4perl->init(\$conf); + +my $logger = Log::Log4perl->get_logger('cat1'); + +$logger->debug("debugging message 1 "); +$logger->info("info message 1 "); +$logger->warn("warning message 1 "); +$logger->fatal("fatal message 1 "); + + +my ($result, $expected); + +$expected = <<EOL; +INFO cat1 - info message 1 +WARN cat1 - warning message 1 +FATAL cat1 - fatal message 1 +EOL + +{local $/ = undef; + open (F, "$test_logfile") || die $!; + $result = <F>; + close F; +} +is ($result, $expected); + +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + diff --git a/t/012Deeper.t b/t/012Deeper.t new file mode 100644 index 0000000..a3a9557 --- /dev/null +++ b/t/012Deeper.t @@ -0,0 +1,212 @@ +# Before `make install' is performed this script should be runnable with +# `make test'. After `make install' it should work as `perl test.pl' + + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test::More; +use File::Spec; + +our $LOG_DISPATCH_PRESENT = 0; + +BEGIN { + eval { require Log::Dispatch; }; + if($@) { + plan skip_all => "only with Log::Dispatch"; + } else { + $LOG_DISPATCH_PRESENT = 1; + plan tests => 3; + } +}; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time); +my $today = sprintf("%4.4d%2.2d%2.2d",$year+1900, $mon+1, $mday); +use vars qw($logfile1 $logfile6 $logfile7); +$logfile1 = File::Spec->catfile(qw(t tmp deeper1.log)); +$logfile6 = File::Spec->catfile(qw(t tmp deeper6.log)); +$logfile7 = File::Spec->catfile(qw(t tmp deeper7.log)); +our @outfiles = ($logfile1, $logfile6, $logfile7); + +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + + +my $config = <<EOL; +#specify LOGLEVEL, appender1, appender2, ... +log4j.category.plant = INFO, FileAppndr1 +log4j.category.animal = INFO, FileAppndr1 +log4j.category.animal.dog = DEBUG, FileAppndr1 + +log4j.oneMessagePerAppender = 1 + + +# --------------------------------------------- +# FileAppndr1 +log4j.appender.FileAppndr1 = org.apache.log4j.FileAppender +log4j.appender.FileAppndr1.File = $logfile1 + +log4j.appender.FileAppndr1.layout = org.apache.log4j.PatternLayout +log4j.appender.FileAppndr1.layout.ConversionPattern=%d %4r [%t] %-5p %c %t - %m%n + + +# --------------------------------------------------- +#2nd set of tests,inheritance +log4j.category.a = INFO, l2 +log4j.category.a.b.c.d = WARN, l2 + +log4j.appender.l2 = org.apache.log4j.FileAppender +log4j.appender.l2.File = $logfile6 +log4j.appender.l2.layout = org.apache.log4j.PatternLayout +log4j.appender.l2.layout.ConversionPattern=%d %4r [%t] %-5p %c - %m%n + + +# -------------------------------------- +#inheritance the other way +log4j.category.xa = WARN, l3 +log4j.category.xa.b.c.d = INFO, l3 + +log4j.appender.l3 = org.apache.log4j.FileAppender +log4j.appender.l3.File = $logfile7 +log4j.appender.l3.layout= org.apache.log4j.PatternLayout +log4j.appender.l3.layout.ConversionPattern=%d %4r 666 [%t] %-5p %c - %m%n + +EOL + + +Log::Log4perl->init(\$config); + + +# ----------------------------------------------------- +# (1) shotgun test +#set to INFO + +my $logger = Log::Log4perl->get_logger('plant'); + +#set to INFO +$logger->debug("debugging message 1 "); +$logger->info("info message 1 "); +$logger->warn("warning message 1 "); +$logger->fatal("fatal message 1 "); + +#set to DEBUG +my $doglogger = Log::Log4perl->get_logger('animal.dog'); +$doglogger->debug("debugging message 2 "); +$doglogger->info("info message 2 "); +$doglogger->warn("warning message 2 "); +$doglogger->fatal("fatal message 2 "); + +#set to INFO +my $animallogger = Log::Log4perl->get_logger('animal'); +$animallogger->debug("debugging message 3 "); +$animallogger->info("info message 3 "); +$animallogger->warn("warning message 3 "); +$animallogger->fatal("fatal message 3 "); + +#should default to animal::dog +my $deeptreelogger = Log::Log4perl->get_logger('animal.dog.leg.toenail'); +$deeptreelogger->debug("debug message"); +$animallogger->info("info message"); +$deeptreelogger->warn("warning message"); +$animallogger->fatal("fatal message"); + +my ($result, $expected); + +{local $/ = undef; + open (F, File::Spec->catfile(qw(t deeper1.expected))) || die $!; + $expected = <F>; + open (F, $logfile1) || die $!; + $result = <F>; + close F; + $result =~ s/.+?] //g; +} + +is ($result, $expected); + + +# ------------------------------------ +# (6) test inheritance +#a=INFO, a.b.c.d=WARN, a.b and a.b.c are undefined +my $la = Log::Log4perl->get_logger('a'); +my $lab = Log::Log4perl->get_logger('a.b'); +my $labc = Log::Log4perl->get_logger('a.b.c'); +my $labcd = Log::Log4perl->get_logger('a.b.c.d'); +my $labcde = Log::Log4perl->get_logger('a.b.c.d.e'); + +foreach my $l ($la, $lab, $labc, $labcd, $labcde){ + $l->debug("should not print"); +} +foreach my $l ($la, $lab, $labc, $labcd, $labcde){ + $l->info("should print for a, a.b, a.b.c"); +} +foreach my $l ($la, $lab, $labc, $labcd, $labcde){ + $l->warn("should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e"); +} +foreach my $l ($la, $lab, $labc, $labcd, $labcde){ + $l->fatal("should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e"); +} +{local $/ = undef; + open (F, File::Spec->catfile(qw(t deeper6.expected))); + $expected = <F>; + open (F, $logfile6); + $result = <F>; + close F; + $result =~ s/.+?] //g; +} + +is($result, $expected); + + +# ------------------------------------ +# (7) test inheritance the other way +#xa=WARN, xa.b.c.d=INFO, xa.b and xa.b.c are undefined +my $xla = Log::Log4perl->get_logger('xa'); +my $xlab = Log::Log4perl->get_logger('xa.b'); +my $xlabc = Log::Log4perl->get_logger('xa.b.c'); +my $xlabcd = Log::Log4perl->get_logger('xa.b.c.d'); +my $xlabcde = Log::Log4perl->get_logger('xa.b.c.d.e'); + +foreach my $l ($xla, $xlab, $xlabc, $xlabcd, $xlabcde){ + $l->debug("should not print"); +} +foreach my $l ($xla, $xlab, $xlabc, $xlabcd, $xlabcde){ + $l->info("should print for xa.b.c.d, xa.b.c.d.e"); +} +foreach my $l ($xla, $xlab, $xlabc, $xlabcd, $xlabcde){ + $l->warn("should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e"); +} +foreach my $l ($xla, $xlab, $xlabc, $xlabcd, $xlabcde){ + $l->fatal("should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e"); +} +{local $/ = undef; + open (F, File::Spec->catfile(qw(t deeper7.expected))); + $expected = <F>; + open (F, $logfile7); + $result = <F>; + close F; + $result =~ s/.+?] //g; +} + +is($result, $expected); + + + +END{ + foreach my $f (@outfiles){ + unlink $f if (-e $f); + } +} diff --git a/t/013Bench.t b/t/013Bench.t new file mode 100644 index 0000000..a37267a --- /dev/null +++ b/t/013Bench.t @@ -0,0 +1,144 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test; +use Benchmark qw/timeit timestr/; +use Log::Log4perl; + +$count = 100_000; + +unless ($ENV{LOG4PERL_BENCH}) { + print "set \$ENV{LOG4PERL_BENCH} to a true value to run benchmarks, skipping...\n"; + ok(1); + exit; +} + +$conf = <<EOL; + +#specify LOGLEVEL, appender1, appender2, ... +log4j.category.simplelayout = INFO, simpleLayoutAppndr + +log4j.category.patternlayout = INFO, PatternLayoutAppndr + +log4j.category.multiappender = INFO, PatternLayoutAppndr, 2ndPatternLayoutAppndr, +log4j.category.multiappender.c1 = INFO, 3rdPatternLayoutAppndr +log4j.category.multiappender.c1.c2 = INFO, 2ndPatternLayoutAppndr + + + +# --------------------------------------------- +# PatternLayoutAppndr +log4j.appender.PatternLayoutAppndr = Log::Log4perl::Appender::TestBuffer +log4j.appender.PatternLayoutAppndr.layout = org.apache.log4j.PatternLayout +log4j.appender.PatternLayoutAppndr.layout.ConversionPattern=%d %4r [%t] %-5p %c %t - %m%n + +# --------------------------------------------- +# 2ndPatternLayoutAppndr +log4j.appender.2ndPatternLayoutAppndr = Log::Log4perl::Appender::TestBuffer +log4j.appender.2ndPatternLayoutAppndr.layout = org.apache.log4j.PatternLayout +log4j.appender.2ndPatternLayoutAppndr.layout.ConversionPattern=%d %4r [%t] %-5p %c %t - %m%n + +# --------------------------------------------- +# 3rdPatternLayoutAppndr +log4j.appender.3rdPatternLayoutAppndr = Log::Log4perl::Appender::TestBuffer +log4j.appender.3rdPatternLayoutAppndr.layout = org.apache.log4j.PatternLayout +log4j.appender.3rdPatternLayoutAppndr.layout.ConversionPattern=%d %4r [%t] %-5p %c %t - %m%n + + +# --------------------------------------------- +# a SimpleLayout +log4j.appender.simpleLayoutAppndr = Log::Log4perl::Appender::TestBuffer +log4j.appender.simpleLayoutAppndr.layout = org.apache.log4j.SimpleLayout + + + + +EOL + +Log::Log4perl::init(\$conf); + +$simplelayout = Log::Log4perl->get_logger('simplelayout'); + +$basecategory = Log::Log4perl->get_logger('patternlayout'); + +$firstlevelcategory = Log::Log4perl->get_logger('patternlayout.foo'); + +$secondlevelcategory = Log::Log4perl->get_logger('patternlayout.foo.bar'); + +print "Iterations: $count\n\n"; + + +print "Just is_debug/info/warn/error/fatal() methods: \n"; +$t = timeit $count, sub{my $v = $basecategory->is_debug(); + $v = $basecategory->is_info(); + $v = $basecategory->is_warn(); + $v = $basecategory->is_error(); + $v = $basecategory->is_fatal(); + }; +print timestr($t),"\n\n"; + +print "no logging: \n"; +$t = timeit $count, sub{$basecategory->debug('debug message')}; +print timestr($t),"\n\n"; + +print "a simple layout: \n"; +$t = timeit $count, sub{$simplelayout->info('info message')}; +print timestr($t),"\n\n"; + +print "pattern layout: \n"; +$t = timeit $count, sub {$basecategory->info('info message')}; +print timestr($t),"\n\n"; + +print "one level inheritance, no logging: \n"; +$t = timeit $count, sub {$firstlevelcategory->debug('debug message')}; +print timestr($t),"\n\n"; + +print "one level inheritance, logging: \n"; +$t = timeit $count, sub {$firstlevelcategory->info('info message')}; +print timestr($t),"\n\n"; + +print "two level inheritance, no logging: \n"; +$t = timeit $count, sub {$secondlevelcategory->debug('debug message')}; +print timestr($t),"\n\n"; + +print "two level inheritance, logging \n"; +$t = timeit $count, sub {$secondlevelcategory->info('info message')}; +print timestr($t),"\n\n"; + +#free up some memory? +undef($basecategory); +undef ($firstlevelcategory); +undef($secondlevelcategory); + + +$multi1 = Log::Log4perl->get_logger('multiappender'); +$multi2 = Log::Log4perl->get_logger('multiappender.c1'); +$multi3 = Log::Log4perl->get_logger('multiappender.c1.c2'); + +print "two appenders: \n"; +$t = timeit $count, sub {$multi1->info('info message')}; +print timestr($t),"\n\n"; + +print "three appenders, one level of inheritance: \n"; +$t = timeit $count, sub {$multi2->info('info message')}; +print timestr($t),"\n\n"; + +print "same appenders, two levels of inheritance: \n"; +$t = timeit $count, sub {$multi3->info('info message')}; +print timestr($t),"\n\n"; + + + + + + +print + + +ok(1); + +BEGIN { plan tests => 1, } diff --git a/t/014ConfErrs.t b/t/014ConfErrs.t new file mode 100644 index 0000000..2e431d0 --- /dev/null +++ b/t/014ConfErrs.t @@ -0,0 +1,252 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test::More; + +$testfile = 't/tmp/test12.log'; + +unlink $testfile if (-e $testfile); + +# ***************************************************** +# nonexistent appender class +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::FileAppenderx +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; +like($@, qr/ERROR: can't load appenderclass 'Log::Log4perl::Appender::FileAppenderx'/); + + +# ***************************************************** +# nonexistent layout class +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayoutx +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; +like($@, qr/ERROR: trying to set layout for myAppender to 'Log::Log4perl::Layout::SimpleLayoutx' failed/); + +# ***************************************************** +# nonexistent appender class containing a ';' +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer; +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; +like($@, qr/ERROR: can't load appenderclass 'Log::Log4perl::Appender::TestBuffer;'/); + +# ***************************************************** +# nonexistent layout class containing a ';' +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout; +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; +like($@, qr/trying to set layout for myAppender to 'Log::Log4perl::Layout::SimpleLayout;' failed/); + +# ***************************************************** +# Relative Layout class +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; + # It's supposed to find it. +is($@, '', 'relative layout class'); + +# ***************************************************** +# bad priority +$conf = <<EOL; +log4j.category.simplelayout.test=xxINFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::File +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); + +}; +like($@, qr/level 'xxINFO' is not a valid error level/); + +# ***************************************************** +# nonsense conf file 1 +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::Screen +log4j.appender.myAppender.nolayout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); +}; +like($@, qr/Layout not specified for appender myAppender at/, + "nonsense conf file 1"); + +# ***************************************************** +# nonsense conf file 2 +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::FileAppender +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender = $testfile +EOL + +eval{ + + Log::Log4perl->init(\$conf); + +}; +like($@, qr/log4j.appender.myAppender redefined/); + + + +# ***************************************************** +# never define an appender +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, XXmyAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); + +}; +like($@, + qr/ERROR: you didn't tell me how to implement your appender 'XXmyAppender'/); + + +# ***************************************************** +# never define a layout +$conf = <<EOL; +log4j.category.simplelayout.test=INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer + +EOL + +eval{ + Log::Log4perl->init(\$conf); + +}; +like($@, qr/Layout not specified for appender myAppender/, 'no layout defined'); + + +# ************************************ +# check continuation chars, this should parse fine +$conf = <<EOL; +log4j.category.simplelayout.test=\\ + INFO, \\ + myAppender + +log4j.appender.myAppender \\ + = Log::Log4perl::Appender::TestBuffer + #this is stupid, I know +log4j.appender.myAppender.layout = Log::Log4perl::Lay\\ + out::SimpleL\\ + ayout +log4j.appender.myAppender.File = $testfile +EOL + +eval{ + Log::Log4perl->init(\$conf); + +}; +is($@,""); + +# ***************************************************** +# init_once +# ***************************************************** +Log::Log4perl->reset(); +$conf = <<EOL; +log4perl.category = INFO, myAppender + +log4perl.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4perl.appender.myAppender.layout = SimpleLayout +EOL + +Log::Log4perl->init_once(\$conf); +my $logger = Log::Log4perl::get_logger(""); +$logger->error("foobar"); +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +#print "BUFFER: [", $buffer->buffer(), "]\n"; +is($buffer->buffer(),"ERROR - foobar\n"); + +$conf = <<EOL; +log4perl.category = FATAL, myAppender + +log4perl.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4perl.appender.myAppender.layout = SimpleLayout +EOL + + # change config, call init_once(), which should ignore the new + # settings. +$buffer->buffer(""); +Log::Log4perl->init_once(\$conf); +$logger = Log::Log4perl::get_logger(""); +$logger->error("foobar"); +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +#print "BUFFER: [", $buffer->buffer(), "]\n"; +is($buffer->buffer(),"ERROR - foobar\n"); + +$conf = <<EOL; +log4perl.logger.Foo.Bar = INFO, Screen +log4perl.logger.Foo.Bar = INFO, Screen +log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Screen.layout = SimpleLayout +EOL +eval { + Log::Log4perl::init( \$conf ); +}; +like($@, qr/log4perl.logger.Foo.Bar redefined/); + +BEGIN { plan tests => 14, } + +END{ + unlink $testfile if (-e $testfile); +} + diff --git a/t/015fltmsg.t b/t/015fltmsg.t new file mode 100644 index 0000000..928403f --- /dev/null +++ b/t/015fltmsg.t @@ -0,0 +1,120 @@ +########################################### +# Test Suite for Log::Log4perl +# warp_message cases +# Mike Schilli, 2003 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test::More tests => 5; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +###################################################################### +# warp_message undef: Concatenation +###################################################################### +Log::Log4perl->init( \ <<EOT ); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%m%n +EOT + +my $app = Log::Log4perl::Appender::TestBuffer->by_name("A1"); +my $logger = Log::Log4perl->get_logger(""); +$logger->debug("Chunk1", "Chunk2", "Chunk3"); + +is($app->buffer(), "Chunk1Chunk2Chunk3\n", "warp_message undef"); + +###################################################################### +# warp_message undef: Concatenation plus JOIN_MSG_ARRAY_CHAR +###################################################################### +Log::Log4perl->init( \ <<EOT ); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%m%n +EOT + +$Log::Log4perl::JOIN_MSG_ARRAY_CHAR = "bang!"; + +$app = Log::Log4perl::Appender::TestBuffer->by_name("A1"); +$logger = Log::Log4perl->get_logger(""); +$logger->debug("Chunk1", "Chunk2", "Chunk3"); + +is($app->buffer(), "Chunk1bang!Chunk2bang!Chunk3\n", + "warp_message undef (JOIN_MSG_ARRAY_CHAR)"); + +$Log::Log4perl::JOIN_MSG_ARRAY_CHAR = ""; # back to default + +###################################################################### +# warp_message 0 +###################################################################### +Log::Log4perl->init( \ <<EOT ); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestArrayBuffer + log4perl.appender.A1.layout=NoopLayout + log4perl.appender.A1.warp_message=0 +EOT + +$app = Log::Log4perl::Appender::TestArrayBuffer->by_name("A1"); +$logger = Log::Log4perl->get_logger(""); +$logger->debug("Chunk1", "Chunk2", "Chunk3"); + +is($app->buffer(), "[Chunk1,Chunk2,Chunk3]", + "warp_message 0 (NoopLayout)"); + +###################################################################### +# warp_message = code ref +###################################################################### +Log::Log4perl->init( \ <<'EOT' ); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestArrayBuffer + log4perl.appender.A1.layout=NoopLayout + log4perl.appender.A1.warp_message = sub { $#_ = 2 if @_ > 3; \ + return @_; } +EOT + +$app = Log::Log4perl::Appender::TestArrayBuffer->by_name("A1"); +$logger = Log::Log4perl->get_logger(""); +$logger->debug("Chunk1", "Chunk2", "Chunk3", "Chunk4"); + +is($app->buffer(), "[Chunk1,Chunk2,Chunk3]", + "warp_message = function (by cref)"); + + +###################################################################### +# warp_message = function +###################################################################### +my $COUNTER = 0; +sub warp_my_message { + my @chunks = @_; + unshift @chunks, ++$COUNTER; + return @chunks; +} + +Log::Log4perl->init( \ <<'EOT' ); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestArrayBuffer + log4perl.appender.A1.layout=NoopLayout + log4perl.appender.A1.warp_message = main::warp_my_message +EOT + +$app = Log::Log4perl::Appender::TestArrayBuffer->by_name("A1"); +$logger = Log::Log4perl->get_logger(""); +$logger->debug("Chunk1", "Chunk2", "Chunk3"); + +is($app->buffer(), "[1,Chunk1,Chunk2,Chunk3]", + "warp_message = function (by name)"); diff --git a/t/016Export.t b/t/016Export.t new file mode 100644 index 0000000..89fa5da --- /dev/null +++ b/t/016Export.t @@ -0,0 +1,140 @@ +########################################### +# Test Suite for Log::Log4perl +# Test all shortcuts (exported symbols) +# +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; +use Log::Log4perl::Appender::TestBuffer; + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +BEGIN { plan tests => 16 }; + +use Log::Log4perl qw(get_logger :levels); + +ok(1); + +ok(Log::Log4perl::Level::isGreaterOrEqual($DEBUG, $ERROR)); +ok(Log::Log4perl::Level::isGreaterOrEqual($INFO, $WARN)); +ok(Log::Log4perl::Level::isGreaterOrEqual($WARN, $ERROR)); +ok(Log::Log4perl::Level::isGreaterOrEqual($ERROR, $FATAL)); + +################################################## +# Init logger +################################################## +my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer", + name => "A1"); +my $logger = get_logger("abc.def"); +$logger->add_appender($app); +$logger->level($DEBUG); + + # Let the next logger assume the default category, + # which defaults to the current package, which + # is 'main' in this case. +my $logger_main = get_logger(); +$logger_main->add_appender($app); +$logger_main->level($DEBUG); +ok(2); + +################################################## +# Use logger +################################################## +my $log2 = get_logger("abc.def"); +$log2->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use other logger +################################################## +my $log3 = get_logger("main"); +$log3->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use main logger +################################################## +my $log4 = get_logger("main"); +$log4->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use other logger +################################################## +my $log5 = get_logger("main"); +$log5->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use default-main logger +################################################## +my $log6 = get_logger(); +$log6->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use default-main logger +################################################## +my $log7 = Log::Log4perl->get_logger(); +$log7->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Use default-main logger +################################################## +my $log8 = Log::Log4perl::get_logger(); +$log8->debug("Is this it?"); + +ok($app->buffer(), "DEBUG - Is this it?\n"); +$app->buffer(""); + +################################################## +# Remove appender +################################################## +$logger->remove_appender("A1"); +$logger_main->remove_appender("A1"); +$log8->debug("Is this it?"); + +$app = Log::Log4perl->appenders()->{"A1"}; + +ok($app->buffer(), ""); +$app->buffer(""); + +################################################## +# Eradicate appender +################################################## +$Log::Log4perl::Appender::TestBuffer::DESTROY_MESSAGE = ""; +Log::Log4perl->eradicate_appender("A1"); +ok($Log::Log4perl::Appender::TestBuffer::DESTROY_MESSAGE, "", + "destroy message before"); + +undef $app; + # Special for TestBuffer: remove circ ref +delete ${Log::Log4perl::Appender::TestBuffer::POPULATION}{A1}; + +ok($Log::Log4perl::Appender::TestBuffer::DESTROY_MESSAGES, + "Log::Log4perl::Appender::TestBuffer destroyed", + "destroy message after destruction"); diff --git a/t/017Watch.t b/t/017Watch.t new file mode 100644 index 0000000..beffdb3 --- /dev/null +++ b/t/017Watch.t @@ -0,0 +1,391 @@ +#testing init_and_watch + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; + +use warnings; +use strict; + +use Log::Log4perl; +use File::Spec; + +sub trunc { + open FILE, ">$_[0]" or die "Cannot open $_[0]"; + close FILE; +} + +sub is_like_windows { + if( $^O eq "MSWin32" or + $^O eq "cygwin" ) { + return 1; + } + + return 0; +} + +BEGIN { + if ($] < 5.006) { + plan skip_all => "Only with perl >= 5.006"; + } else { + plan tests => 34; + } +} + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} + +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $testfile = File::Spec->catfile($WORK_DIR, "test17.log"); +my $testfile2 = File::Spec->catfile($WORK_DIR, "test17b.log"); +my $testconf = File::Spec->catfile($WORK_DIR, "test17.conf"); + +END { + unlink $testfile if (-e $testfile); + unlink $testfile2 if (-e $testfile2); + unlink $testconf if (-e $testconf); + rmdir $WORK_DIR; +} + +trunc($testfile); +trunc($testconf); + +my $conf1 = <<EOL; +log4j.category.animal.dog = INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::File +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.filename = $testfile +log4j.appender.myAppender.mode = append + +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf1; +close CONF; + +Log::Log4perl->init_and_watch($testconf, 1); + +my $logger = Log::Log4perl::get_logger('animal.dog'); + +$logger->debug('debug message'); +$logger->info('info message'); + +ok(! $logger->is_debug(), "is_debug - true"); +ok( $logger->is_info(), "is_info - true"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +# ********************************************************************* +# Check if we really dont re-read the conf file if nothing has changed +# ********************************************************************* + +my $how_many_reads = $Log::Log4perl::Config::CONFIG_FILE_READS; +print "sleeping for 2 secs\n"; +sleep 2; +$logger->is_debug(); +is($how_many_reads, $Log::Log4perl::Config::CONFIG_FILE_READS, + "no re-read until config has changed"); + + # Need to sleep for at least a sec, otherwise the watcher + # wont check +print "sleeping for 2 secs\n"; +sleep 2; + +# ********************************************************************* +# Now, lets check what happens if the config changes +# ********************************************************************* + +my $conf2 = <<EOL; +log4j.category.animal.dog = DEBUG, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::File +log4j.appender.myAppender.layout = org.apache.log4j.PatternLayout +log4j.appender.myAppender.layout.ConversionPattern=%-5p %c - %m%n + +log4j.appender.myAppender.filename = $testfile +log4j.appender.myAppender.mode = append +EOL + +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf2; +close CONF; + +$logger = Log::Log4perl::get_logger('animal.dog'); + +$logger->debug('2nd debug message'); +is($Log::Log4perl::Config::CONFIG_FILE_READS, + $how_many_reads + 1, + "re-read if config has changed, even if no logger has fired"); + +$logger->info('2nd info message'); +print "sleeping for 2 secs\n"; +sleep 2; +$logger->info('2nd info message again'); + +is($Log::Log4perl::Config::CONFIG_FILE_READS, + $how_many_reads + 1, + "no re-read unless config has changed"); + +open (LOG, $testfile) or die "can't open $testfile $!"; +my @log = <LOG>; +close LOG; +my $log = join('',@log); + +is($log, "INFO - info message\nDEBUG animal.dog - 2nd debug message\nINFO animal.dog - 2nd info message\nINFO animal.dog - 2nd info message again\n", "1st init"); +ok( $logger->is_debug(), "is_debug - false"); +ok( $logger->is_info(), "is_info - true"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +# *************************************************************** +# do it 3rd time + +print "sleeping for 2 secs\n"; +sleep 2; + +$conf2 = <<EOL; +log4j.category.animal.dog = INFO, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::File +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.filename = $testfile +log4j.appender.myAppender.mode = append +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf2; +close CONF; + +$logger = Log::Log4perl::get_logger('animal.dog'); + +$logger->debug('2nd debug message'); +$logger->info('3rd info message'); + +ok(! $logger->is_debug(), "is_debug - false"); +ok( $logger->is_info(), "is_info - true"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +open (LOG, $testfile) or die "can't open $testfile $!"; +@log = <LOG>; +close LOG; +$log = join('',@log); + +is($log, "INFO - info message\nDEBUG animal.dog - 2nd debug message\nINFO animal.dog - 2nd info message\nINFO animal.dog - 2nd info message again\nINFO - 3rd info message\n", "after reload"); + +SKIP: { + skip "Signal handling not supported on Win32", 2 if is_like_windows(); + # *************************************************************** + # Check the 'recreate' feature + + trunc($testfile); + my $conf4 = <<EOL; + log4j.category.animal.dog = INFO, myAppender + + log4j.appender.myAppender = Log::Log4perl::Appender::File + log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender.filename = $testfile + log4j.appender.myAppender.recreate = 1 + log4j.appender.myAppender.recreate_check_interval = 0 + log4j.appender.myAppender.mode = append +EOL + + Log::Log4perl->init(\$conf4); + + $logger = Log::Log4perl::get_logger('animal.dog'); + $logger->info("test1"); + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar <LOG>, "INFO - test1\n", "Before recreate"); + close LOG; + + unlink $testfile or die "Cannot unlink $testfile: $!"; + $logger->info("test2"); + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar <LOG>, "INFO - test2\n", "After recreate"); + close LOG; + + trunc($testfile); + trunc($testconf); +}; + + +# *************************************************************** +# Check the 'recreate' feature with signal handling + +SKIP: { + skip "File recreation not supported on Win32", 9 if is_like_windows(); + + # Use two appenders to confirm that both files are recreated when the + # signal is received, rather than just whichever watcher was created + # last. + + my $conf5 = <<EOL; + log4j.category.animal.dog = INFO, myAppender1 + log4j.category.animal.cat = INFO, myAppender2 + + log4j.appender.myAppender1 = Log::Log4perl::Appender::File + log4j.appender.myAppender1.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender1.filename = $testfile + log4j.appender.myAppender1.recreate = 1 + log4j.appender.myAppender1.recreate_check_signal = USR1 + + log4j.appender.myAppender2 = Log::Log4perl::Appender::File + log4j.appender.myAppender2.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender2.filename = $testfile2 + log4j.appender.myAppender2.recreate = 1 + log4j.appender.myAppender2.recreate_check_signal = USR1 +EOL + + Log::Log4perl->init(\$conf5); + + my $logger = Log::Log4perl::get_logger('animal.dog'); + $logger->info("test1"); + ok(-f $testfile, "recreate_signal - testfile created"); + + my $logger2 = Log::Log4perl::get_logger('animal.cat'); + $logger2->info("test1"); + ok(-f $testfile2, "recreate_signal - testfile created"); + + + unlink $testfile, $testfile2; + ok(!-f $testfile, "recreate_signal - testfile deleted"); + ok(!-f $testfile2, "recreate_signal - testfile2 deleted"); + + $logger->info("test1"); + $logger2->info("test1"); + ok(!-f $testfile, "recreate_signal - testfile still missing"); + ok(!-f $testfile2, "recreate_signal - testfile2 still missing"); + + ok(kill('USR1', $$), "sending signal"); + $logger->info("test1"); + $logger2->info("test1"); + ok(-f $testfile, "recreate_signal - testfile reinstated"); + ok(-f $testfile2, "recreate_signal - testfile2 reinstated"); +}; + + +SKIP: { + skip "Removing busy files not supported on Win32", 1 if is_like_windows(); + + # *************************************************************** + # Check the 'recreate' feature with check_interval + + trunc($testfile); + my $conf3 = <<EOL; + log4j.category.animal.dog = INFO, myAppender + + log4j.appender.myAppender = Log::Log4perl::Appender::File + log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender.filename = $testfile + log4j.appender.myAppender.recreate = 1 + log4j.appender.myAppender.recreate_check_interval = 1 + log4j.appender.myAppender.mode = append +EOL + + # Create logfile + Log::Log4perl->init(\$conf3); + # ... and immediately remove it + unlink $testfile or die "cannot remove file $testfile ($!)"; + + print "sleeping for 2 secs\n"; + sleep(2); + + $logger = Log::Log4perl::get_logger('animal.dog'); + $logger->info("test1"); + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar <LOG>, "INFO - test1\n", "recreate before first write"); + close LOG; +} + +# *************************************************************** +# Check the 'recreate' feature with check_interval (2nd write) + +SKIP: { + skip "Signal handling not supported on Win32", 1 if is_like_windows(); + trunc($testfile); + my $conf3 = <<EOL; + log4j.category.animal.dog = INFO, myAppender + + log4j.appender.myAppender = Log::Log4perl::Appender::File + log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender.filename = $testfile + log4j.appender.myAppender.recreate = 1 + log4j.appender.myAppender.recreate_check_interval = 1 + log4j.appender.myAppender.mode = append +EOL + + # Create logfile + Log::Log4perl->init(\$conf3); + + # Write to it + $logger = Log::Log4perl::get_logger('animal.dog'); + $logger->info("test1"); + + # ... remove it (stupid windoze cannot remove an open file) + rename $testfile, "$testfile.old"; + unlink $testfile; + + print "sleeping for 2 secs\n"; + sleep(2); + + # ... write again + $logger->info("test2"); + + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar <LOG>, "INFO - test2\n", "recreate before 2nd write"); + close LOG; + unlink "$testfile.old"; +}; + +# *************************************************************** +# Check the 'recreate' feature with moved/recreated file + +SKIP: { + skip "Moving busy files not supported on Win32", 1 if is_like_windows(); + + trunc($testfile); + my $conf3 = <<EOL; + log4j.category.animal.dog = INFO, myAppender + + log4j.appender.myAppender = Log::Log4perl::Appender::File + log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.myAppender.filename = $testfile + log4j.appender.myAppender.recreate = 1 + log4j.appender.myAppender.recreate_check_interval = 1 + log4j.appender.myAppender.mode = append +EOL + + # Create logfile + Log::Log4perl->init(\$conf3); + + # Get a logger, but dont write to it + $logger = Log::Log4perl::get_logger('animal.dog'); + + rename "$testfile", "$testfile.old" or die "Cannot rename ($!)"; + # recreate it + trunc($testfile); + + print "sleeping for 2 secs\n"; + sleep(2); + + # ... write to (hopefully) truncated file + $logger->info("test3"); + + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar <LOG>, "INFO - test3\n", "log to externally recreated file"); + close LOG; + + unlink "$testfile.old"; +}; diff --git a/t/018Init.t b/t/018Init.t new file mode 100644 index 0000000..3c5e23f --- /dev/null +++ b/t/018Init.t @@ -0,0 +1,70 @@ +#Testing double-init + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test; + +use warnings; +use strict; + +use Log::Log4perl; +use File::Spec; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $testfilea = File::Spec->catfile(qw(t tmp test18a.log)); +unlink $testfilea if (-e $testfilea); + +my $testfileb = File::Spec->catfile(qw(t tmp test18b.log)); +unlink $testfileb if (-e $testfileb); + +BEGIN {plan tests => 2} +END { unlink $testfilea; + unlink $testfileb; + } + +#################################################### +# Double-Init, 2nd time with different log file name +#################################################### +my $data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testfilea +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +my $log = Log::Log4perl::get_logger(""); + +$log->info("Shu-wa-chi!"); + +$data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testfileb +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(); + +$log->info("Shu-wa-chi!"); + +# Check if both files contain one message each +for my $file ($testfilea, $testfileb) { + open FILE, "<$file" or die "Cannot open $file"; + my $content = join '', <FILE>; + close FILE; + ok($content, "INFO - Shu-wa-chi!\n"); +} diff --git a/t/019Warn.t b/t/019Warn.t new file mode 100644 index 0000000..d710140 --- /dev/null +++ b/t/019Warn.t @@ -0,0 +1,75 @@ +# Check if warnings are issued for weirdo configurations + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test; +use Log::Log4perl; +use File::Spec; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $TMP_FILE = File::Spec->catfile(qw(t tmp warnings)); +$TMP_FILE = "tmp/warnings" if ! -d "t"; + +BEGIN { plan tests => 2 } +END { close IN; + unlink $TMP_FILE; + } + +ok(1); # Initialized ok + +# Capture STDERR to a temporary file and a filehandle to read from it +open STDERR, ">$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; +sub readwarn { return scalar <IN>; } + +############################################################ +# Get a logger and use it without having called init() first +############################################################ +my $log = Log::Log4perl::get_logger("abc.def"); +$log->debug("hey there"); + +my $warn = readwarn(); +#print "'$warn'\n"; + +ok($warn, 'm#Forgot#'); + +__END__ + +############################################################ +# Check for single \'s on line ends -- they need to be +# \\ for perl to recognize it. But how? Perl swallows it. +############################################################ +my $conf = <<EOL; +log4j.rootLogger=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%-4r [%t] %-5p %c %t - %m%n +log4j.category.simplelayout.test=INFO, \ + myAppender +log4j.appender.myAppender = Log::Log4perl::Appender::FileAppenderx +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.myAppender.File = abc +EOL + +Log::Log4perl->init(\$conf); + +my $err = readwarn(); + +ok($err, 'm#single \\#i'); + +print "$conf\n"; diff --git a/t/020Easy.t b/t/020Easy.t new file mode 100644 index 0000000..5b61f5a --- /dev/null +++ b/t/020Easy.t @@ -0,0 +1,235 @@ +# Tests for the lazy man:s logger with easy_init() + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +use Log::Log4perl qw(:easy); +use File::Spec; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $TMP_FILE = File::Spec->catfile(qw(t tmp easy)); +$TMP_FILE = "tmp/easy" if ! -d "t"; + +BEGIN { + if ($] < 5.006) { + plan skip_all => "Only with perl >= 5.006"; + } else { + plan tests => 21; + } +} + +END { unlink $TMP_FILE; + close IN; + } + +ok(1); # Initialized ok +unlink $TMP_FILE; + +# Capture STDOUT to a temporary file and a filehandle to read from it +open STDERR, ">$TMP_FILE"; +select STDERR; $| = 1; #needed on win32 +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; +sub readstderr { return join("", <IN>); } + +############################################################ +# Typical easy setup +############################################################ +Log::Log4perl->easy_init($INFO); +my $log = get_logger(); +$log->debug("We don't want to see this"); +$log->info("But this we want to see"); +$log->error("And this also"); +my $stderr = readstderr(); +#print "STDERR='$stderr'\n"; + +unlike($stderr, qr/don't/); +like($stderr, qr/this we want/); +like($stderr, qr/this also/); + +############################################################ +# Advanced easy setup +############################################################ +Log::Log4perl->reset(); +close IN; + # Reopen stderr +open STDERR, ">&1"; +unlink $TMP_FILE; + +package Bar::Twix; +use Log::Log4perl qw(:easy); +sub crunch { DEBUG("Twix Not shown"); + ERROR("Twix mjam"); } + +package Bar::Mars; +use Log::Log4perl qw(:easy); +my $line = __LINE__ + 1; +sub crunch { ERROR("Mars mjam"); + INFO("Mars not shown"); } +package main; + +Log::Log4perl->easy_init( + { level => $INFO, + category => "Bar::Twix", + file => ">>$TMP_FILE", + layout => '%m%n', + }, + { level => $WARN, + category => "Bar::Mars", + file => ">>$TMP_FILE", + layout => '%F{1}-%L-%M: %m%n', + }, +); + +Bar::Mars::crunch(); +Bar::Twix::crunch(); + +open FILE, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; +my $data = join '', <FILE>; +close FILE; + +is($data, "020Easy.t-$line-Bar::Mars::crunch: Mars mjam\nTwix mjam\n"); + +############################################################ +# LOGDIE and LOGWARN +############################################################ +# redir STDERR again +open STDERR, ">$TMP_FILE"; +select STDERR; $| = 1; #needed on win32 +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; + +Log::Log4perl->easy_init($INFO); +$log = get_logger(); +$line = __LINE__ + 1; +eval { LOGDIE("logdie"); }; + +like($@, qr/logdie at .*?020Easy.t line $line/); +like(readstderr(), qr/^[\d:\/ ]+logdie$/m); + +LOGWARN("logwarn"); +like(readstderr(), qr/logwarn/); + +############################################################ +# Test logdie/logwarn with and without "\n"s +############################################################ +LOGWARN("message"); +like(readstderr(), qr/message at .*? line \d+/); + +LOGWARN("message\n"); +unlike(readstderr(), qr/message at .*? line \d+/); + +LOGWARN("message\nother"); +like(readstderr(), qr/other at .*? line \d+/); + +LOGWARN("message\nother\n"); +unlike(readstderr(), qr/other at .*? line \d+/); + + # logdie +eval { LOGDIE("logdie"); }; +like($@, qr/logdie at .*?020Easy.t line \d+/); + +eval { LOGDIE("logdie\n"); }; +unlike($@, qr/at .*?020Easy.t line \d+/); + +eval { LOGDIE("logdie\nother"); }; +like($@, qr/other at .*?020Easy.t line \d+/); + +eval { LOGDIE("logdie\nother\n"); }; +unlike($@, qr/at .*?020Easy.t line \d+/); + +############################################################ +# Test %T stack traces +############################################################ +Log::Log4perl->easy_init({ level => $INFO, layout => "%T: %m%n"}); + +sub foo { + bar(); +} + +sub bar { + my $log = get_logger(); + $log->info("info!"); +} + +foo(); +like(readstderr(), qr(main::bar.*?main::foo)); +close IN; + +############################################################ +# LOGCARP and LOGCROAK +############################################################ +# redir STDERR again +open STDERR, ">$TMP_FILE"; +select STDERR; $| = 1; #needed on win32 +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; + +package Whack; +use Log::Log4perl qw(:easy); +sub whack { + LOGCROAK("logcroak in whack"); +} + +package main; + +Log::Log4perl->easy_init($INFO); +$log = get_logger(); +$line = __LINE__ + 1; +eval { Whack::whack() }; + +like($@, qr/logcroak in whack at .*?020Easy.t line $line/); +like(readstderr(), qr/^[\d:\/ ]+logcroak in whack.*$line/m); + +$line = __LINE__ + 8; +package Junk1; +use Log::Log4perl qw(:easy); +sub foo { + LOGCARP("LOGCARP"); +} +package Junk2; +sub foo { + Junk1::foo(); +} +package main; +Junk2::foo(); +SKIP: { + use Carp; + skip "Detected buggy Carp.pm (upgrade to perl-5.8.*)", 1 unless + defined $Carp::VERSION; + like(readstderr(), qr/LOGCARP.*020Easy.t line $line/); +} + +############################################################ +# LOGDIE and wrapper packages +############################################################ +package JunkWrapper; +use Log::Log4perl qw(:easy); +sub foo { + LOGDIE("Ahhh"); +} + +package main; + +Log::Log4perl->wrapper_register("JunkWrapper"); +$line = __LINE__ + 2; +eval { + JunkWrapper::foo(); +}; +like $@, qr/line $line/, "logdie with wrapper"; + +# Finally close +############################################################ +close IN; diff --git a/t/020Easy2.t b/t/020Easy2.t new file mode 100644 index 0000000..abaf450 --- /dev/null +++ b/t/020Easy2.t @@ -0,0 +1,63 @@ +########################################### +# 020Easy2.t - more Easy tests +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; +use Log::Log4perl::Appender::TestBuffer; + +my $stderr = ""; + +$SIG{__WARN__} = sub { + #print "warn: <$_[0]>\n"; + $stderr .= $_[0]; +}; + +use Test::More tests => 3; + +use Log::Log4perl qw(:easy); + +Log::Log4perl->init(\ q{ +log4perl.category.Bar.Twix = WARN, Term +log4perl.appender.Term = Log::Log4perl::Appender::Screen +log4perl.appender.Term.layout = Log::Log4perl::Layout::SimpleLayout +}); + + # This case caused a warning L4p 0.47 +INFO "Boo!"; + +is($stderr, "", "no warning"); + +# Test new level TRACE + +Log::Log4perl->init(\ q{ +log4perl.category = TRACE, Buf +log4perl.appender.Buf = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Buf.layout = Log::Log4perl::Layout::SimpleLayout +}); + +my $appenders = Log::Log4perl->appenders(); +my $bufapp = Log::Log4perl::Appender::TestBuffer->by_name("Buf"); + +TRACE("foobar"); +is($bufapp->buffer(), "TRACE - foobar\n", "TRACE check"); + +Log::Log4perl->init(\ q{ +log4perl.category = DEBUG, Buf +log4perl.appender.Buf = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Buf.layout = Log::Log4perl::Layout::SimpleLayout +}); +$bufapp = Log::Log4perl::Appender::TestBuffer->by_name("Buf"); + +my $log = Log::Log4perl::get_logger(""); +$log->trace("We don't want to see this"); +is($bufapp->buffer(), "", "Suppressed trace() check"); + diff --git a/t/021AppThres.t b/t/021AppThres.t new file mode 100644 index 0000000..492c4c4 --- /dev/null +++ b/t/021AppThres.t @@ -0,0 +1,240 @@ +########################################### +# Test Suite for Log::Log4perl::Logger +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Level; + +BEGIN { plan tests => 24 } + +ok(1); # If we made it this far, we're ok. + +cmp_ok(Log::Log4perl->appender_thresholds_adjust(1), q{==}, 0, + q{Expect 0 appenders to be affected before first init since there are none} +); + +my $log0 = Log::Log4perl->get_logger(""); +my $log1 = Log::Log4perl->get_logger("abc.def"); +my $log2 = Log::Log4perl->get_logger("abc.def.ghi"); + +$log0->level($DEBUG); +$log1->level($DEBUG); +$log2->level($DEBUG); + +my $app0 = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +my $app1 = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +$app0->threshold($ERROR); # As integer value +$app1->threshold("WARN"); # As string + +$log0->add_appender($app0); +$log1->add_appender($app1); + +################################################## +# Root logger's appender +################################################## +$app0->buffer(""); +$app1->buffer(""); +$log0->warn("Don't want to see this"); +$log0->error("Yeah, log0"); + +is($app0->buffer(), "ERROR - Yeah, log0\n", "Threshold ERROR"); +is($app1->buffer(), "", "Threshold WARN"); + +################################################## +# Inherited appender +################################################## +my $ret; + +$app0->buffer(""); +$app1->buffer(""); + +$ret = $log1->info("Don't want to see this"); +is($ret, 0, "Info suppressed"); + +$ret = $log1->warn("Yeah, log1"); +is($ret, 1, "inherited"); + +is($app0->buffer(), "", "inherited"); +is($app1->buffer(), "WARN - Yeah, log1\n", "inherited"); + +################################################## +# Inherited appender over two hierarchies +################################################## +$app0->buffer(""); +$app1->buffer(""); +$log2->info("Don't want to see this"); +$log2->error("Yeah, log2"); + +is($app0->buffer(), "ERROR - Yeah, log2\n", "two hierarchies"); +is($app1->buffer(), "ERROR - Yeah, log2\n", "two hierarchies"); + +################################################## +# Appender threshold with config file +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf = <<EOT; +log4perl.logger = ERROR, BUF0 +log4perl.logger.a = INFO, BUF1 +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +log4perl.appender.BUF0.Threshold = ERROR +log4perl.appender.BUF1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF1.layout = Log::Log4perl::Layout::SimpleLayout +log4perl.appender.BUF1.Threshold = WARN +EOT + +Log::Log4perl::init(\$conf); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +$app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +my $loga = get_logger("a"); + +$loga->info("Don't want to see this"); +$loga->error("Yeah, loga"); + +is($app0->buffer(), "ERROR - Yeah, loga\n", "appender threshold"); +is($app1->buffer(), "ERROR - Yeah, loga\n", "appender threshold"); + +################################################## +# Appender threshold with config file and a Java +# Class +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = <<EOT; +log4j.logger = ERROR, BUF0 +log4j.logger.a = INFO, BUF1 +log4j.appender.BUF0 = org.apache.log4j.TestBuffer +log4j.appender.BUF0.layout = SimpleLayout +log4j.appender.BUF0.Threshold = ERROR +log4j.appender.BUF1 = org.apache.log4j.TestBuffer +log4j.appender.BUF1.layout = SimpleLayout +log4j.appender.BUF1.Threshold = WARN +EOT + +Log::Log4perl::init(\$conf); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +$app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +$loga = get_logger("a"); + +$loga->info("Don't want to see this"); +$loga->error("Yeah, loga"); + +is($app0->buffer(), "ERROR - Yeah, loga\n", "threshold/java"); +is($app1->buffer(), "ERROR - Yeah, loga\n", "threshold/java"); + +################################################## +# 'threshold' vs. 'Threshold' +################################################## +$conf = <<EOT; +log4j.logger = ERROR, BUF0 +log4j.logger.a = INFO, BUF1 +log4j.appender.BUF0 = org.apache.log4j.TestBuffer +log4j.appender.BUF0.layout = SimpleLayout +log4j.appender.BUF0.Threshold = ERROR +log4j.appender.BUF1 = org.apache.log4j.TestBuffer +log4j.appender.BUF1.layout = SimpleLayout +log4j.appender.BUF1.threshold = WARN +EOT + +eval { Log::Log4perl::init(\$conf); }; + +if($@) { + like($@, qr/perhaps you meant 'Threshold'/, + "warn on misspelled 'threshold'"); +} else { + ok(0, "Abort on misspelled 'threshold'"); +} + +################################################## +# Increase threshold of all appenders +################################################## +$conf = <<EOT; +log4perl.category = WARN, BUF0, BUF1 + +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.Threshold = WARN +log4perl.appender.BUF0.layout = SimpleLayout + +log4perl.appender.BUF1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF1.Threshold = ERROR +log4perl.appender.BUF1.layout = SimpleLayout +EOT + +Log::Log4perl::init(\$conf); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +$app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +my $logger = get_logger(""); + +$logger->info("Info"); +$logger->warn("Warning"); +$logger->error("Error"); + +is($app0->buffer(), "WARN - Warning\nERROR - Error\n", "appender threshold"); +is($app1->buffer(), "ERROR - Error\n", "appender threshold"); + +cmp_ok(Log::Log4perl->appender_thresholds_adjust(-1), + q{==}, 2, q{Expect 2 appenders to be affected}); + +$app0->buffer(""); +$app1->buffer(""); + +$logger->more_logging(); +$logger->info("Info"); +$logger->warn("Warning"); +$logger->error("Error"); + +is($app0->buffer(), "INFO - Info\nWARN - Warning\nERROR - Error\n", + "adjusted appender threshold"); +is($app1->buffer(), "WARN - Warning\nERROR - Error\n", + "appender threshold"); + +$app0->buffer(""); +$app1->buffer(""); + + # reset previous thresholds +cmp_ok(Log::Log4perl->appender_thresholds_adjust(1), + q{==}, 2, q{Expect 2 appenders to be affected}); + +$app0->buffer(""); +$app1->buffer(""); + + # rig just one threshold +cmp_ok(Log::Log4perl->appender_thresholds_adjust(-1, ['BUF0']), + q{==}, 1, q{Expect 1 appender to be affected}); + +$logger->more_logging(); +$logger->info("Info"); +$logger->warn("Warning"); +$logger->error("Error"); + +is($app0->buffer(), "INFO - Info\nWARN - Warning\nERROR - Error\n", + "adjusted appender threshold"); +is($app1->buffer(), "ERROR - Error\n", + "appender threshold"); + diff --git a/t/022Wrap.t b/t/022Wrap.t new file mode 100644 index 0000000..e9aa76f --- /dev/null +++ b/t/022Wrap.t @@ -0,0 +1,131 @@ +########################################### +# Tests for Log4perl used by a wrapper class +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +use File::Basename; + +BEGIN { plan tests => 5 } + +################################################## +package Wrapper::Log4perl; + +use Log::Log4perl; +use Log::Log4perl::Level; + +our @ISA = qw(Log::Log4perl); + +sub get_logger { + # This is highly stupid (object duplication) and definitely not what we + # want anybody to do, but just to have a test case for a logger in a + # wrapper package + return Wrapper::Log4perl::Logger->new(@_); +} + +################################################## +package Wrapper::Log4perl::Logger; +Log::Log4perl->wrapper_register(__PACKAGE__); +sub new { + my $real_logger = Log::Log4perl::get_logger(@_); + bless { real_logger => $real_logger }, $_[0]; +} +sub AUTOLOAD { + no strict; + my $self = shift; + $AUTOLOAD =~ s/.*:://; + $self->{real_logger}->$AUTOLOAD(@_); +} +sub DESTROY {} + +################################################## +package main; + +use Log::Log4perl; +local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; +use Log::Log4perl::Level; + +my $log0 = Wrapper::Log4perl->get_logger(""); +$log0->level($DEBUG); + +my $app0 = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); +my $layout = Log::Log4perl::Layout::PatternLayout->new( + "File: %F{1} Line number: %L package: %C trace: %T"); +$app0->layout($layout); +$log0->add_appender($app0); + +################################################## +my $rootlogger = Wrapper::Log4perl->get_logger(""); +my $line = __LINE__ + 1; +$rootlogger->debug("Hello"); + +my $buf = $app0->buffer(); +$buf =~ s#(\S+022Wrap\.t)#basename( $1 )#eg; + +# [rt 74836] Carp.pm added a dot at the end with 1.25. +# Be dot-agnostic. +$buf =~ s/\.$//; + +is($buf, + "File: 022Wrap.t Line number: $line package: main " . + "trace: at 022Wrap.t line $line", + "appender check"); + + # with the new wrapper_register in Log4perl 1.29, this will even work + # *without* modifying caller_depth +$Log::Log4perl::caller_depth--; +$app0->buffer(""); +$line = __LINE__ + 1; +$rootlogger->debug("Hello"); + + # Win32 +# [rt 74836] Carp.pm added a dot at the end with 1.25. +# Be dot-agnostic. +$buf = $app0->buffer(); +$buf =~ s/\.$//; +$buf =~ s#(\S+022Wrap\.t)#basename( $1 )#eg; + +is($buf, + "File: 022Wrap.t Line number: $line package: main " . + "trace: at 022Wrap.t line $line", + "appender check"); + +################################################## +package L4p::Wrapper; +Log::Log4perl->wrapper_register(__PACKAGE__); +no strict qw(refs); +*get_logger = sub { + + my @args = @_; + + if(defined $args[0] and $args[0] eq __PACKAGE__) { + $args[0] =~ s/__PACKAGE__/Log::Log4perl/g; + } + Log::Log4perl::get_logger( @args ); +}; + +package main; + +my $logger = L4p::Wrapper::get_logger(); +is $logger->{category}, "main", "cat on () is main"; + +$logger = L4p::Wrapper::get_logger(__PACKAGE__); +is $logger->{category}, "main", "cat on (__PACKAGE__) is main"; + +$logger = L4p::Wrapper->get_logger(); +is $logger->{category}, "main", "cat on ->() is main"; + +# use Data::Dumper; +# print Dumper($logger); diff --git a/t/023Date.t b/t/023Date.t new file mode 100755 index 0000000..8779fad --- /dev/null +++ b/t/023Date.t @@ -0,0 +1,184 @@ +########################################### +# Tests for Log4perl::DateFormat +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +BEGIN { plan tests => 36 } + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::DateFormat; +use Log::Log4perl::Appender::TestBuffer; + +$Log::Log4perl::DateFormat::GMTIME = 1; + +my $GMTIME = 1030429942 - 7*3600; + +########################################### +# Year +########################################### +my $formatter = Log::Log4perl::DateFormat->new("yyyy yy yyyy"); +is($formatter->format($GMTIME), "2002 02 2002"); + +########################################### +# Month +########################################### +$formatter = Log::Log4perl::DateFormat->new("MM M MMMM yyyy"); +is($formatter->format($GMTIME), "08 8 August 2002"); + +########################################### +# Month +########################################### +$formatter = Log::Log4perl::DateFormat->new("MMM yyyy"); +is($formatter->format($GMTIME), "Aug 2002"); + +########################################### +# Day-of-Month +########################################### +$formatter = Log::Log4perl::DateFormat->new("d ddd dd dddd yyyy"); +is($formatter->format($GMTIME), "26 026 26 0026 2002"); + +########################################### +# am/pm Hour +########################################### +$formatter = Log::Log4perl::DateFormat->new("h hh hhh hhhh"); +is($formatter->format($GMTIME), "11 11 011 0011"); + +########################################### +# 24 Hour +########################################### +$formatter = Log::Log4perl::DateFormat->new("H HH HHH HHHH"); +is($formatter->format($GMTIME), "23 23 023 0023"); + +########################################### +# Minute +########################################### +$formatter = Log::Log4perl::DateFormat->new("m mm mmm mmmm"); +is($formatter->format($GMTIME), "32 32 032 0032"); + +########################################### +# Second +########################################### +$formatter = Log::Log4perl::DateFormat->new("s ss sss ssss"); +is($formatter->format($GMTIME), "22 22 022 0022"); + +########################################### +# Day of Week +########################################### +$formatter = Log::Log4perl::DateFormat->new("E EE EEE EEEE"); +is($formatter->format($GMTIME), "Mon Mon Mon Monday"); +is($formatter->format($GMTIME+24*60*60*1), "Tue Tue Tue Tuesday"); +is($formatter->format($GMTIME+24*60*60*2), "Wed Wed Wed Wednesday"); +is($formatter->format($GMTIME+24*60*60*3), "Thu Thu Thu Thursday"); +is($formatter->format($GMTIME+24*60*60*4), "Fri Fri Fri Friday"); +is($formatter->format($GMTIME+24*60*60*5), "Sat Sat Sat Saturday"); +is($formatter->format($GMTIME+24*60*60*6), "Sun Sun Sun Sunday"); + +########################################### +# Day of Year +########################################### +$formatter = Log::Log4perl::DateFormat->new("D DD DDD DDDD"); +is($formatter->format($GMTIME), "238 238 238 0238"); + +########################################### +# AM/PM +########################################### +$formatter = Log::Log4perl::DateFormat->new("a aa"); +is($formatter->format($GMTIME), "PM PM"); + +########################################### +# Milliseconds +########################################### +$formatter = Log::Log4perl::DateFormat->new("S SS SSS SSSS SSSSS SSSSSS"); +is($formatter->format($GMTIME, 123456), "1 12 123 1234 12345 123456"); + +########################################### +# Predefined formats +########################################### +$formatter = Log::Log4perl::DateFormat->new("DATE"); +is($formatter->format($GMTIME, 123456), "26 Aug 2002 23:32:22,123"); + +$formatter = Log::Log4perl::DateFormat->new("ISO8601"); +is($formatter->format($GMTIME, 123456), "2002-08-26 23:32:22,123"); + +$formatter = Log::Log4perl::DateFormat->new("ABSOLUTE"); +is($formatter->format($GMTIME, 123456), "23:32:22,123"); + +$formatter = Log::Log4perl::DateFormat->new("APACHE"); +is($formatter->format($GMTIME, 123456), "[Mon Aug 26 23:32:22 2002]"); + +########################################### +# Unknown +########################################### +$formatter = Log::Log4perl::DateFormat->new("xx K"); +is($formatter->format($GMTIME), "xx -- 'K' not (yet) implemented --"); + +########################################### +# DDD bugfix +########################################### +$formatter = Log::Log4perl::DateFormat->new("DDD"); + # 1/1/2006 +is($formatter->format(1136106000), "001"); +$formatter = Log::Log4perl::DateFormat->new("D"); + # 1/1/2006 +is($formatter->format(1136106000), "1"); + +########################################### +# In conjunction with Log4perl +########################################### +my $conf = q( +log4perl.category.Bar.Twix = WARN, Buffer +log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Buffer.layout = \ + Log::Log4perl::Layout::PatternLayout +log4perl.appender.Buffer.layout.ConversionPattern = %d{HH:mm:ss} %p %m %n +); + +Log::Log4perl::init(\$conf); + +my $logger = get_logger("Bar::Twix"); +$logger->error("Blah"); + +like(Log::Log4perl::Appender::TestBuffer->by_name("Buffer")->buffer(), + qr/\d\d:\d\d:\d\d ERROR Blah/); + +########################################### +# Allowing literal text in L4p >= 1.19 +########################################### +my @tests = ( + q!yyyy-MM-dd'T'HH:mm:ss.SSS'Z'! => q!%04d-%02d-%02dT%02d:%02d:%02d.%sZ!, + q!yyyy-MM-dd''HH:mm:ss.SSS''! => q!%04d-%02d-%02d%02d:%02d:%02d.%s!, + q!yyyy-MM-dd''''HH:mm:ss.SSS! => q!%04d-%02d-%02d'%02d:%02d:%02d.%s!, + q!yyyy-MM-dd''''''HH:mm:ss.SSS! => q!%04d-%02d-%02d''%02d:%02d:%02d.%s!, + q!yyyy-MM-dd,HH:mm:ss.SSS! => q!%04d-%02d-%02d,%02d:%02d:%02d.%s!, + q!HH:mm:ss,SSS! => q!%02d:%02d:%02d,%s!, + q!dd MMM yyyy HH:mm:ss,SSS! => q!%02d %.3s %04d %02d:%02d:%02d,%s!, + q!hh 'o''clock' a! => q!%02d o'clock %1s!, + q!hh 'o'clock' a! => q!(undef)!, + q!yyyy-MM-dd 'at' HH:mm:ss! => q!%04d-%02d-%02d at %02d:%02d:%02d!, +); + +#' calm down up vim syntax highlighting + +while ( my ( $src, $expected ) = splice @tests, 0, 2 ) { + my $df = eval { Log::Log4perl::DateFormat->new( $src ) }; + my $err = ''; + if ( $@ ) + { + chomp $@; + $err = "(error: $@)"; + } + my $got = $df->{fmt} || '(undef)'; + is($got, $expected, "literal $src"); +} diff --git a/t/024WarnDieCarp.t b/t/024WarnDieCarp.t new file mode 100755 index 0000000..21ced8b --- /dev/null +++ b/t/024WarnDieCarp.t @@ -0,0 +1,404 @@ +#!/usr/bin/perl + +# $Id: 024WarnDieCarp.t,v 1.1 2002/08/29 05:33:28 mschilli Exp $ + +# Check the various logFOO for FOO in {die, warn, Carp*} + +# note: I <erik@selberg.com> prefer Test::Simple to just Test. + +###################################################################### +# +# This is a fairly simply smoketest... it basically runs the gamut of +# the warn / die / croak / cluck / confess / carp family and makes sure +# that the log output contained the appropriate string and STDERR +# contains the appropriate string. +# +###################################################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +use Log::Log4perl qw(get_logger :easy); +use Log::Log4perl::Level; +use File::Spec; use Data::Dumper; + +BEGIN { + if ($] < 5.006) { + plan skip_all => "Only with perl >= 5.006"; + } else { + plan tests => 73; + } +} + +my $warnstr; + +# this nullifies warns and dies here... so testing the testscript may suck. +local $SIG{__WARN__} = sub { $warnstr = join("", @_); }; +local $SIG{__DIE__} = sub { $warnstr = join("", @_); }; + +sub warndietest { + my ($method, $in_str, $out_str, $app, $mname) = @_; + + eval { &$method($in_str) }; + + like($warnstr, qr/$out_str/, + "$mname($in_str): STDERR contains \"$out_str\""); + like($app->buffer(), qr/$out_str/, + "$mname($in_str): Buffer contains \"$out_str\""); + $app->buffer(""); +} + +# same as above, just look for no output +sub warndietest_nooutput { + my ($method, $in_str, $out_str, $app, $mname) = @_; + + eval { &$method($in_str) }; + + unlike($warnstr, qr/\Q$out_str\E/, + "$mname($in_str): STDERR does NOT contain \"$out_str\""); + unlike($app->buffer(), qr/$out_str/, + "$mname($in_str): Buffer does NOT contain \"$out_str\""); +} + +# warn() still prints to stderr, but nothing gets logged +sub warndietest_stderronly { + my ($method, $in_str, $out_str, $app, $mname) = @_; + + eval { &$method($in_str) }; + + my($pkg, $file, $line) = caller(); + + # it's in stderr + like($warnstr, qr/\Q$out_str\E/, + "$mname($in_str): STDERR does contain \"$out_str\" ($file:$line)"); + # but not logged by log4perl + unlike($app->buffer(), qr/$out_str/, + "$mname($in_str): Buffer does NOT contain \"$out_str\" ($file:$line)"); +} + +# same as above, just look for no output in buffer, but output in STDERR +sub dietest_nooutput { + my ($method, $in_str, $out_str, $app, $mname) = @_; + + eval { &$method($in_str) }; + + like($warnstr, qr/$out_str/, "$mname($in_str): STDERR contains \"$out_str\""); + unlike($app->buffer(), qr/$out_str/, + "$mname($in_str): Buffer does NOT contain \"$out_str\""); +} + + +ok(1, "Initialized OK"); + +############################################################ +# Get a logger and use it without having called init() first +############################################################ +my $log = Log::Log4perl::get_logger("abc.def"); +my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); +$log->add_appender($app); + +###################################################################### +# lets start testing! + +$log->level($DEBUG); + +my $test = 1; + +###################################################################### +# sanity: make sure the tests spit out FOO to the buffer and STDERR + +foreach my $f ("logwarn", "logdie", "logcarp", "logcroak", "logcluck", + "logconfess", "error_warn", "error_die") { + warndietest(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); + $test++; +} + +###################################################################### +# change the log level to ERROR... warns should produce nothing in +# log4perl now, but logwarn still triggers warn() + +$log->level($ERROR); + +foreach my $f ("logdie", "logcroak", + "logconfess", "error_warn", "error_die") { + warndietest(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); + $test++; +} + +foreach my $f ("logwarn", "logcarp", "logcluck", + ) { + warndietest_stderronly(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); + $test++; +} + +###################################################################### +# change logging to OFF... FATALs still produce output though. + +$log->level($OFF); # $OFF == $FATAL... although I suspect thats a bug in the log4j spec + +foreach my $f ("logwarn", "logcarp", "logcluck", "error_warn") { + warndietest_stderronly(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); + $test++; +} + +foreach my $f ("error_die", "logdie", "logcroak", "logconfess") { + dietest_nooutput(sub {$log->$f(@_)}, "Test $test: $f", "Test $test: $f", $app, "$f"); + $test++; +} + +###################################################################### +# Check if logdie %F%L lists the right file/line +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=org.apache.log4j.PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%F-%L: %m +EOT + +my $logger = get_logger("Twix::Bar"); + +my $line_number = __LINE__ + 1; +eval { $logger->logdie("Log and die!"); }; + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("A1"); +# print "Buffer: ", $app0->buffer(), "\n"; + +like($app0->buffer(), qr/024WarnDieCarp.t-$line_number: Log and die!/, + "%F-%L adjustment"); + +###################################################################### +# Check if logcarp/cluck/croak are reporting the calling package, +# not the one the error happened in. +###################################################################### +$app0->buffer(""); + +package Weirdo; +our $foo_line; +our $bar_line; + +use Log::Log4perl qw(get_logger); +sub foo { + my $logger = get_logger("Twix::Bar"); + $foo_line = __LINE__ + 1; + $logger->logcroak("Inferno!"); +} +sub bar { + my $logger = get_logger("Twix::Bar"); + $bar_line = __LINE__ + 1; + $logger->logdie("Inferno!"); +} + +package main; +eval { Weirdo::foo(); }; + +like($app0->buffer(), qr/$Weirdo::foo_line/, + "Check logcroak/Carp"); + +$app0->buffer(""); +eval { Weirdo::bar(); }; + +like($app0->buffer(), qr/$Weirdo::bar_line/, + "Check logdie"); + +###################################################################### +# Check if logcarp/cluck/croak are reporting the calling package, +# when they are more than one hierarchy from the top. +###################################################################### +$app0->buffer(""); + +package Foo; +our $foo_line; +use Log::Log4perl qw(get_logger); +sub foo { + my $logger = get_logger("Twix::Bar"); + $foo_line = __LINE__ + 1; + $logger->logcarp("Inferno!"); +} + +package Bar; +sub bar { + Foo::foo(); +} + +package main; +eval { Bar::bar(); }; + +SKIP: { + use Carp; + skip "Detected buggy Carp.pm (upgrade to perl-5.8.*)", 1 unless + defined $Carp::VERSION; + like($app0->buffer(), qr/$Foo::foo_line/, + "Check logcarp"); +} + +###################################################################### +# Test fix of bug that had logwarn/die/etc print unformatted messages. +###################################################################### +$logger = get_logger("Twix::Bar"); +$log->level($DEBUG); + +eval { $logger->logdie(sub { "a" . "-" . "b" }); }; +like($@, qr/a-b/, "bugfix: logdie with sub{} as argument"); + +$logger->logwarn(sub { "a" . "-" . "b" }); +like($warnstr, qr/a-b/, "bugfix: logwarn with sub{} as argument"); + +$logger->logwarn({ filter => \&Dumper, + value => "a-b" }); +like($warnstr, qr/a-b/, "bugfix: logwarn with sub{filter/value} as argument"); + +eval { $logger->logcroak({ filter => \&Dumper, + value => "a-b" }); }; +like($warnstr, qr/a-b/, "bugfix: logcroak with sub{} as argument"); + +###################################################################### +# logcroak/cluck/carp/confess level test +###################################################################### +our($carp_line, $call_line); + +package Foo1; +use Log::Log4perl qw(:easy); +sub foo { get_logger("Twix::Bar")->logcarp("foocarp"); $carp_line = __LINE__ } + +package Bar1; +sub bar { Foo1::foo(); $call_line = __LINE__; } + +package main; + +my $l4p_app = $Log::Log4perl::Logger::APPENDER_BY_NAME{"A1"}; +my $layout = Log::Log4perl::Layout::PatternLayout->new("%M#%L %m%n"); +$l4p_app->layout($layout); + +$app0->buffer(""); +Foo1::foo(); $call_line = __LINE__; + # Foo1::foo#238 foocarp at 024WarnDieCarp.t line 250 +like($app0->buffer(), qr/Foo1::foo#$carp_line foocarp.*$call_line/, + "carp in subfunction"); + # foocarp at 024WarnDieCarp.t line 250 +like($warnstr, qr/foocarp.*line $call_line/, "carp output"); + +$app0->buffer(""); +Bar1::bar(); + +SKIP: { + use Carp; + skip "Detected buggy Carp.pm (upgrade to perl-5.8.*)", 1 unless + defined $Carp::VERSION; + + # Foo1::foo#238 foocarp at 024WarnDieCarp.t line 250 + like($app0->buffer(), qr/Foo1::foo#$carp_line foocarp.*$call_line/, + "carp in sub-sub-function"); +} + + # foocarp at 024WarnDieCarp.t line 250 +like($warnstr, qr/foocarp.*line $call_line/, "carp output"); + +###################################################################### +# logconfess fix (1.12) +###################################################################### +$app0->buffer(""); + +package Foo1; +sub new { + my($class) = @_; + bless {}, $class; +} + +sub foo1 { + my $log = get_logger(); + $log->logconfess("bah!"); +} + +package main; + +my $foo = Foo1->new(); +eval { $foo->foo1() }; + +like $@, qr/024WarnDieCarp.*Foo1::foo1.*eval/s, "Confess logs correct frame"; + +###################################################################### +# logdie/warn caller level bug +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=org.apache.log4j.PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%F-%L: %m +EOT + +$logger = get_logger("Twix::Bar"); + +$logger->logwarn("warn!"); +like $warnstr, qr/024WarnDieCarp/, "logwarn() caller depth bug"; +unlike $warnstr, qr/Logger.pm/, "logwarn() caller depth bug"; + +$Log::Log4perl::Logger::DIE_DEBUG = 1; +$logger->logdie("die!"); +like $Log::Log4perl::Logger::DIE_DEBUG_BUFFER, qr/024WarnDieCarp/, + "logdie() caller depth bug"; +unlike $Log::Log4perl::Logger::DIE_DEBUG_BUFFER, qr/Logger.pm/, + "logdie() caller depth bug"; + +my $app3 = Log::Log4perl::Appender::TestBuffer->by_name("A1"); +$app3->buffer(""); + +my $line1 = __LINE__ + 1; +subroutine(); + +my $line2; +sub subroutine { + $line2 = __LINE__ + 1; + $logger->logcluck("cluck!"); +} + +like $app3->buffer(), qr/-$line2: cluck!/, "logcluck()"; +like $app3->buffer(), qr/main::subroutine\(\) called .* line $line1/, + "logcluck()"; + +# Carp test + +$app3->buffer(""); +my $line3 = __LINE__ + 1; +subroutine_carp(); + +my $line4; +sub subroutine_carp { + $line4 = __LINE__ + 1; + $logger->logcarp("carp!"); +} + +like $app3->buffer(), qr/-$line4: carp!/, "logcarp()"; +like $app3->buffer(), qr/main::subroutine_carp\(\) called .* line $line3/, + "logcarp()"; + +# Stringify test +$Log::Log4perl::Logger::DIE_DEBUG = 0; +$Log::Log4perl::STRINGIFY_DIE_MESSAGE = 0; + +eval { + $logger->logcroak( { foo => "bar" } ); +}; + +is $@->{ foo }, "bar", "croak without stringify"; + +eval { + $logger->logconfess( { foo => "bar" } ); +}; + +is $@->{ foo }, "bar", "confess without stringify"; + +eval { + $logger->logdie( { foo => "bar" } ); +}; + +is $@->{ foo }, "bar", "die without stringify"; diff --git a/t/025CustLevels.t b/t/025CustLevels.t new file mode 100644 index 0000000..8bf8036 --- /dev/null +++ b/t/025CustLevels.t @@ -0,0 +1,208 @@ +########################################### +# Test Suite for Log::Log4perl::Config +# Erik Selberg, (c) 2002 erik@selberg.com +# clone of 025CustLevels.t but uses nicer method (?) we hope +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; + +#create a custom level "LITEWARN" +use Log::Log4perl; +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; +# use strict; + + +ok(1); # If we made it this far, we're ok. + +Log::Log4perl::Logger::create_custom_level("LITEWARN", "WARN"); +#testing for bugfix of 9/19/03 before which custom levels beneath DEBUG didn't work +Log::Log4perl::Logger::create_custom_level("DEBUG2", "DEBUG"); + +# test insane creation of levels + +foreach (1 .. 14) { + ok(Log::Log4perl::Logger::create_custom_level("TEST$_", "INFO"), 0); +} + +# 15th should fail.. this assumes that each level is 10000 apart from +# the other. + +ok(!defined eval { Log::Log4perl::Logger::create_custom_level("TEST15", "INFO") }); + +# now, by re-arranging (as we whine about in create_custom_levels), we +# should be able to get 15. + +my %btree = ( + 8 => "DEBUG", + 4 => 8, + 2 => 4, + 1 => 2, + 3 => 4, + 6 => 8, + 5 => 6, + 7 => 8, + 12 => "DEBUG", + 10 => 12, + 9 => 10, + 11 => 12, + 14 => "DEBUG", + 13 => 14, + 15 => "DEBUG", + ); + +foreach (8, 4, 2, 1, 3, 6, 5, 7, 12, 10, 9, 11, 14, 13, 15) { + my $level = $btree{$_} eq "DEBUG" ? "DEBUG" : "BTREE$btree{$_}"; +# warn("Creating BTREE$_ after $level"); + ok(Log::Log4perl::Logger::create_custom_level("BTREE$_", $level), 0); +# warn("BTREE$_ is ", ${Log::Log4perl::Level::PRIORITY{"BTREE$_"}}); +} + +# foreach (1 .. 15) { +# warn("BTREE$_ is: ", ${Log::Log4perl::Level::PRIORITY{"BTREE$_"}}); +# } + + +my $LOGFILE = "example$$.log"; +unlink $LOGFILE; + +my $config = <<EOT; +log4j.category = LITEWARN, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $LOGFILE +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.debug2test = DEBUG2, FileAppndr +log4j.additivity.debug2test= 0 +EOT + + +Log::Log4perl::init(\$config); + + +# can't create a custom level after init... let's test that. Just look +# for an undef (i.e. failure) from the eval + +ok(!defined eval { Log::Log4perl::Logger::create_custom_level("NOTIFY", "WARN"); }); + + +# ********************* +# check a category logger + +my $logger = Log::Log4perl->get_logger("groceries.beer"); +$logger->warn("this is a warning message"); +$logger->litewarn("this is a LITE warning message (2/3 the calories)"); +$logger->info("this info message should not log"); + + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +$/ = undef; +my $data = <FILE>; +close FILE; +my $result1 = "WARN - this is a warning message\nLITEWARN - this is a LITE warning message (2/3 the calories)\n"; +ok($data, $result1); + +# ********************* +# check the root logger +my $rootlogger = Log::Log4perl->get_logger(""); +$logger->warn("this is a rootlevel warning message"); +$logger->litewarn("this is a rootlevel LITE warning message (2/3 the calories)"); +$logger->info("this rootlevel info message should not log"); + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +$/ = undef; +$data = <FILE>; +close FILE; +my $result2 = "WARN - this is a rootlevel warning message\nLITEWARN - this is a rootlevel LITE warning message (2/3 the calories)\n"; +ok($data, "$result1$result2"); + +$logger->log($WARN, "a warning message"); +$logger->log($LITEWARN, "a LITE warning message"); +die("lame hack to suppress warning") if ($LITEWARN != $LITEWARN); +$logger->log($DEBUG, "an info message, should not log"); + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +$/ = undef; +$data = <FILE>; +close FILE; +my $result3 = "WARN - a warning message\nLITEWARN - a LITE warning message\n"; +ok($data, "$result1$result2$result3"); + +# ********************* +# check debug2 level +my $debug2 = Log::Log4perl->get_logger("debug2test"); +$debug2->debug2("this is a debug2 message"); + +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +$/ = undef; +$data = <FILE>; +close FILE; +my $result4 = "DEBUG2 - this is a debug2 message\n"; +ok($data, "$result1$result2$result3$result4"); + +#********************* +#check the is_* methods +ok($logger->is_warn); +ok($logger->is_litewarn); +ok(! $logger->is_info); + + +# warn("Testing inc_level()"); + +#*************************** +#increase/decrease leves +$logger->inc_level(1); #bump up from litewarn to warn +# warn("level is now: ", $logger->level()); +ok($logger->is_warn); +ok(!$logger->is_litewarn); +ok(!$logger->is_info); +$logger->warn("after bumping, warning message"); +$logger->litewarn("after bumping, lite warning message, should not log"); +open FILE, "<$LOGFILE" or die "Cannot open $LOGFILE"; +$/ = undef; +$data = <FILE>; +close FILE; +my $result5 = "WARN - after bumping, warning message\n"; +ok($data, "$result1$result2$result3$result4$result5"); + +$logger->dec_level(2); #bump down from warn to litewarn to info + +ok($logger->is_warn); +ok($logger->is_litewarn); +ok($logger->is_info); + +ok(! $logger->is_debug) ; + +$logger->level($FATAL); + +ok($logger->is_fatal() && !($logger->is_error() || $logger->is_warn() || + $logger->is_info() || $logger->is_debug())); + +$logger->more_logging(); # should inc one level + +ok($logger->is_fatal() && $logger->is_error() && !( $logger->is_warn() || + $logger->is_info() || $logger->is_debug())); + +$logger->more_logging(100); # should be debug now + +ok($logger->is_fatal() && $logger->is_error() && $logger->is_warn() && + $logger->is_info() && $logger->is_debug()); + +$logger->less_logging(150); # should be OFF now + +ok(!($logger->is_fatal() || $logger->is_error() || $logger->is_warn() || + $logger->is_info() || $logger->is_debug())); + +BEGIN { plan tests => 51 }; + +unlink $LOGFILE; diff --git a/t/026FileApp.t b/t/026FileApp.t new file mode 100644 index 0000000..b3ae4f4 --- /dev/null +++ b/t/026FileApp.t @@ -0,0 +1,494 @@ +#Testing if the file-appender appends in default mode + +END { + # Must be before enabling the Log4Perl stuff, or file will still + # be open and locked (under Win32) on program close. + + unlink_testfiles(); + } + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; + +use warnings; +use strict; + +use Log::Log4perl; +use File::Spec; +use File::Path qw(remove_tree); + +our $LOG_DISPATCH_PRESENT; + +BEGIN { + eval { require Log::Dispatch; }; + if(! $@) { + $LOG_DISPATCH_PRESENT = 1; + } +}; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $testfile = File::Spec->catfile($WORK_DIR, "test26.log"); +my $testpath = File::Spec->catfile($WORK_DIR, "test26"); + +BEGIN {plan tests => 26} + +sub unlink_testfiles { + unlink $testfile; + unlink "${testfile}_1"; + unlink "${testfile}_2"; + unlink "${testfile}_3"; + unlink "${testfile}_4"; + unlink "${testfile}_5"; + remove_tree ($testpath, "${testpath}_1"); +} + +unlink_testfiles(); + +#################################################### +# First, preset the log file with some content +#################################################### +open FILE, ">$testfile" or die "Cannot create $testfile"; +print FILE "previous content\n"; +close FILE; + +#################################################### +# Append to a log file without specifying append mode +# explicitely +#################################################### +my $data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testfile +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +my $log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +open FILE, "<$testfile" or die "Cannot create $testfile"; +my $content = join '', <FILE>; +close FILE; + +is($content, "previous content\nINFO - Shu-wa-chi!\n"); + +#################################################### +# Clobber the log file if overwriting is required +#################################################### +$data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testfile +log4j.appender.FileAppndr.mode = write +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +open FILE, "<$testfile" or die "Cannot create $testfile"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - Shu-wa-chi!\n"); + +#################################################### +# Explicetly say "append" +#################################################### +$data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testfile +log4j.appender.FileAppndr.mode = append +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +open FILE, "<$testfile" or die "Cannot create $testfile"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - Shu-wa-chi!\nINFO - Shu-wa-chi!\n"); + +######################################################### +# Mix Log::Dispatch and Log::Log4perl::Appender appenders +######################################################### +SKIP: { + skip "Skipping Log::Dispatch tests", 2 unless $LOG_DISPATCH_PRESENT; + +$data = <<EOT; +log4perl.category = INFO, FileAppndr1, FileAppndr2 +log4perl.appender.FileAppndr1 = Log::Dispatch::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.mode = append +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout + +log4perl.appender.FileAppndr2 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr2.filename = ${testfile}_2 +log4perl.appender.FileAppndr2.mode = append +log4perl.appender.FileAppndr2.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +for(qw(1 2)) { + open FILE, "<${testfile}_$_" or die "Cannot open ${testfile}_$_"; + $content = join '', <FILE>; + close FILE; + + is($content, "INFO - Shu-wa-chi!\n"); +} +}; + +######################################################### +# Check if the 0.33 Log::Log4perl::Appender::File bug is +# fixed which caused all messages to end up in the same +# file. +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1, FileAppndr2 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout + +log4perl.appender.FileAppndr2 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr2.filename = ${testfile}_2 +log4perl.appender.FileAppndr2.mode = write +log4perl.appender.FileAppndr2.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +for(qw(1 2)) { + open FILE, "<${testfile}_$_" or die "Cannot open ${testfile}_$_"; + $content = join '', <FILE>; + close FILE; + + is($content, "INFO - Shu-wa-chi!\n"); +} + +######################################################### +# Check if switching over to a new file will work +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +my $app = Log::Log4perl->appenders()->{FileAppndr1}; +$app->file_switch("${testfile}_2"); +$log->info("File2"); + +for(qw(1 2)) { + open FILE, "<${testfile}_$_" or die "Cannot open ${testfile}_$_"; + $content = join '', <FILE>; + close FILE; + + is($content, "INFO - File$_\n"); +} + +is($app->filename(), "${testfile}_2"); + +######################################################### +# Testing syswrite +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.syswrite = 1 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\n"); + +Log::Log4perl::init(\$data); +$log->info("File1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\n"); + +######################################################### +# Testing syswrite with append +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.syswrite = 1 +log4perl.appender.FileAppndr1.mode = append +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\nINFO - File1\n"); + +######################################################### +# Testing syswrite and recreate +######################################################### +SKIP: { + skip "File recreation not supported on Win32", 1 if $^O eq "MSWin32"; +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.syswrite = 1 +log4perl.appender.FileAppndr1.recreate = 1 +log4perl.appender.FileAppndr1.recreate_check_interval = 0 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +unlink "${testfile}_1"; + +$log->info("File1-1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1-1\n"); +}; + +######################################################### +# Testing syswrite and recreate without check_interval +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.syswrite = 1 +log4perl.appender.FileAppndr1.recreate = 1 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +unlink "${testfile}_1"; + +eval { $log->info("File1-1"); }; + +is($@, "", "no error on moved file/syswrite"); + +SKIP: { + skip "Signals not supported on Win32", 2 if $^O eq "MSWin32"; + +######################################################### +# Testing syswrite and recreate_check_signal +######################################################### +$data = <<EOT; +log4perl.category = INFO, FileAppndr1 +log4perl.appender.FileAppndr1 = Log::Log4perl::Appender::File +log4perl.appender.FileAppndr1.filename = ${testfile}_1 +log4perl.appender.FileAppndr1.syswrite = 1 +log4perl.appender.FileAppndr1.recreate = 1 +log4perl.appender.FileAppndr1.recreate_check_signal = USR1 +log4perl.appender.FileAppndr1.mode = write +log4perl.appender.FileAppndr1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +unlink "${testfile}_1"; + +is(kill('USR1', $$), 1, "sending signal"); +$log->info("File1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\n"); +}; + +######################################################### +# Testing create_at_logtime +######################################################### +unlink "${testfile}_3"; # delete leftovers from previous tests + +$data = qq( +log4perl.category = DEBUG, Logfile +log4perl.appender.Logfile = Log::Log4perl::Appender::File +log4perl.appender.Logfile.filename = ${testfile}_3 +log4perl.appender.Logfile.create_at_logtime = 1 +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl->init(\$data); +ok(! -f "${testfile}_3"); + +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +open FILE, "<${testfile}_3" or die "Cannot open ${testfile}_3"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\n"); + +unlink "${testfile}_3"; + +######################################################### +# Testing create_at_logtime with recreate_check_signal +######################################################### +unlink "${testfile}_4"; # delete leftovers from previous tests + +$data = qq( +log4perl.category = DEBUG, Logfile +log4perl.appender.Logfile = Log::Log4perl::Appender::File +log4perl.appender.Logfile.filename = ${testfile}_4 +log4perl.appender.Logfile.create_at_logtime = 1 +log4perl.appender.Logfile.recreate = 1; +log4perl.appender.Logfile.recreate_check_signal = USR1 +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl->init(\$data); +ok(! -f "${testfile}_4"); + +$log = Log::Log4perl::get_logger(""); +$log->info("File1"); + +open FILE, "<${testfile}_4" or die "Cannot open ${testfile}_4"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - File1\n"); + +unlink "${testfile}_4"; + +######################################################### +# Print a header into a newly opened file +######################################################### +$data = qq( +log4perl.category = DEBUG, Logfile +log4perl.appender.Logfile = Log::Log4perl::Appender::File +log4perl.appender.Logfile.filename = ${testfile}_5 +log4perl.appender.Logfile.header_text = This is a nice header. +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl->init(\$data); +open FILE, "<${testfile}_5" or die "Cannot open ${testfile}_5"; +$content = join '', <FILE>; +close FILE; + +is($content, "This is a nice header.\n", "header_text"); + +#################################################### +# Create path if it is not already created +#################################################### + + +my $testmkpathfile = File::Spec->catfile($testpath, "test26.log"); + +$data = <<EOT; +log4j.category = INFO, FileAppndr +log4j.appender.FileAppndr = Log::Log4perl::Appender::File +log4j.appender.FileAppndr.filename = $testmkpathfile +log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.FileAppndr.mkpath = 1 +EOT + +Log::Log4perl::init(\$data); +$log = Log::Log4perl::get_logger(""); +$log->info("Shu-wa-chi!"); + +open FILE, "<$testmkpathfile" or die "Cannot create $testmkpathfile"; +$content = join '', <FILE>; +close FILE; + +is($content, "INFO - Shu-wa-chi!\n"); + +#################################################### +# Create path with umask if it is not already created +#################################################### + +SKIP: { + skip "Umask not supported on Win32", 3 if $^O eq "MSWin32"; + + my $oldumask = umask; + + $testmkpathfile = File::Spec->catfile("${testpath}_1", "test26.log"); + + $data = <<EOT; + log4j.category = INFO, FileAppndr + log4j.appender.FileAppndr = Log::Log4perl::Appender::File + log4j.appender.FileAppndr.filename = $testmkpathfile + log4j.appender.FileAppndr.layout = Log::Log4perl::Layout::SimpleLayout + log4j.appender.FileAppndr.umask = 0026 + log4j.appender.FileAppndr.mkpath = 1 + log4j.appender.FileAppndr.mkpath_umask = 0027 +EOT + + Log::Log4perl::init(\$data); + $log = Log::Log4perl::get_logger(""); + $log->info("Shu-wa-chi!"); + + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat("${testpath}_1"); + + is($mode & 07777,0750); #Win32 777 + + ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, $atime,$mtime,$ctime,$blksize,$blocks) = stat($testmkpathfile); + + is($mode & 07777,0640); #Win32 666 + + is(umask,$oldumask); +}; diff --git a/t/027Watch2.t b/t/027Watch2.t new file mode 100644 index 0000000..2fe25b5 --- /dev/null +++ b/t/027Watch2.t @@ -0,0 +1,218 @@ +#testing init_and_watch +#special problem with init_and_watch, +#fixed in Logger::reset by setting logger level to OFF + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; + +use warnings; +use strict; + +use Log::Log4perl qw(:easy); +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +BEGIN { + if ($] < 5.006) { + plan skip_all => "Only with perl >= 5.006"; + } else { + plan tests => 21; + } +} + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = "t/tmp"; +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $testconf= "$WORK_DIR/test27.conf"; +unlink $testconf if (-e $testconf); + +#goto NEW; +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf1 = <<EOL; +log4j.category = WARN, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.dog = DEBUG, goneAppender + +log4j.appender.goneAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.goneAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.cat = INFO, myAppender + +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf1; +close CONF; + + +Log::Log4perl->init_and_watch($testconf, 1); + +my $logger = Log::Log4perl::get_logger('animal.dog'); + +ok( $logger->is_debug(), "is_debug - true"); +ok( $logger->is_info(), "is_info - true"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +$logger->debug('debug message, should appear'); + +is($app0->buffer(), "DEBUG - debug message, should appear\n"); + + +#--------------------------- +#now go to sleep and reload + +print "sleeping for 3 seconds\n"; +sleep 3; + +$conf1 = <<EOL; +log4j.category = WARN, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + +#*****log4j.category.animal.dog = DEBUG, goneAppender + +#*****log4j.appender.goneAppender = Log::Log4perl::Appender::TestBuffer +#*****log4j.appender.goneAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.cat = INFO, myAppender + +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf1; +close CONF; + +ok(! $logger->is_debug(), "is_debug - false"); +ok(! $logger->is_info(), "is_info - false"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +#now the logger is ruled by root/s WARN level +$logger->debug('debug message, should NOT appear'); + +my $app1 = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +is($app1->buffer(), "", "buffer empty"); + +$logger->warn('warning message, should appear'); + +is($app1->buffer(), "WARN - warning message, should appear\n", "warn in"); + +#check the root logger +$logger = Log::Log4perl::get_logger(); + +$logger->warn('warning message, should appear'); + +like($app1->buffer(), qr/(WARN - warning message, should appear\n){2}/, + "2nd warn in"); + +# ------------------------------------------- +#double-check an unrelated category with a lower level +$logger = Log::Log4perl::get_logger('animal.cat'); +$logger->info('warning message to cat, should appear'); + +like($app1->buffer(), qr/(WARN - warning message, should appear\n){2}INFO - warning message to cat, should appear/, "message output"); + +NEW: +############################################################################ +# This was a bug in L4p 1.01: After init_and_watch() caused a re-init, +# filename/linenumber were referring to 'eval', not the actual file +# name/line number of the message. + +my $counter = 0; +my $reload_permitted = 1; +conf_file_write(); +Log::Log4perl->init_and_watch($testconf, 1, { + preinit_callback => sub { + $counter++; +#print "Counter incremented to $counter\n"; + return $reload_permitted; + }, +}); + + +my $line_ref = __LINE__ + 1; +DEBUG("first"); + my $buf = Log::Log4perl::Appender::TestBuffer->by_name("Testbuffer"); + like($buf->buffer(), qr/027Watch2.t $line_ref> first/, + "init-and-watch caller level first"); + $buf->buffer(""); + +print "Sleeping 1 second\n"; +sleep(1); +conf_file_write(); +$line_ref = __LINE__ + 1; +DEBUG("second"); + $buf = Log::Log4perl::Appender::TestBuffer->by_name("Testbuffer"); + like($buf->buffer(), qr/027Watch2.t $line_ref> second/, + "init-and-watch caller level second"); + $buf->buffer(""); + +$reload_permitted = 0; +print "Sleeping 2 seconds\n"; +sleep(2); +conf_file_write("FATAL"); +$line_ref = __LINE__ + 1; +DEBUG("third"); + $buf = Log::Log4perl::Appender::TestBuffer->by_name("Testbuffer"); + like($buf->buffer(), qr/027Watch2.t $line_ref> third/, + "init-and-watch caller level third"); + $buf->buffer(""); + +$reload_permitted = 1; +print "Sleeping 2 seconds\n"; +sleep(2); +conf_file_write("ERROR"); +$line_ref = __LINE__ + 1; +ERROR("third"); + $buf = Log::Log4perl::Appender::TestBuffer->by_name("Testbuffer"); + like($buf->buffer(), qr/027Watch2.t $line_ref> third/, + "init-and-watch caller level third"); + $buf->buffer(""); + +ok($counter >= 1, "Callback counter check"); + +print "Sleeping 2 seconds\n"; +sleep(2); +ERROR("fourth"); +like $buf->buffer(), qr/main-main:: 027Watch2.t/, + "[rt.cpan.org #60386] caller level check"; + +########################################### +sub conf_file_write { +########################################### + my($level) = @_; + + $level = "DEBUG" unless defined $level; + + open FILE, ">$testconf" or die $!; + print FILE <<EOT; +log4perl.category.main = $level, Testbuffer +log4perl.appender.Testbuffer = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Testbuffer.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.Testbuffer.layout.ConversionPattern = %d %C-%M %F{1} %L> %m %n +EOT + close FILE; +#print "Config written\n"; +} + +unlink $testconf; diff --git a/t/027Watch3.t b/t/027Watch3.t new file mode 100644 index 0000000..a07a959 --- /dev/null +++ b/t/027Watch3.t @@ -0,0 +1,152 @@ +#testing init_and_watch +#same as 027Watch2, just with signal handling instead of watch/delay code + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; +use Test::More; +use Config; + +our $SIGNALS_AVAILABLE = 0; + +BEGIN { + no warnings; + # Check if this platform supports signals + if (length $Config{sig_name} and length $Config{sig_num}) { + eval { + $SIG{USR1} = sub { $SIGNALS_AVAILABLE = 1 }; + # From the Config.pm manpage + my(%sig_num); + my @names = split ' ', $Config{sig_name}; + @sig_num{@names} = split ' ', $Config{sig_num}; + + kill $sig_num{USR1}, $$; + }; + if($@) { + $SIGNALS_AVAILABLE = 0; + } + } + + if ($SIGNALS_AVAILABLE) { + plan tests => 15; + }else{ + plan skip_all => "only on platforms supporting signals"; + } +} + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $testconf= File::Spec->catfile($WORK_DIR, "test27.conf"); +unlink $testconf if (-e $testconf); + +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf1 = <<EOL; +log4j.category = WARN, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.dog = DEBUG, goneAppender + +log4j.appender.goneAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.goneAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.cat = INFO, myAppender + +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf1; +close CONF; + +Log::Log4perl->init_and_watch($testconf, 'HUP'); + +my $logger = Log::Log4perl::get_logger('animal.dog'); + +ok( $logger->is_debug(), "is_debug - true"); +ok( $logger->is_info(), "is_info - true"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +$logger->debug('debug message, should appear'); + +is($app0->buffer(), "DEBUG - debug message, should appear\n", "debug()"); + + +#--------------------------- +#now reload and then signal + +$conf1 = <<EOL; +log4j.category = WARN, myAppender + +log4j.appender.myAppender = Log::Log4perl::Appender::TestBuffer +log4j.appender.myAppender.layout = Log::Log4perl::Layout::SimpleLayout + +#*****log4j.category.animal.dog = DEBUG, goneAppender + +#*****log4j.appender.goneAppender = Log::Log4perl::Appender::TestBuffer +#*****log4j.appender.goneAppender.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.category.animal.cat = INFO, myAppender + +EOL +open (CONF, ">$testconf") || die "can't open $testconf $!"; +print CONF $conf1; +close CONF; + +#--------------------------- +# send the signal to the process itself +kill(1, $$) or die "Cannot signal"; + +ok(! $logger->is_debug(), "is_debug - false"); +ok(! $logger->is_info(), "is_info - false"); +ok( $logger->is_warn(), "is_warn - true"); +ok( $logger->is_error(), "is_error - true"); +ok( $logger->is_fatal(), "is_fatal - true"); + +#now the logger is ruled by root's WARN level +$logger->debug('debug message, should NOT appear'); + +my $app1 = Log::Log4perl::Appender::TestBuffer->by_name("myAppender"); + +is($app1->buffer(), "", "buffer empty"); + +$logger->warn('warning message, should appear'); + +is($app1->buffer(), "WARN - warning message, should appear\n", "warn in"); + +#check the root logger +$logger = Log::Log4perl::get_logger(); + +$logger->warn('warning message, should appear'); + +like($app1->buffer(), qr/(WARN - warning message, should appear\n){2}/, + "2nd warn in"); + +# ------------------------------------------- +#double-check an unrelated category with a lower level +$logger = Log::Log4perl::get_logger('animal.cat'); +$logger->info('warning message to cat, should appear'); + +like($app1->buffer(), qr/(WARN - warning message, should appear\n){2}INFO - warning message to cat, should appear/, "message output"); + +unlink $testconf; diff --git a/t/027Watch4.t b/t/027Watch4.t new file mode 100755 index 0000000..6f61097 --- /dev/null +++ b/t/027Watch4.t @@ -0,0 +1,44 @@ +#!/usr/local/bin/perl -w + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use strict; +use warnings; +use Test::More; +use Log::Log4perl::Config::Watch; + +plan tests => 4; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + + # sample file to run tests on +my $file = "$EG_DIR/log4j-manual-1.conf"; + +my $w = Log::Log4perl::Config::Watch->new( + file => $file, + signal => 'USR1', +); + +$w->change_detected(); +$Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_DETECTED = 0; +$Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_CHECKED = 0; +$w->change_detected(); + +is($Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_CHECKED, + 0, "no change checked without signal"); +is($Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_DETECTED, + 0, "no change detected without signal"); + +$w->force_next_check(); +$w->change_detected(); + +is($Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_CHECKED, + 1, "change checked after force_next_check()"); +is($Log::Log4perl::Config::Watch::L4P_TEST_CHANGE_DETECTED, + 0, "no change detected after force_next_check()"); diff --git a/t/028Additivity.t b/t/028Additivity.t new file mode 100644 index 0000000..118d09a --- /dev/null +++ b/t/028Additivity.t @@ -0,0 +1,124 @@ +########################################### +# Test Suite for Appender additivity +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +######################### +# change 'tests => 1' to 'tests => last_test_to_print'; +######################### +use Test; +BEGIN { plan tests => 9 }; + +use Log::Log4perl qw(get_logger :levels); +use Log::Log4perl::Appender::TestBuffer; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +ok(1); # If we made it this far, we're ok. + +###################################################################### +# Define the root logger and another logger, additivity on +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.logger = INFO, A1 + log4perl.logger.Twix.Bar = DEBUG, A2 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + log4perl.appender.A2=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A2.layout=Log::Log4perl::Layout::SimpleLayout +EOT + +my $logger = get_logger("Twix::Bar"); +$logger->info("Percolate this!"); + +my $buf1 = Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(); +my $buf2 = Log::Log4perl::Appender::TestBuffer->by_name("A2")->buffer(); + +ok($buf1, "INFO - Percolate this!\n"); +ok($buf2, "INFO - Percolate this!\n"); + +Log::Log4perl::Appender::TestBuffer->reset(); + +###################################################################### +# Define the root logger and another logger, additivity off +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.logger = INFO, A1 + log4perl.logger.Twix.Bar = DEBUG, A2 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + log4perl.appender.A2=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A2.layout=Log::Log4perl::Layout::SimpleLayout + log4perl.additivity.Twix.Bar = false +EOT + +$logger = get_logger("Twix::Bar"); +$logger->info("Percolate this!"); + +$buf1 = Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(); +$buf2 = Log::Log4perl::Appender::TestBuffer->by_name("A2")->buffer(); + +ok($buf1, ""); # Not supposed to show up in the root logger +ok($buf2, "INFO - Percolate this!\n"); + +Log::Log4perl::Appender::TestBuffer->reset(); + +###################################################################### +# Define the root logger and another logger, additivity on explicitely +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.logger = INFO, A1 + log4perl.logger.Twix.Bar = DEBUG, A2 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + log4perl.appender.A2=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A2.layout=Log::Log4perl::Layout::SimpleLayout + log4perl.additivity.Twix.Bar = true +EOT + +$logger = get_logger("Twix::Bar"); +$logger->info("Percolate this!"); + +$buf1 = Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(); +$buf2 = Log::Log4perl::Appender::TestBuffer->by_name("A2")->buffer(); + +ok($buf1, "INFO - Percolate this!\n"); +ok($buf2, "INFO - Percolate this!\n"); + +Log::Log4perl::Appender::TestBuffer->reset(); + +###################################################################### +# Additivity set via method after init +# https://github.com/mschilli/log4perl/issues/29 +###################################################################### +Log::Log4perl->init(\<<'EOT'); + log4perl.rootLogger = INFO, A1 + log4perl.logger.Twix.Bar = INFO, A2 + + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout + + log4perl.appender.A2=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A2.layout=Log::Log4perl::Layout::SimpleLayout +EOT + +$logger = get_logger("Twix::Bar"); +$logger->level( $INFO ); +$logger->additivity( 0 ); +$logger->info("Only for Twix"); + +$buf1 = Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(); +$buf2 = Log::Log4perl::Appender::TestBuffer->by_name("A2")->buffer(); + +ok($buf1, ""); +ok($buf2, "INFO - Only for Twix\n"); + +Log::Log4perl::Appender::TestBuffer->reset(); diff --git a/t/029SysWide.t b/t/029SysWide.t new file mode 100644 index 0000000..353610e --- /dev/null +++ b/t/029SysWide.t @@ -0,0 +1,123 @@ +########################################### +# Test Suite for Log::Log4perl::Logger +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test; + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; + +BEGIN { plan tests => 6 } + +ok(1); # If we made it this far, we're ok. + +################################################## +# System-wide threshold +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf = <<EOT; +log4perl.logger.a = INFO, BUF0 +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +log4perl.threshold = ERROR +EOT + +Log::Log4perl::init(\$conf); + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); + +my $loga = get_logger("a"); + +$loga->info("Don't want to see this"); +$loga->error("Yeah, loga"); + +ok($app0->buffer(), "ERROR - Yeah, loga\n"); + +################################################## +# System-wide threshold with appender threshold +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = <<EOT; +log4perl.logger = ERROR, BUF0 +log4perl.logger.a = INFO, BUF1 +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +log4perl.appender.BUF0.Threshold = WARN +log4perl.appender.BUF1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF1.layout = Log::Log4perl::Layout::SimpleLayout +log4perl.appender.BUF1.Threshold = INFO +log4perl.threshold = ERROR +EOT + +Log::Log4perl::init(\$conf); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +my $app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +$loga = get_logger("a"); + +$loga->info("Don't want to see this"); +$loga->error("Yeah, loga"); + +ok($app0->buffer(), "ERROR - Yeah, loga\n"); +ok($app1->buffer(), "ERROR - Yeah, loga\n"); + +############################################################ +# System-wide threshold shouldn't lower appender thresholds +############################################################ +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = q( +log4perl.threshold = DEBUG +log4perl.category = INFO, BUF0 +log4perl.appender.BUF0.Threshold = WARN +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl::init(\$conf); + +my $logger = get_logger(); +$logger->info("Blah"); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +ok($app0->buffer(), "", "syswide threshold shouldn't lower app thresholds"); + +############################################################ +# System-wide threshold shouldn't lower appender thresholds +############################################################ +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = q( +log4perl.threshold = ERROR +log4perl.category = INFO, BUF0 +log4perl.appender.BUF0.Threshold = DEBUG +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl::init(\$conf); + +$logger = get_logger(); +$logger->warn("Blah"); + +$app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); +ok($app0->buffer(), "", "syswide threshold trumps thresholds"); diff --git a/t/030LDLevel.t b/t/030LDLevel.t new file mode 100644 index 0000000..7594d32 --- /dev/null +++ b/t/030LDLevel.t @@ -0,0 +1,55 @@ +########################################### +# Test Suite for Log::Log4perl::Logger +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test; + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; + +BEGIN { plan tests => 2 } + +ok(1); # If we made it this far, we're ok. + +# Have TestBuffer log the Log::Dispatch priority +$Log::Log4perl::Appender::TestBuffer::LOG_PRIORITY = 1; +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf = <<EOT; +log4perl.logger = ALL, BUF0 +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +Log::Log4perl::init(\$conf); + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); + +my $loga = get_logger("a"); + +$loga->debug("debug"); +$loga->info("info"); +$loga->warn("warn"); +$loga->error("error"); +$loga->fatal("fatal"); + +ok($app0->buffer(), + "[0]: DEBUG - debug\n" . + "[1]: INFO - info\n" . + "[3]: WARN - warn\n" . + "[4]: ERROR - error\n" . + "[7]: FATAL - fatal\n" . + "" + ); diff --git a/t/031NDC.t b/t/031NDC.t new file mode 100644 index 0000000..db8dbc3 --- /dev/null +++ b/t/031NDC.t @@ -0,0 +1,105 @@ +########################################### +# Test Suite Log::Log4perl::NDC +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test; + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; +use Log::Log4perl::NDC; +use Log::Log4perl::MDC; + +BEGIN { plan tests => 3 } + +# Have TestBuffer log the Log::Dispatch priority +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf = <<EOT; +log4perl.logger = ALL, BUF0 +log4perl.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF0.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.BUF0.layout.ConversionPattern = %m <%x> +EOT + +Log::Log4perl::init(\$conf); + +my $app0 = Log::Log4perl::Appender::TestBuffer->by_name("BUF0"); + +my $loga = get_logger("a"); + +Log::Log4perl::NDC->push("first"); +$loga->debug("debug"); + + # Push more than MAX +Log::Log4perl::NDC->push("second"); +Log::Log4perl::NDC->push("third"); +Log::Log4perl::NDC->push("fourth"); +Log::Log4perl::NDC->push("fifth"); +Log::Log4perl::NDC->push("sixth"); +$loga->info("info"); + + # Delete NDC stack +Log::Log4perl::NDC->remove(); +$loga->warn("warn"); + +Log::Log4perl::NDC->push("seventh"); +$loga->error("error"); + +ok($app0->buffer(), + "debug <first>info <first second third fourth sixth>warn <[undef]>error <seventh>"); + +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl::MDC->put("remote_host", "blah-host"); +Log::Log4perl::MDC->put("ip", "blah-ip"); + +$conf = <<EOT; +log4perl.logger = ALL, BUF1 +log4perl.appender.BUF1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF1.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.BUF1.layout.ConversionPattern = %X{remote_host}: %m %X{ip}%n +EOT + +Log::Log4perl::init(\$conf); + +my $app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +my $logb = get_logger("b"); + +$logb->debug("testmessage"); + +ok($app1->buffer(), + "blah-host: testmessage blah-ip\n"); + +# Check what happens if %X is used with an undef value +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = <<EOT; +log4perl.logger = ALL, BUF1 +log4perl.appender.BUF1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.BUF1.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.BUF1.layout.ConversionPattern = %X{quack}: %m %X{ip}%n +EOT + +Log::Log4perl::init(\$conf); + +$app1 = Log::Log4perl::Appender::TestBuffer->by_name("BUF1"); + +$logb = get_logger("b"); + +$logb->debug("testmessage"); + +ok($app1->buffer(), + "[undef]: testmessage blah-ip\n"); diff --git a/t/032JRollFile.t b/t/032JRollFile.t new file mode 100644 index 0000000..82684c8 --- /dev/null +++ b/t/032JRollFile.t @@ -0,0 +1,73 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test::More; +use File::Spec; + +BEGIN { + eval { + require Log::Dispatch::FileRotate; + }; + if ($@ or $Log::Dispatch::FileRotate::VERSION < 1.10) { + plan skip_all => "only with Log::Dispatch::FileRotate 1.10"; + } else { + plan tests => 2; + } +} + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +use vars qw(@outfiles); @outfiles = (File::Spec->catfile($WORK_DIR, 'rolltest.log'), + File::Spec->catfile($WORK_DIR, 'rolltest.log.1'), + File::Spec->catfile($WORK_DIR, 'rolltest.log.2'),); + +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} + +my $conf = <<CONF; +log4j.category.cat1 = INFO, myAppender + +log4j.appender.myAppender=org.apache.log4j.RollingFileAppender +log4j.appender.myAppender.File=@{[File::Spec->catfile($WORK_DIR, 'rolltest.log')]} +#this will roll the file after one write +log4j.appender.myAppender.MaxFileSize=1024 +log4j.appender.myAppender.MaxBackupIndex=2 +log4j.appender.myAppender.layout=org.apache.log4j.PatternLayout +log4j.appender.myAppender.layout.ConversionPattern=%-5p %c - %m%n + +CONF + +Log::Log4perl->init(\$conf); + +my $logger = Log::Log4perl->get_logger('cat1'); + +$logger->debug("x" x 1024 . "debugging message 1 "); +$logger->info("x" x 1024 . "info message 1 "); +$logger->warn("x" x 1024 . "warning message 1 "); +$logger->fatal("x" x 1024 . "fatal message 1 "); + +my $rollfile = File::Spec->catfile($WORK_DIR, 'rolltest.log.2'); + +open F, $rollfile or die "Cannot open $rollfile"; +my $result = <F>; +close F; +like($result, qr/^INFO cat1 - x+info message 1/); + +#MaxBackupIndex is 2, so this file shouldn't exist +ok(! -e File::Spec->catfile($WORK_DIR, 'rolltest.log.3')); + +foreach my $f (@outfiles){ + unlink $f if (-e $f); +} diff --git a/t/033UsrCspec.t b/t/033UsrCspec.t new file mode 100644 index 0000000..36651be --- /dev/null +++ b/t/033UsrCspec.t @@ -0,0 +1,314 @@ +#testing user-defined conversion specifiers (cspec) + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; +use File::Spec; + +Log::Log4perl::Appender::TestBuffer->reset(); + + +my $config = <<'EOL'; +log4j.category.plant = DEBUG, appndr1 +log4j.category.animal = DEBUG, appndr2 + +#'U' a global user-defined cspec +log4j.PatternLayout.cspec.U = \ + sub { \ + return "UID $< GID $("; \ + } \ + + +# ******************** +# first appender +log4j.appender.appndr1 = Log::Log4perl::Appender::TestBuffer +#log4j.appender.appndr1 = Log::Log4perl::Appender::Screen +log4j.appender.appndr1.layout = org.apache.log4j.PatternLayout +log4j.appender.appndr1.layout.ConversionPattern = %K xx %G %U + +#'K' cspec local to appndr1 (pid in hex) +log4j.appender.appndr1.layout.cspec.K = sub { return sprintf "%1x", $$} + +#'G' cspec unique to appdnr1 +log4j.appender.appndr1.layout.cspec.G = sub {return 'thisistheGcspec'} + + + +# ******************** +# second appender +log4j.appender.appndr2 = Log::Log4perl::Appender::TestBuffer +#log4j.appender.appndr2 = Log::Log4perl::Appender::Screen +log4j.appender.appndr2.layout = org.apache.log4j.PatternLayout +log4j.appender.appndr2.layout.ConversionPattern = %K %U + +#'K' cspec local to appndr2 +log4j.appender.appndr2.layout.cspec.K = \ + sub { \ + my ($self, $message, $category, $priority, $caller_level) = @_; \ + $message =~ /--- (.+) ---/; \ + my $snippet = $1; \ + return ucfirst(lc($priority)).'-'.$snippet.'-'.ucfirst(lc($priority)); \ + } + +#override global 'U' cspec +log4j.appender.appndr2.layout.cspec.U = sub {return 'foobar'} + +EOL + + +Log::Log4perl::init(\$config); + +my $plant = Log::Log4perl::get_logger('plant'); +my $animal = Log::Log4perl::get_logger('animal'); + + +my $hexpid = sprintf "%1x", $$; +my $uid = $<; +my $gid = $(; + + +my $plantbuffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr1"); +my $animalbuffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr2"); + +$plant->fatal('blah blah blah --- plant --- yadda yadda'); +is($plantbuffer->buffer(), "$hexpid xx thisistheGcspec UID $uid GID $gid"); +$plantbuffer->reset; + +$animal->fatal('blah blah blah --- animal --- yadda yadda'); +is($animalbuffer->buffer(), "Fatal-animal-Fatal foobar"); +$animalbuffer->reset; + +$plant->error('blah blah blah --- plant --- yadda yadda'); +is($plantbuffer->buffer(), "$hexpid xx thisistheGcspec UID $uid GID $gid"); +$plantbuffer->reset; + +$animal->error('blah blah blah --- animal --- yadda yadda'); +is($animalbuffer->buffer(), "Error-animal-Error foobar"); +$animalbuffer->reset; + +$plant->warn('blah blah blah --- plant --- yadda yadda'); +is($plantbuffer->buffer(), "$hexpid xx thisistheGcspec UID $uid GID $gid"); +$plantbuffer->reset; + +$animal->warn('blah blah blah --- animal --- yadda yadda'); +is($animalbuffer->buffer(), "Warn-animal-Warn foobar"); +$animalbuffer->reset; + +$plant->info('blah blah blah --- plant --- yadda yadda'); +is($plantbuffer->buffer(), "$hexpid xx thisistheGcspec UID $uid GID $gid"); +$plantbuffer->reset; + +$animal->info('blah blah blah --- animal --- yadda yadda'); +is($animalbuffer->buffer(), "Info-animal-Info foobar"); +$animalbuffer->reset; + +$plant->debug('blah blah blah --- plant --- yadda yadda'); +is($plantbuffer->buffer(), "$hexpid xx thisistheGcspec UID $uid GID $gid"); +$plantbuffer->reset; + +$animal->debug('blah blah blah --- animal --- yadda yadda'); +is($animalbuffer->buffer(), "Debug-animal-Debug foobar"); +$animalbuffer->reset; + + +#now test the api call we're adding + +Log::Log4perl::Layout::PatternLayout::add_global_cspec('Z', sub {'zzzzzzzz'}); #snooze? + + +my $app = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer"); + +my $logger = Log::Log4perl->get_logger("plant"); +$logger->add_appender($app); +my $layout = Log::Log4perl::Layout::PatternLayout->new( + "%m %Z"); +$app->layout($layout); +$logger->debug("That's the message"); + +is($app->buffer(), "That's the message zzzzzzzz"); + +########################################################### +#testing perl code snippets in Log4perl configuration files +########################################################### + +Log::Log4perl::Appender::TestBuffer->reset(); + +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = sub { \ + return "Log::Log4perl::Appender::TestBuffer" } +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout + # This should be evaluated at config parse time ("%m %K%n") +log4perl.appender.appndr.layout.ConversionPattern = sub{ "%" . \ + chr(109) . " %K%n"; } + + # This should be evaluated at run time ('K' cspec) +log4perl.appender.appndr.layout.cspec.K = sub { $ENV{TEST_VALUE} } +EOL + +Log::Log4perl::init(\$config); + +$ENV{TEST_VALUE} = "env_value"; + +$logger = Log::Log4perl::get_logger('some'); +$logger->debug("log_message"); + +$ENV{TEST_VALUE} = "env_value2"; +$logger->info("log_message2"); + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr"); + +#print "Testbuffer: ", $buffer->buffer(), "\n"; + +is($buffer->buffer(), "log_message env_value\nlog_message2 env_value2\n"); + +########################################################### +#testing perl code snippets with ALLOW_CODE_IN_CONFIG_FILE +#disabled +########################################################### + +Log::Log4perl::Appender::TestBuffer->reset(); + +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = Log::Log4perl::Appender::TestBuffer +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout + # This should be evaluated at config parse time ("%m %K%n") +log4perl.appender.appndr.layout.ConversionPattern = sub{ "%m" . \ + chr(109) . " %n"; } +EOL + +Log::Log4perl::Config::allow_code(0); + +eval { + Log::Log4perl::init(\$config); +}; + +print "ERR is $@\n"; + +if($@ and $@ =~ /prohibits/) { + ok(1); +} else { + ok(0); +} + +# Test if cspecs are denied +Log::Log4perl::Appender::TestBuffer->reset(); + +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = Log::Log4perl::Appender::TestBuffer +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.appndr.layout.ConversionPattern = %m %n +log4perl.appender.appndr.layout.cspec.K = sub { $ENV{TEST_VALUE} } +EOL + +Log::Log4perl::Config->allow_code(0); + +eval { + Log::Log4perl::init(\$config); +}; + +print "ERR is $@\n"; + +if($@ and $@ =~ /prohibits/) { + ok(1); +} else { + ok(0); +} + +################################################################ +# Test if cspecs are passing the correct caller level +################################################################ +Log::Log4perl::Config::allow_code(1); +Log::Log4perl::Appender::TestBuffer->reset(); + +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = Log::Log4perl::Appender::TestBuffer +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.appndr.layout.ConversionPattern = %K %m %n +log4perl.appender.appndr.layout.cspec.K = sub { return (caller($_[4]))[1] } +EOL + +Log::Log4perl::init(\$config); + +my $some = Log::Log4perl::get_logger('some'); +$some->debug("blah"); + +my $somebuffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr"); + +like($somebuffer->buffer(), qr/033UsrCspec.t blah/); + +################################################################ +# cspecs with parameters in curlies +################################################################ +Log::Log4perl::Config::allow_code(1); +Log::Log4perl::Appender::TestBuffer->reset(); + +our %hash = (foo => "bar", quack => "schmack"); +$hash{hollerin} = "hootin"; # shut up perl warnings + +use Data::Dumper; +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = Log::Log4perl::Appender::TestBuffer +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.appndr.layout.ConversionPattern = %K{foo} %m %K{quack}%n +log4perl.appender.appndr.layout.cspec.K = sub { $main::hash{$_[0]->{curlies} } } +EOL + +Log::Log4perl::init(\$config); + +$some = Log::Log4perl::get_logger('some'); +$some->debug("blah"); + +$somebuffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr"); + +is($somebuffer->buffer(), "bar blah schmack\n"); + +################################################################ +# Get the calling package from a cspec +################################################################ +Log::Log4perl::Config::allow_code(1); +Log::Log4perl::Appender::TestBuffer->reset(); + +$config = <<'EOL'; +log4perl.category.some = DEBUG, appndr + + # This should be evaluated at config parse time +log4perl.appender.appndr = Log::Log4perl::Appender::TestBuffer +log4perl.appender.appndr.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.appndr.layout.ConversionPattern = %K %m%n +log4perl.appender.appndr.layout.cspec.K = \ + sub { scalar caller( $_[4] )} +EOL + +Log::Log4perl::init(\$config); + +$some = Log::Log4perl::get_logger('some'); +$some->debug("blah"); + +$somebuffer = Log::Log4perl::Appender::TestBuffer->by_name("appndr"); + +is($somebuffer->buffer(), "main blah\n"); + +BEGIN { plan tests => 17, } diff --git a/t/034DBI.t b/t/034DBI.t new file mode 100644 index 0000000..3ddea6e --- /dev/null +++ b/t/034DBI.t @@ -0,0 +1,328 @@ +########################################### +# Test using Log::Dispatch::DBI +# Kevin Goess <cpan@goess.org> +########################################### + +our $table_name = "log4perltest$$"; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +BEGIN { + use FindBin qw($Bin); + use lib "$Bin/lib"; + require Log4perlInternalTest; +} + +use Test::More; +use Log::Log4perl; +use warnings; +use strict; + +BEGIN { + my $minversion = \%Log::Log4perl::Internal::Test::MINVERSION; + eval { + require DBI; + die if $DBI::VERSION < $minversion->{ "DBI" }; + + require DBD::CSV; + die if $DBD::CSV::VERSION < $minversion->{ "DBD::CSV" }; + + require SQL::Statement; + die if $SQL::Statement::VERSION < $minversion->{ "SQL::Statement" }; + }; + if ($@) { + plan skip_all => + "DBI $minversion->{ DBI } or " . + "DBD::CSV $minversion->{'DBD::CSV'} or " . + "SQL::Statement $minversion->{'SQL::Statement'} " . + "not installed, skipping tests\n"; + }else{ + plan tests => 33; + } +} + +END { + unlink "t/tmp/$table_name"; + rmdir "t/tmp"; +} + +mkdir "t/tmp" unless -d "t/tmp"; + +require DBI; +my $dbh = DBI->connect('DBI:CSV:f_dir=t/tmp','testuser','testpw',{ RaiseError => 1, PrintError => 1 }); + +$dbh->do("DROP TABLE $table_name") if -e "t/tmp/$table_name"; + +my $stmt = <<EOL; + CREATE TABLE $table_name ( + loglevel char(9) , + message char(128), + shortcaller char(5), + thingid char(6), + category char(16), + pkg char(16), + runtime1 char(16), + runtime2 char(16) + ) +EOL + +$dbh->do($stmt); + +#creating a log statement where bind values 1,3,5 and 6 are +#calculated from conversion specifiers and 2,4,7,8 are +#calculated at runtime and fed to the $logger->whatever(...) +#statement + +my $config = <<"EOT"; +#log4j.category = WARN, DBAppndr, console +log4j.category = WARN, DBAppndr +log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI +log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp +log4j.appender.DBAppndr.username = bobjones +log4j.appender.DBAppndr.password = 12345 +log4j.appender.DBAppndr.sql = \\ + insert into $table_name \\ + (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) \\ + values (?,?,?,?,?,?,?,?) +log4j.appender.DBAppndr.params.1 = %p +#---------------------------- #2 is message +log4j.appender.DBAppndr.params.3 = %5.5l +#---------------------------- #4 is thingid +log4j.appender.DBAppndr.params.5 = %c +log4j.appender.DBAppndr.params.6 = %C +#-----------------------------#7,8 are also runtime + +log4j.appender.DBAppndr.bufferSize=2 +log4j.appender.DBAppndr.warp_message=0 + +#noop layout to pass it through +log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + +#a console appender for debugging +log4j.appender.console = Log::Log4perl::Appender::Screen +log4j.appender.console.layout = Log::Log4perl::Layout::SimpleLayout + + +EOT + +Log::Log4perl::init(\$config); + + +# ********************* +# check a category logger + +my $logger = Log::Log4perl->get_logger("groceries.beer"); + + +$logger->fatal('fatal message',1234,'foo',{aaa => 'aaa'}); + +#since we ARE buffering, that message shouldnt be there yet +{ + local $/ = undef; + open (F, "t/tmp/$table_name"); + my $got = <F>; + close F; + my $expected = <<EOL; +LOGLEVEL,MESSAGE,SHORTCALLER,THINGID,CATEGORY,PKG,RUNTIME1,RUNTIME2 +EOL + $got =~ s/[^\w ,"()]//g; #silly DBD_CSV uses funny EOL chars + $expected =~ s/[^\w ,"()]//g; + $got = lc $got; #accounting for variations in DBD::CSV behavior + $expected = lc $expected; + is($got, $expected, "buffered"); +} + +$logger->warn('warning message',3456,'foo','bar'); + +#with buffersize == 2, now they should write +{ + local $/ = undef; + open (F, "t/tmp/$table_name"); + my $got = <F>; + close F; + my $expected = <<EOL; +LOGLEVEL,MESSAGE,SHORTCALLER,THINGID,CATEGORY,PKG,RUNTIME1,RUNTIME2 +FATAL,"fatal message",main:,1234,groceries.beer,main,foo,HASH(0x84cfd64) +WARN,"warning message",main:,3456,groceries.beer,main,foo,bar +EOL + $got =~ s/[^\w ,"()]//g; #silly DBD_CSV uses funny EOL chars + $expected =~ s/[^\w ,"()]//g; + $got =~ s/HASH\(.+?\)//; + $expected =~ s/HASH\(.+?\)//; + $got = lc $got; #accounting for variations in DBD::CSV behavior + $expected = lc $expected; + is($got, $expected, "buffersize=2"); +} + + +# setting is WARN so the debug message should not go through +$logger->debug('debug message',99,'foo','bar'); +$logger->warn('warning message with two params',99, 'foo', 'bar'); +$logger->warn('another warning to kick the buffer',99, 'foo', 'bar'); + +my $sth = $dbh->prepare("select * from $table_name"); +$sth->execute; + +#first two rows are repeats from the last test +my $row = $sth->fetchrow_arrayref; +is($row->[0], 'FATAL'); +is($row->[1], 'fatal message'); +is($row->[3], '1234'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +like($row->[7], qr/HASH/); #verifying param checking for "filter=>sub{...} stuff + +$row = $sth->fetchrow_arrayref; +is($row->[0], 'WARN'); +is($row->[1], 'warning message'); +is($row->[3], '3456'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +is($row->[7], 'bar'); + +#these two rows should have undef for the final two params +$row = $sth->fetchrow_arrayref; +is($row->[0], 'WARN'); +is($row->[1], 'warning message with two params'); +is($row->[3], '99'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +is($row->[7], 'bar'); + +$row = $sth->fetchrow_arrayref; +is($row->[0], 'WARN'); +is($row->[1], 'another warning to kick the buffer'); +is($row->[3], '99'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +is($row->[7], 'bar'); +#that should be all +ok(!$sth->fetchrow_arrayref); + +$dbh->disconnect; + +# ************************************** +# checking usePreparedStmt, spurious warning bug reported by Brett Rann +# might as well give it a thorough check +Log::Log4perl->reset; + +unlink "t/tmp/$table_name" + if -e "t/tmp/$table_name"; + +$dbh = DBI->connect('DBI:CSV:f_dir=t/tmp','testuser','testpw',{ PrintError => 1 }); + +$stmt = <<EOL; + CREATE TABLE $table_name ( + loglevel char(9) , + message char(128) + + ) +EOL + +$dbh->do($stmt) || die "do failed on $stmt".$dbh->errstr; + + +$config = <<"EOT"; +log4j.category = WARN, DBAppndr +log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI +log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp +log4j.appender.DBAppndr.sql = \\ + insert into $table_name \\ + (loglevel, message) \\ + values (?,?) +log4j.appender.DBAppndr.params.1 = %p +#---------------------------- #2 is message + +log4j.appender.DBAppndr.usePreparedStmt=2 +log4j.appender.DBAppndr.warp_message=0 + +#noop layout to pass it through +log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + +EOT + +Log::Log4perl::init(\$config); + +$logger = Log::Log4perl->get_logger("groceries.beer"); + +$logger->fatal('warning message'); + +#since we're not buffering, this message should show up immediately +{ + local $/ = undef; + open (F, "t/tmp/$table_name"); + my $got = <F>; + close F; + my $expected = <<EOL; +LOGLEVEL,MESSAGE +FATAL,"warning message" +EOL + $got =~ s/[^\w ,"()]//g; #silly DBD_CSV uses funny EOL chars + $expected =~ s/[^\w ,"()]//g; + $got = lc $got; #accounting for variations in DBD::CSV behavior + $expected = lc $expected; + is($got, $expected); +} + +$logger->fatal('warning message'); + + # https://rt.cpan.org/Public/Bug/Display.html?id=79960 + # undef as NULL +$dbh->do("DROP TABLE $table_name"); +$stmt = <<EOL; + CREATE TABLE $table_name ( + loglevel char(9) , + message char(128), + mdc char(16) + + ) +EOL + +$dbh->do($stmt) || die "do failed on $stmt".$dbh->errstr; + +$config = <<"EOT"; +log4j.category = WARN, DBAppndr +log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI +log4j.appender.DBAppndr.datasource = DBI:CSV:f_dir=t/tmp +log4j.appender.DBAppndr.sql = \\ + insert into $table_name \\ + (loglevel, mdc, message) \\ + values (?, ?, ?) +log4j.appender.DBAppndr.params.1 = %p +log4j.appender.DBAppndr.params.2 = %X{foo} +#---------------------------- #3 is message + +log4j.appender.DBAppndr.usePreparedStmt=2 +log4j.appender.DBAppndr.warp_message=0 + +#noop layout to pass it through +log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + +EOT + +Log::Log4perl::init(\$config); + +$logger = Log::Log4perl->get_logger(); +$logger->warn('test message'); + +open (F, "t/tmp/$table_name"); +my $got = join '', <F>; +close F; + +my $expected = <<EOT; +loglevel,message,mdc +WARN,"test message", +EOT + +$got =~ s/[^\w ,"()]//g; #silly DBD_CSV uses funny EOL chars +$expected =~ s/[^\w ,"()]//g; +is $got, $expected, "dbi insert with NULL values"; diff --git a/t/035JDBCAppender.t b/t/035JDBCAppender.t new file mode 100644 index 0000000..868b3d9 --- /dev/null +++ b/t/035JDBCAppender.t @@ -0,0 +1,144 @@ +########################################### +# Test using Log::Dispatch::DBI +# Kevin Goess <cpan@goess.org> +########################################### + +use strict; +use warnings; + +our $table_name = "log4perl$$"; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; + +use Log::Log4perl; + +BEGIN { + use FindBin qw($Bin); + use lib "$Bin/lib"; + require Log4perlInternalTest; +} + +BEGIN { + my $minversion = \%Log::Log4perl::Internal::Test::MINVERSION; + eval { + require DBD::CSV; + die if $DBD::CSV::VERSION < $minversion->{ "DBD::CSV" }; + + require Log::Dispatch; + }; + if ($@) { + plan skip_all => + "only with Log::Dispatch and DBD::CSV $minversion->{'DBD::CSV'}"; + }else{ + plan tests => 14; + } +} + +END { + unlink "t/tmp/$table_name"; + rmdir "t/tmp"; +} + +mkdir "t/tmp" unless -d "t/tmp"; + +require DBI; +my $dbh = DBI->connect('DBI:CSV:f_dir=t/tmp','testuser','testpw',{ PrintError => 1 }); + +-e "t/tmp/$table_name" && $dbh->do("DROP TABLE $table_name"); + +my $stmt = <<EOL; + CREATE TABLE $table_name ( + loglevel char(9) , + message char(128), + shortcaller char(5), + thingid char(6), + category char(16), + pkg char(16), + runtime1 char(16), + runtime2 char(16) + + ) +EOL + +$dbh->do($stmt); + +#creating a log statement where bind values 1,3,5 and 6 are +#calculated from conversion specifiers and 2,4,7,8 are +#calculated at runtime and fed to the $logger->whatever(...) +#statement + +my $config = <<"EOT"; +#log4j.category = WARN, DBAppndr, console +log4j.category = WARN, DBAppndr +log4j.appender.DBAppndr = org.apache.log4j.jdbc.JDBCAppender +log4j.appender.DBAppndr.URL = jdbc:CSV:testdb://localhost:9999;f_dir=t/tmp +log4j.appender.DBAppndr.user = bobjones +log4j.appender.DBAppndr.password = 12345 +log4j.appender.DBAppndr.sql = \\ + insert into $table_name \\ + (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) \\ + values (?,?,?,?,?,?,?,?) +log4j.appender.DBAppndr.params.1 = %p +#---------------------------- #2 is message +log4j.appender.DBAppndr.params.3 = %5.5l +#---------------------------- #4 is thingid +log4j.appender.DBAppndr.params.5 = %c +log4j.appender.DBAppndr.params.6 = %C +#-----------------------------#7,8 are also runtime + +log4j.appender.DBAppndr.bufferSize=3 +log4j.appender.DBAppndr.warp_message=0 + +#noop layout to pass it through +log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout + +#a console appender for debugging +log4j.appender.console = Log::Log4perl::Appender::Screen +log4j.appender.console.layout = Log::Log4perl::Layout::SimpleLayout + +EOT + +Log::Log4perl::init(\$config); + + +# ********************* +# check a category logger + +my $logger = Log::Log4perl->get_logger("groceries.beer"); + +#$logger->fatal('fatal message',1234,'foo','bar'); +$logger->fatal('fatal message',1234,'foo', 'bar'); +$logger->warn('warning message',3456,'foo','bar'); +$logger->debug('debug message',99,'foo','bar'); + +my $sth = $dbh->prepare("select * from $table_name"); +$sth->execute; + +my $row = $sth->fetchrow_arrayref; +is($row->[0], 'FATAL'); +is($row->[1], 'fatal message'); +is($row->[3], '1234'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +is($row->[7], 'bar'); + +$row = $sth->fetchrow_arrayref; +is($row->[0], 'WARN'); +is($row->[1], 'warning message'); +is($row->[3], '3456'); +is($row->[4], 'groceries.beer'); +is($row->[5], 'main'); +is($row->[6], 'foo'); +is($row->[7], 'bar'); + +$dbh->do("DROP TABLE $table_name"); + +1; diff --git a/t/036JSyslog.t b/t/036JSyslog.t new file mode 100644 index 0000000..e3708d3 --- /dev/null +++ b/t/036JSyslog.t @@ -0,0 +1,68 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test; + +BEGIN {plan tests => 1} +ok(1); #always succeed + +#skipping on win32 systems +eval { + require Sys::Syslog; +}; +if ($@){ + print STDERR "Sys::Syslog not installed, skipping...\n"; + exit; +} + + +print <<EOL; + +Since syslog() doesn't return any value that indicates sucess or failure, +I'm just going to send messages to syslog. These messages should +appear in the log file generated by syslog(8): + +INFO - info message 1 +WARN - warning message 1 + +Error messages probably indicate problems with related syslog modules +that exist on some systems. + +EOL + + +my $conf = <<CONF; +log4j.category.cat1 = INFO, myAppender + +log4j.appender.myAppender=org.apache.log4j.SyslogAppender +log4j.appender.myAppender.Facility=local1 +log4j.appender.myAppender.layout=org.apache.log4j.SimpleLayout +CONF + + +#There seems to be problems with Sys::Syslog on some platforms. +#So we'll just run this, maybe it will work and maybe it won't. +#A failure won't keep Log4perl from installing, but it will give +#some indication to the user whether to expect syslog logging +#to work on their system. + +eval { + + Log::Log4perl->init(\$conf); + + my $logger = Log::Log4perl->get_logger('cat1'); + + + $logger->debug("debugging message 1 "); + $logger->info("info message 1 "); + $logger->warn("warning message 1 "); + +}; + + + diff --git a/t/037JWin32Event.t b/t/037JWin32Event.t new file mode 100644 index 0000000..a7f2460 --- /dev/null +++ b/t/037JWin32Event.t @@ -0,0 +1,59 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Log::Log4perl; +use Test::More; + + +#skipping on non-win32 systems +BEGIN { + eval { + require Log::Dispatch::Win32EventLog; + }; + if ($@){ + plan skip_all => "only with Log::Dispatch::Win32EventLog"; + } +}; + +print <<EOL; + +Since EventLog doesn't return any value that indicates sucess or failure, +I'm just going to send messages to the EventLog. You can see these +messages using the event viewer: + +INFO - info message 1 +WARN - warning message 1 + +(Probably prefaced with something like "The description for Event ID ( 0 ) +in Source ( t/037JWinEvent.t ) cannot be found... ") + + +EOL + + +my $conf = <<CONF; +log4j.category.cat1 = INFO, myAppender + +log4j.appender.myAppender=org.apache.log4j.NTEventLogAppender +log4j.appender.myAppender.source=$0 +log4j.appender.myAppender.layout=org.apache.log4j.SimpleLayout +CONF + +Log::Log4perl->init(\$conf); + +my $logger = Log::Log4perl->get_logger('cat1'); + + +$logger->debug("debugging message 1 "); +$logger->info("info message 1 "); +$logger->warn("warning message 1 "); + + +BEGIN {plan tests => 1} + +#if we didn't die, we got here +ok(1); diff --git a/t/038XML-DOM1.t b/t/038XML-DOM1.t new file mode 100644 index 0000000..b6f2c80 --- /dev/null +++ b/t/038XML-DOM1.t @@ -0,0 +1,287 @@ + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl; +use strict; +use warnings; +use Data::Dumper; +use File::Spec; +$SIG{__WARN__} = sub { die @_; }; + +our $no_XMLDOM; + +BEGIN { + my $dvrq = $Log::Log4perl::DOM_VERSION_REQUIRED; + + eval { + require XML::DOM; + XML::DOM->VERSION($dvrq); + my $dver = XML::DOM->VERSION($dvrq); + require XML::Parser; + my $pver = XML::Parser->VERSION; + if ($pver >= 2.32 && $dver <= 1.42){ + print STDERR "Your version of XML::DOM ($dver) is incompatible with your version of XML::Parser ($pver). You should upgrade your XML::DOM to 1.43 or greater.\n"; + die 'skip tests'; + } + + }; + if ($@) { + plan skip_all => "only with XML::DOM > $dvrq"; + }else{ + plan tests => 2; + } +} + +if ($no_XMLDOM){ + ok(1); + exit(0); +} + + +my $xmlconfig = <<EOL; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4j:configuration SYSTEM "log4j.dtd"> + +<log4j:configuration xmlns:log4j="http://jakarta.apache.org/log4j/" + threshold="debug"> + + <appender name="A1" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + </appender> + <appender name="A2" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + </appender> + <appender name="BUF0" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <param name="Threshold" value="error"/> + </appender> + <appender name="FileAppndr1" class="org.apache.log4j.FileAppender"> + <layout class="Log::Log4perl::Layout::PatternLayout"> + <param name="ConversionPattern" + value="%d %4r [%t] %-5p %c %t - %m%n"/> + </layout> + <param name="File" value="t/tmp/DOMtest"/> + <param name="Append" value="false"/> + </appender> + + <category name="a.b.c.d" additivity="false"> + <level value="warn"/> <!-- note lowercase! --> + <appender-ref ref="A1"/> + + </category> + <category name="a.b"> + <priority value="info"/> + <appender-ref ref="A1"/> + </category> + <category name="animal.dog"> + <priority value="info"/> + <appender-ref ref="FileAppndr1"/> + <appender-ref ref="A2"/> + </category> + <category name="animal"> + <priority value="info"/> + <appender-ref ref="FileAppndr1"/> + </category> + <category name="xa.b.c.d"> + <priority value="info"/> + <appender-ref ref="A2"/> + </category> + <category name="xa.b"> + <priority value="warn"/> + <appender-ref ref="A2"/> + </category> + + <root> + <priority value="warn"/> + <appender-ref ref="FileAppndr1"/> + </root> + + +</log4j:configuration> + +EOL + + +#Log::Log4perl::init(\$config); + +my $xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +my $propsconfig = <<EOL; +log4j.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.appender.A2 = Log::Log4perl::Appender::TestBuffer +log4j.appender.A2.layout = Log::Log4perl::Layout::SimpleLayout + +log4j.appender.BUF0 = Log::Log4perl::Appender::TestBuffer +log4j.appender.BUF0.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.BUF0.Threshold = ERROR + +log4j.appender.FileAppndr1 = org.apache.log4j.FileAppender +log4j.appender.FileAppndr1.layout = Log::Log4perl::Layout::PatternLayout +log4j.appender.FileAppndr1.layout.ConversionPattern = %d %4r [%t] %-5p %c %t - %m%n +log4j.appender.FileAppndr1.File = t/tmp/DOMtest +log4j.appender.FileAppndr1.Append = false + +log4j.category.a.b.c.d = WARN, A1 +log4j.category.a.b = INFO, A1 + +log4j.category.xa.b.c.d = INFO, A2 +log4j.category.xa.b = WARN, A2 + +log4j.category.animal = INFO, FileAppndr1 +log4j.category.animal.dog = INFO, FileAppndr1,A2 + +log4j.category = WARN, FileAppndr1 + +log4j.threshold = DEBUG + +log4j.additivity.a.b.c.d = 0 + +EOL + + + +my $propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +#brute force testing here, not very granular, but it is thorough + +eval {require Data::Dump}; +my $dump_available; +if (! $@) { + $dump_available = 1; +} + + +require File::Spec->catfile('t','compare.pl'); + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n"; + print STDERR "================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + +# =======================================================\ +# test variable substitutions +# more brute force + +$xmlconfig = <<'EOL'; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4j:configuration SYSTEM "log4j.dtd"> + +<log4j:configuration xmlns:log4j="http://jakarta.apache.org/log4j/" + threshold="${rootthreshold}"> + + <appender name="${A1}" class="${testbfr}"> + <layout class="${simplelayout}"/> + </appender> + <appender name="${A2}" class="${testbfr}"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + </appender> + <appender name="BUF0" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <param name="${appthreshold}" value="${appthreshlevel}"/> + </appender> + <appender name="FileAppndr1" class="org.apache.log4j.FileAppender"> + <layout class="Log::Log4perl::Layout::PatternLayout"> + <param name="${convpatt}" + value="${thepatt}"/> + </layout> + <param name="${pfile}" value="${pfileval}"/> + <param name="Append" value="false"/> + </appender> + + <category name="${abcd}" additivity="${abcd_add}"> + <level value="${abcd_level}"/> <!-- note lowercase! --> + <appender-ref ref="A1"/> + + </category> + <category name="a.b"> + <priority value="info"/> + <appender-ref ref="A1"/> + </category> + <category name="animal.dog"> + <priority value="info"/> + <appender-ref ref="FileAppndr1"/> + <appender-ref ref="A2"/> + </category> + <category name="animal"> + <priority value="info"/> + <appender-ref ref="FileAppndr1"/> + </category> + <category name="xa.b.c.d"> + <priority value="info"/> + <appender-ref ref="A2"/> + </category> + <category name="xa.b"> + <priority value="warn"/> + <appender-ref ref="A2"/> + </category> + + <root> + <priority value="warn"/> + <appender-ref ref="FileAppndr1"/> + </root> + + +</log4j:configuration> + +EOL + + +$ENV{rootthreshold} = 'debug'; +$ENV{A1} = 'A1'; +$ENV{A2} = 'A2'; +$ENV{testbfr} = 'Log::Log4perl::Appender::TestBuffer'; +$ENV{simplelayout} = 'Log::Log4perl::Layout::SimpleLayout'; +$ENV{appthreshold} = 'Threshold'; +$ENV{appthreshlevel} = 'error'; +$ENV{convpatt} = 'ConversionPattern'; +$ENV{thepatt} = '%d %4r [%t] %-5p %c %t - %m%n'; +$ENV{pfile} = 'File'; +$ENV{pfileval} = 't/tmp/DOMtest'; +$ENV{abcd} = 'a.b.c.d'; +$ENV{abcd_add} = 'false'; +$ENV{abcd_level} = 'warn'; +$ENV{a1_appenderref} = 'A1'; + +my $varsubsdata = Log::Log4perl::Config::config_read(\$xmlconfig); + +ok(Compare($varsubsdata, $xmldata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($varsubsdata),"\n"; + print STDERR "================\n"; + print STDERR "expected: ", Data::Dump::dump($xmldata),"\n"; + } + }; + +#<param name="Threshold" value="error"/> +$xmlconfig = <<EOL; +<?xml version="1.0" encoding="utf-8"?> +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/" threshold="debug" oneMessagePerAppender="true"> +<appender name="AppGeneralScreen" class="Log::Log4perl::Appender::Screen"> +<layout class="Log::Log4perl::Layout::SimpleLayout"/> +</appender> +<root> +<priority value="WARN" /> +<appender-ref ref="AppGeneralScreen" /> +</root> +</log4perl:configuration> +EOL + +Log::Log4perl::init( \$xmlconfig ); +my $logger = Log::Log4perl->get_logger(); + +$logger->info("Info"); +$logger->debug("Debug"); diff --git a/t/039XML-DOM2.t b/t/039XML-DOM2.t new file mode 100644 index 0000000..29386ec --- /dev/null +++ b/t/039XML-DOM2.t @@ -0,0 +1,358 @@ + +our $table_name = "log4perltest$$"; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl; +use strict; + +our $no_XMLDOM; + +BEGIN { + my $dvrq = $Log::Log4perl::DOM_VERSION_REQUIRED; + eval { + require XML::DOM; + my $dver = XML::DOM->VERSION($dvrq); + require XML::Parser; + my $pver = XML::Parser->VERSION; + if ($pver >= 2.32 && $dver <= 1.42){ + print STDERR "Your version of XML::DOM ($dver) is incompatible with your version of XML::Parser ($pver). You should upgrade your XML::DOM to 1.43 or greater.\n"; + die 'skip tests'; + } + }; + if ($@) { + plan skip_all => "only with XML::DOM > $dvrq"; + }else{ + plan tests => 4; + } +} + +if ($no_XMLDOM){ + ok(1); + exit(0); +} + + +my $xmlconfig = <<EOL; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/" + threshold="debug" oneMessagePerAppender="true"> + +<log4perl:appender name="jabbender" class="Log::Dispatch::Jabber"> + <param-nested name="login"> + <param name="hostname" value="a.jabber.server"/> + <param name="password" value="12345"/> + <param name="port" value="5222"/> + <param name="resource" value="logger"/> + <param name="username" value="bobjones"/> + </param-nested> + <param name="to" value="bob\@a.jabber.server"/> + <param-text name="to">mary\@another.jabber.server</param-text> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + +</log4perl:appender> +<log4perl:appender name="DBAppndr2" class="Log::Log4perl::Appender::DBI"> + <param name="warp_message" value="0"/> + <param name="datasource" value="DBI:CSV:f_dir=t/tmp"/> + <param name="bufferSize" value="2"/> + <param name="password" value="sub { \$ENV{PWD} }"/> + <param name="username" value="bobjones"/> + + <param-text name="sql">insert into $table_name (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) values (?,?,?,?,?,?,?,?)</param-text> + <param-nested name="params"> + <param name="1" value="%p"/> + <param name="3" value="%5.5l"/> + <param name="5" value="%c"/> + <param name="6" value="%C"/> + </param-nested> + + <layout class="Log::Log4perl::Layout::NoopLayout"/> + +</log4perl:appender> +<category name="animal.dog"> + <priority value="info"/> + <appender-ref ref="jabbender"/> +</category> + +<PatternLayout> + <cspec name="G"><![CDATA[sub { return "UID \$< GID \$("; }]]></cspec> +</PatternLayout> + + +</log4perl:configuration> +EOL + + +my $xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +my $propsconfig = <<EOL; + +log4j.category.animal.dog = INFO, jabbender +log4j.threshold = DEBUG + +log4j.oneMessagePerAppender=1 + +log4j.PatternLayout.cspec.G=sub { return "UID \$< GID \$("; } + +log4j.appender.jabbender = Log::Dispatch::Jabber +log4j.appender.jabbender.layout = Log::Log4perl::Layout::SimpleLayout +log4j.appender.jabbender.login.hostname = a.jabber.server +log4j.appender.jabbender.login.port = 5222 +log4j.appender.jabbender.login.username = bobjones +log4j.appender.jabbender.login.password = 12345 +log4j.appender.jabbender.login.resource = logger +log4j.appender.jabbender.to = bob\@a.jabber.server +log4j.appender.jabbender.to = mary\@another.jabber.server + +log4j.appender.DBAppndr2 = Log::Log4perl::Appender::DBI +log4j.appender.DBAppndr2.username = bobjones +log4j.appender.DBAppndr2.datasource = DBI:CSV:f_dir=t/tmp +log4j.appender.DBAppndr2.password = sub { \$ENV{PWD} } +log4j.appender.DBAppndr2.sql = insert into $table_name (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) values (?,?,?,?,?,?,?,?) +log4j.appender.DBAppndr2.params.1 = %p +log4j.appender.DBAppndr2.params.3 = %5.5l +log4j.appender.DBAppndr2.params.5 = %c +log4j.appender.DBAppndr2.params.6 = %C + +log4j.appender.DBAppndr2.bufferSize=2 +log4j.appender.DBAppndr2.warp_message=0 + +#noop layout to pass it through +log4j.appender.DBAppndr2.layout = Log::Log4perl::Layout::NoopLayout + + +EOL + + + +my $propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +#brute force testing here, not very granular, but it is thorough + +eval {require Data::Dump}; +my $dump_available; +if (! $@) { + $dump_available = 1; +} + + +require 't/compare.pl'; + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + +# ------------------------------------------------ +#ok, let's get more hairy, make-believe + +$xmlconfig = <<'EOL'; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/"> + +<log4perl:appender name="A1" class="Log::Dispatch::Jabber"> + <param-nested name="A"> + <param-text name="1">fffff</param-text> + <param name="list" value="11111"/> + <param name="list" value="22222"/> + <param-nested name="subnest"> + <param-text name="a">hhhhh</param-text> + <param name="list" value="aaaaa"/> + <param name="list" value="bbbbb"/> + </param-nested> + </param-nested> + <param-text name="to">mary@another.jabber.server</param-text> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> +</log4perl:appender> + +</log4perl:configuration> + +EOL + +$propsconfig = <<'EOL'; + +log4j.appender.A1= Log::Dispatch::Jabber +log4j.appender.A1.A.1=fffff +log4j.appender.A1.A.list=11111 +log4j.appender.A1.A.list=22222 +log4j.appender.A1.A.subnest.a=hhhhh +log4j.appender.A1.A.subnest.list=aaaaa +log4j.appender.A1.A.subnest.list=bbbbb +log4j.appender.A1.to=mary@another.jabber.server +log4j.appender.A1.layout=Log::Log4perl::Layout::SimpleLayout +EOL + +$xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); +$propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + +# ------------------------------------------------ +#now testing things like cspecs, code refs + +$xmlconfig = <<'EOL'; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/"> + + + +<log4perl:appender name="appndr1" class="Log::Log4perl::Appender::TestBuffer"> + <log4perl:layout class="org.apache.log4j.PatternLayout"> + <param name="ConversionPattern" value = "%K xx %G %U"/> + <cspec name="K"> + sub { return sprintf "%1x", $$} + </cspec> + <cspec name="G"> + sub {return 'thisistheGcspec'} + </cspec> + </log4perl:layout> +</log4perl:appender> + +<category name="plant"> + <priority value="debug"/> + <appender-ref ref="appndr1"/> +</category> + +<PatternLayout> + <cspec name="U"><![CDATA[ + sub { return "UID $< GID $("; } + ]]></cspec> +</PatternLayout> + + + +</log4perl:configuration> + + +EOL + + +$propsconfig = <<'EOL'; +log4j.category.plant = DEBUG, appndr1 + +log4j.PatternLayout.cspec.U = \ + sub { \ + return "UID $< GID $("; \ + } \ + +log4j.appender.appndr1 = Log::Log4perl::Appender::TestBuffer +log4j.appender.appndr1.layout = org.apache.log4j.PatternLayout +log4j.appender.appndr1.layout.ConversionPattern = %K xx %G %U + +log4j.appender.appndr1.layout.cspec.K = sub { return sprintf "%1x", $$} + +log4j.appender.appndr1.layout.cspec.G = sub {return 'thisistheGcspec'} +EOL + +$xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); +$propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + + +#now we test variable substitution +#brute force again +my $varsubstconfig = <<'EOL'; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/" + threshold="debug" oneMessagePerAppender="${onemsgperappnder}"> + +<log4perl:appender name="jabbender" class="${jabberclass}"> + <param-nested name="${paramnestedname}"> + <param name="${hostname}" value="${hostnameval}"/> + <param name="${password}" value="${passwordval}"/> + <param name="port" value="5222"/> + <param name="resource" value="logger"/> + <param name="username" value="bobjones"/> + </param-nested> + <param name="to" value="bob@a.jabber.server"/> + <param-text name="to">${topcdata}</param-text> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + +</log4perl:appender> +<log4perl:appender name="DBAppndr2" class="Log::Log4perl::Appender::DBI"> + <param name="warp_message" value="0"/> + <param name="datasource" value="DBI:CSV:f_dir=t/tmp"/> + <param name="bufferSize" value="2"/> + <param name="password" value="sub { $ENV{PWD} }"/> + <param name="username" value="bobjones"/> + + <param-text name="sql">insert into ${tablename} (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) values (?,?,?,?,?,?,?,?)</param-text> + <param-nested name="params"> + <param name="1" value="%p"/> + <param name="3" value="%5.5l"/> + <param name="5" value="%c"/> + <param name="6" value="%C"/> + </param-nested> + + <layout class="Log::Log4perl::Layout::NoopLayout"/> + +</log4perl:appender> +<category name="animal.dog"> + <priority value="info"/> + <appender-ref ref="jabbender"/> +</category> + +<PatternLayout> + <cspec name="${cspecname}"><![CDATA[sub { ${perlcode} }]]></cspec> +</PatternLayout> + + +</log4perl:configuration> +EOL + +$ENV{onemsgperappnder} = 'true'; +$ENV{jabberclass} = 'Log::Dispatch::Jabber'; +$ENV{paramnestedname} = 'login'; +$ENV{hostname} = 'hostname'; +$ENV{hostnameval} = 'a.jabber.server'; +$ENV{password} = 'password'; +$ENV{passwordval} = '12345'; +$ENV{topcdata} = 'mary@another.jabber.server'; +$ENV{tablename} = $table_name; +$ENV{cspecname} = 'G'; +$ENV{perlcode} = 'return "UID $< GID $(";'; + +my $varsubstdata = Log::Log4perl::Config::config_read(\$varsubstconfig); + + + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + diff --git a/t/040Filter.t b/t/040Filter.t new file mode 100644 index 0000000..a4a0cb8 --- /dev/null +++ b/t/040Filter.t @@ -0,0 +1,516 @@ +########################################### +# Test Suite for Log::Log4perl::Filter +# Mike Schilli, 2003 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More tests => 36; + +use Log::Log4perl; + +############################################# +# Use a pattern-matching subroutine as filter +############################################# + +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger.Some = INFO, A1 + log4perl.filter.MyFilter = sub { /let this through/ } + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = MyFilter + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +my $logger = Log::Log4perl->get_logger("Some.Where"); + + # Let this through +$logger->info("Here's the info, let this through!"); + + # Suppress this +$logger->info("Here's the info, suppress this!"); + +like($buffer->buffer(), qr(let this through), "pattern-match let through"); +unlike($buffer->buffer(), qr(suppress), "pattern-match block"); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# Block in filter based on message level +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger.Some = INFO, A1 + log4perl.filter.MyFilter = sub { \ + my %p = @_; \ + ($p{log4p_level} eq "WARN") ? 1 : 0; \ + } + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = MyFilter + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Suppress this +$logger->info("This doesn't make it"); + + # Let this through +$logger->warn("This passes the hurdle"); + + +like($buffer->buffer(), qr(passes the hurdle), "level-match let through"); +unlike($buffer->buffer(), qr(make it), "level-match block"); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# Filter combination with Filter::Boolean +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + + log4perl.filter.Match1 = sub { /let this through/ } + log4perl.filter.Match2 = sub { /and that, too/ } + log4perl.filter.Match3 = Log::Log4perl::Filter::StringMatch + log4perl.filter.Match3.StringToMatch = suppress + log4perl.filter.Match3.AcceptOnMatch = true + + log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean + log4perl.filter.MyBoolean.logic = !Match3 && (Match1 || Match2) + + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = MyBoolean + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "Boolean 1"); +$buffer->buffer(""); + + # Block +$logger->info("suppress, let this through"); +is($buffer->buffer(), "", "Boolean 2"); +$buffer->buffer(""); + + # Let through +$logger->info("and that, too"); +like($buffer->buffer(), qr(and that, too), "Boolean 3"); +$buffer->buffer(""); + + # Block +$logger->info("and that, too suppress"); +is($buffer->buffer(), "", "Boolean 4"); +$buffer->buffer(""); + + # Block +$logger->info("let this through - and that, too - suppress"); +is($buffer->buffer(), "", "Boolean 5"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# LevelMatchFilter +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::LevelMatch + log4perl.filter.Match1.LevelToMatch = INFO + log4perl.filter.Match1.AcceptOnMatch = true + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "Matched Level"); +$buffer->buffer(""); + + # Block +$logger->warn("suppress, let this through"); +is($buffer->buffer(), "", "Non-Matched Level 1"); +$buffer->buffer(""); + + # Block +$logger->debug("and that, too"); +is($buffer->buffer(), "", "Non-Matched Level 2"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# LevelMatchFilter - negative +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::LevelMatch + log4perl.filter.Match1.LevelToMatch = INFO + log4perl.filter.Match1.AcceptOnMatch = false + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Block +$logger->info("let this through"); +is($buffer->buffer(), "", "Non-Matched Level 1 - negative"); +$buffer->buffer(""); + + # Pass +$logger->warn("suppress, let this through"); +like($buffer->buffer(), qr(let this through), "Matched Level - negative"); +$buffer->buffer(""); + + # Pass +$logger->fatal("and that, too"); +like($buffer->buffer(), qr(and that, too), "Matched Level - negative"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# MDCFilter +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::MDC + log4perl.filter.Match1.KeyToMatch = foo + log4perl.filter.Match1.RegexToMatch = ^bar$ + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +Log::Log4perl::MDC->put(foo => 'bar'); +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "MDC - passed"); +$buffer->buffer(""); +Log::Log4perl::MDC->remove; + + # Block +$logger->info("block this"); +is($buffer->buffer(), "", "MDC - blocked"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# StringMatchFilter +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::StringMatch + log4perl.filter.Match1.StringToMatch = block this + log4perl.filter.Match1.AcceptOnMatch = false + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "StringMatch - passed"); +$buffer->buffer(""); + + # Block +$logger->info("block this"); +is($buffer->buffer(), "", "StringMatch - blocked"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# StringMatchFilter - negative +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::StringMatch + log4perl.filter.Match1.StringToMatch = let this through + log4perl.filter.Match1.AcceptOnMatch = true + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "StringMatch - passed"); +$buffer->buffer(""); + + # Block +$logger->info("block this"); +is($buffer->buffer(), "", "StringMatch - blocked"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# Non-existing filter class +############################################# +eval { + Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::GobbleDeGook + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT +}; + +like($@, qr/Log::Log4perl::Filter::GobbleDeGook/, "Unknown Filter"); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# Syntax error in subroutine +############################################# +eval { + Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = sub { */+- }; + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT +}; + +like($@, qr/Can't evaluate/, "Detect flawed filter subroutine"); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# LevelRangeFilter +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = DEBUG, A1 + log4perl.filter.Range1 = Log::Log4perl::Filter::LevelRange + log4perl.filter.Range1.LevelMin = INFO + log4perl.filter.Range1.LevelMax = WARN + log4perl.filter.Range1.AcceptOnMatch = true + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Range1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Block +$logger->debug("blah"); +is($buffer->buffer(), "", "Outside Range"); +$buffer->buffer(""); + + # Let through +$logger->info("let this through"); +like($buffer->buffer(), qr(let this through), "Matched Range"); +$buffer->buffer(""); + + # Let through +$logger->warn("let this through"); +like($buffer->buffer(), qr(let this through), "Matched Range"); +$buffer->buffer(""); + + # Block +$logger->error("blah"); +is($buffer->buffer(), "", "Outside Range"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# LevelRangeFilter - negative +############################################# +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = DEBUG, A1 + log4perl.filter.Range1 = Log::Log4perl::Filter::LevelRange + log4perl.filter.Range1.LevelMin = INFO + log4perl.filter.Range1.LevelMax = WARN + log4perl.filter.Range1.AcceptOnMatch = false + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Range1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Let through +$logger->debug("debug msg"); +like($buffer->buffer(), qr(debug msg), "Outside Range - negative"); +$buffer->buffer(""); + + # Block +$logger->info("block this"); +is($buffer->buffer(), "", "Matched Range - negative"); +$buffer->buffer(""); + + # Block +$logger->warn("block this"); +is($buffer->buffer(), "", "Matched Range - negative"); +$buffer->buffer(""); + + # Let through +$logger->error("error msg"); +like($buffer->buffer(), qr(error msg), "Outside Range - negative"); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +eval { + Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = INFO, A1 + log4perl.filter.Match1 = Log::Log4perl::Filter::LevelMatch + log4perl.filter.Match1.LevelToWomper = INFO + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.Filter = Match1 + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT +}; + +like $@, qr/Unknown parameter: LevelToWomper/, "Unknown parameter check"; + +############################################# +# AND-Shortcut with boolean filters +############################################# +my $counter = 0; +no warnings qw( redefine ); +my $old_level_match_ok = *{ Log::Log4perl::Filter::LevelMatch::ok }; +*{ Log::Log4perl::Filter::LevelMatch::ok } = sub { + $counter++; 0 }; + +Log::Log4perl->init(\ <<'EOT'); +log4perl.category.Some.Where = DEBUG, A1 + +log4perl.filter.Debug = Log::Log4perl::Filter::LevelMatch +log4perl.filter.Debug.LevelToMatch = DEBUG +log4perl.filter.Debug.AcceptOnMatch = true + +log4perl.filter.Info = Log::Log4perl::Filter::LevelMatch +log4perl.filter.Info.LevelToMatch = INFO +log4perl.filter.Info.AcceptOnMatch = true + +log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean +log4perl.filter.MyBoolean.logic = Debug && Info + +log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.A1.Filter = MyBoolean +log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Block it +$logger->debug("some message"); +is($buffer->buffer(), "", "all blocked"); +is( $counter, 1, "shortcut ok" ); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +############################################# +# OR-Shortcut with boolean filters +############################################# +$counter = 0; +*{ Log::Log4perl::Filter::LevelMatch::ok } = sub { + $counter++; 1 }; + +Log::Log4perl->init(\ <<'EOT'); +log4perl.category.Some.Where = DEBUG, A1 + +log4perl.filter.Debug = Log::Log4perl::Filter::LevelMatch +log4perl.filter.Debug.LevelToMatch = DEBUG +log4perl.filter.Debug.AcceptOnMatch = true + +log4perl.filter.Info = Log::Log4perl::Filter::LevelMatch +log4perl.filter.Info.LevelToMatch = INFO +log4perl.filter.Info.AcceptOnMatch = true + +log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean +log4perl.filter.MyBoolean.logic = Debug || Info + +log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.A1.Filter = MyBoolean +log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + + # Define a logger +$logger = Log::Log4perl->get_logger("Some.Where"); + + # Block it +$logger->debug("some message"); +like($buffer->buffer(), qr/some message/, "all blocked"); +is( $counter, 1, "shortcut ok" ); +$buffer->buffer(""); + +Log::Log4perl->reset(); +$buffer->reset(); + +*{ Log::Log4perl::Filter::LevelMatch::ok } = $old_level_match_ok; diff --git a/t/041SafeEval.t b/t/041SafeEval.t new file mode 100644 index 0000000..41dc313 --- /dev/null +++ b/t/041SafeEval.t @@ -0,0 +1,191 @@ +######################################################################## +# Test Suite for Log::Log4perl::Config (Safe compartment functionality) +# James FitzGibbon, 2003 (james.fitzgibbon@target.com) +# Mike Schilli, 2003 (log4perl@perlmeister.com) +######################################################################## + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test; +BEGIN { plan tests => 23 }; + +use Log::Log4perl; + +ok(1); # If we made it this far, we're ok. + +my $example_log = "example" . (stat($0))[9] . ".log"; +unlink($example_log); + +Log::Log4perl::Config->vars_shared_with_safe_compartment( + main => [ '$0' ], +); + +# test that unrestricted code works properly +Log::Log4perl::Config::allow_code(1); +my $config = <<'END'; + log4perl.logger = INFO, Main + log4perl.appender.Main = Log::Log4perl::Appender::File + log4perl.appender.Main.filename = sub { "example" . (stat($0))[9] . ".log" } + log4perl.appender.Main.layout = Log::Log4perl::Layout::SimpleLayout +END +eval { Log::Log4perl->init( \$config ) }; +my $failed = $@ ? 1 : 0; +ok($failed, 0, 'config file with code initializes successfully'); + +# test that disallowing code works properly +Log::Log4perl::Config->allow_code(0); +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 1, 'config file with code fails if ALLOW_CODE_IN_CONFIG_FILE is false'); + +# test that providing an explicit mask causes illegal code to fail +Log::Log4perl::Config->allow_code(1); +Log::Log4perl::Config->allowed_code_ops(':default'); +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 1, 'config file with code fails if ALLOW_CODE_IN_CONFIG_FILE is true and an explicit mask is set'); + +# test that providing an restrictive convenience mask causes illegal code to fail +Log::Log4perl::Config::allow_code('restrictive'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 1, 'config file with code fails if ALLOW_CODE_IN_CONFIG_FILE is true and a restrictive convenience mask is set'); + +# test that providing an restrictive convenience mask causes illegal code to fail +Log::Log4perl::Config->allow_code('safe'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 0, 'config file with code succeeds if ALLOW_CODE_IN_CONFIG_FILE is true and a safe convenience mask is set'); + +################################################## +# Test allowed_code_ops_convenience_map accessors +################################################### + +# get entire map as hashref +my $map = Log::Log4perl::Config->allowed_code_ops_convenience_map(); +ok(ref $map, 'HASH', 'entire map is returned as a hashref'); +my $numkeys = keys %{ $map }; + +# get entire map as hash +my %map = Log::Log4perl::Config->allowed_code_ops_convenience_map(); +ok(keys %map, $numkeys, 'entire map returned as hash has same number of keys as hashref'); + +# replace entire map +Log::Log4perl::Config->allowed_code_ops_convenience_map( {} ); +ok(keys %{ Log::Log4perl::Config->allowed_code_ops_convenience_map() }, 0, + 'can replace entire map with an empty one'); +Log::Log4perl::Config->allowed_code_ops_convenience_map( \%map ); +ok(keys %{ Log::Log4perl::Config->allowed_code_ops_convenience_map() }, $numkeys, + 'can replace entire map with an populated one'); + +# Add a new name/mask to the map +Log::Log4perl::Config->allowed_code_ops_convenience_map( foo => [ ':default' ] ); +ok( keys %{ Log::Log4perl::Config->allowed_code_ops_convenience_map() }, + $numkeys + 1, 'can add a new name/mask to the map'); + +# get the mask we just added back +my $mask = Log::Log4perl::Config->allowed_code_ops_convenience_map( 'foo' ); +ok( $mask->[0], ':default', 'can retrieve a single mask'); + +################################################### +# Test vars_shared_with_safe_compartment accessors +################################################### + +# get entire varlist as hashref +$map = Log::Log4perl::Config->vars_shared_with_safe_compartment(); +ok(ref $map, 'HASH', 'entire map is returned as a hashref'); +$numkeys = keys %{ $map }; + +# get entire map as hash +%map = Log::Log4perl::Config->vars_shared_with_safe_compartment(); +ok(keys %map, $numkeys, 'entire map returned as hash has same number of keys as hashref'); + +# replace entire map +Log::Log4perl::Config->vars_shared_with_safe_compartment( {} ); +ok(keys %{ Log::Log4perl::Config->vars_shared_with_safe_compartment() }, 0, + 'can replace entire map with an empty one'); +Log::Log4perl::Config->vars_shared_with_safe_compartment( \%map ); +ok(keys %{ Log::Log4perl::Config->vars_shared_with_safe_compartment() }, $numkeys, + 'can replace entire map with an populated one'); + +# Add a new name/mask to the map +$Foo::foo = 1; +@Foo::bar = ( 1, 2, 3 ); +push @Foo::bar, $Foo::foo; # Some nonsense to avoid 'used only once' warning +Log::Log4perl::Config->vars_shared_with_safe_compartment( Foo => [ '$foo', '@bar' ] ); +ok( keys %{ Log::Log4perl::Config->vars_shared_with_safe_compartment() }, + $numkeys + 1, 'can add a new name/mask to the map'); + +# get the varlist we just added back +my $varlist = Log::Log4perl::Config->vars_shared_with_safe_compartment( 'Foo' ); +ok( $varlist->[0], '$foo', 'can retrieve a single varlist'); +ok( $varlist->[1], '@bar', 'can retrieve a single varlist'); + + +############################################ +# Now the some tests with restricted cspecs +############################################ + +# Global cspec with illegal code +$config = <<'END'; + log4perl.logger = INFO, Main + #'U' a global user-defined cspec + log4j.PatternLayout.cspec.U = sub { unlink 'quackquack'; } + log4perl.appender.Main = Log::Log4perl::Appender::Screen + log4perl.appender.Main.layout = Log::Log4perl::Layout::SimpleLayout +END +Log::Log4perl::Config::allow_code('restrictive'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 1, + 'global cspec with harmful code rejected on restrictive setting'); + +# Global cspec with legal code +$config = <<'END'; + log4perl.logger = INFO, Main + #'U' a global user-defined cspec + log4j.PatternLayout.cspec.U = sub { 1; } + log4perl.appender.Main = Log::Log4perl::Appender::Screen + log4perl.appender.Main.layout = Log::Log4perl::Layout::SimpleLayout +END +Log::Log4perl::Config->allow_code('restrictive'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 0, 'global cspec with legal code allowed on restrictive setting'); + +# Local cspec with illegal code +$config = <<'END'; + log4perl.logger = INFO, Main + log4perl.appender.Main = Log::Log4perl::Appender::Screen + log4perl.appender.Main.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Main.layout.cspec.K = sub { symlink("a", "b"); } +END +Log::Log4perl::Config::allow_code('restrictive'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 1, 'local cspec with harmful code rejected on restrictive setting'); + +# Global cspec with legal code +$config = <<'END'; + log4perl.logger = INFO, Main + log4perl.appender.Main = Log::Log4perl::Appender::Screen + log4perl.appender.Main.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Main.layout.cspec.K = sub { return sprintf "%1x", $$} +END +Log::Log4perl::Config::allow_code('restrictive'); +undef @Log::Log4perl::ALLOWED_CODE_OPS_IN_CONFIG_FILE; +eval { Log::Log4perl->init( \$config ) }; +$failed = $@ ? 1 : 0; +ok($failed, 0, 'local cspec with legal code allowed on restrictive setting'); + +unlink($example_log); diff --git a/t/042SyncApp.t b/t/042SyncApp.t new file mode 100644 index 0000000..18eb416 --- /dev/null +++ b/t/042SyncApp.t @@ -0,0 +1,339 @@ +#!/usr/bin/perl +########################################################################## +# Synchronizing appender output with Log::Log4perl::Appender::Synchronized. +# This test uses fork and a semaphore to get two appenders to get into +# each other/s way. +# Mike Schilli, 2003 (m@perlmeister.com) +########################################################################## + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +use Log::Log4perl qw(:easy); +Log::Log4perl->easy_init($DEBUG); +use constant INTERNAL_DEBUG => 0; + +our $INTERNAL_DEBUG = 0; + +$| = 1; + +BEGIN { + if(exists $ENV{"L4P_ALL_TESTS"}) { + plan tests => 5; + } else { + plan skip_all => "- only with L4P_ALL_TESTS"; + } +} + +use Log::Log4perl::Util::Semaphore; +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Appender::Synchronized; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +my $logfile = "$EG_DIR/fork.log"; + +our $lock; +our $locker; +our $locker_key = "abc"; + +unlink $logfile; + +#goto SECOND; + +#print "tie\n"; +$locker = Log::Log4perl::Util::Semaphore->new( + key => $locker_key, +); + +print $locker->status_as_string, "\n" if INTERNAL_DEBUG; + +my $conf = qq( +log4perl.category.Bar.Twix = WARN, Syncer + +log4perl.appender.Logfile = Log::Log4perl::Appender::TestFileCreeper +log4perl.appender.Logfile.autoflush = 1 +log4perl.appender.Logfile.filename = $logfile +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.Logfile.layout.ConversionPattern = %F{1}%L> %m%n + +log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized +log4perl.appender.Syncer.appender = Logfile +log4perl.appender.Syncer.key = blah +); + +$locker->semlock(); + +Log::Log4perl::init(\$conf); + +my $pid = fork(); + +die "fork failed" unless defined $pid; + +my $logger = get_logger("Bar::Twix"); +if($pid) { + #parent + $locker->semlock(); + #print "Waiting for child\n"; + for(1..10) { + #print "Parent: Writing\n"; + $logger->error("X" x 4097); + } +} else { + #child + $locker->semunlock(); + for(1..10) { + #print "Child: Writing\n"; + $logger->error("Y" x 4097); + } + exit 0; +} + + # Wait for child to finish +print "Waiting for pid $pid\n" if $INTERNAL_DEBUG; +waitpid($pid, 0); +print "Done waiting for pid $pid\n" if $INTERNAL_DEBUG; + +my $clashes_found = 0; + +open FILE, "<$logfile" or die "Cannot open $logfile"; +while(<FILE>) { + if(/XY/ || /YX/) { + $clashes_found = 1; + last; + } +} +close FILE; + +unlink $logfile; +#print $logfile, "\n"; +#exit 0; + +ok(! $clashes_found, "Checking for clashes in logfile"); + +################################################################### +# Test the Socket appender +################################################################### + +use IO::Socket::INET; + +SECOND: + +unlink $logfile; + +#print "tie\n"; +$locker = Log::Log4perl::Util::Semaphore->new( + key => $locker_key, +); + +$conf = q{ + log4perl.category = WARN, Socket + log4perl.appender.Socket = Log::Log4perl::Appender::Socket + log4perl.appender.Socket.PeerAddr = localhost + log4perl.appender.Socket.PeerPort = 12345 + log4perl.appender.Socket.layout = SimpleLayout +}; + +print "1 Semunlock\n" if $INTERNAL_DEBUG; +print $locker->status_as_string, "\n" if INTERNAL_DEBUG; +$locker->semunlock(); +print "1 Done semunlock\n" if $INTERNAL_DEBUG; + +print "2 Semlock\n" if $INTERNAL_DEBUG; +print $locker->status_as_string, "\n" if INTERNAL_DEBUG; +$locker->semlock(); +print "2 Done semlock\n" if $INTERNAL_DEBUG; + +#print "forking\n"; +$pid = fork(); + +die "fork failed" unless defined $pid; + +if($pid) { + #parent + #print "Waiting for child\n"; + print "Before semlock\n" if $INTERNAL_DEBUG; + $locker->semlock(); + print "Done semlock\n" if $INTERNAL_DEBUG; + + { + my $client = IO::Socket::INET->new( PeerAddr => 'localhost', + PeerPort => 12345, + ); + + #print "Checking connection\n"; + + if(defined $client) { + #print "Client defined, sending test\n"; + eval { $client->send("test\n") }; + if($@) { + #print "Send failed ($!), retrying ...\n"; + sleep(1); + redo; + } + } else { + #print "Server not responding yet ($!) ... retrying\n"; + sleep(1); + redo; + } + $client->close(); + } + + Log::Log4perl::init(\$conf); + $logger = get_logger("Bar::Twix"); + #print "Sending message\n"; + $logger->error("Greetings from the client"); +} else { + #child + + #print STDERR "child starting\n"; + my $sock = IO::Socket::INET->new( + Listen => 5, + LocalAddr => 'localhost', + LocalPort => 12345, + ReuseAddr => 1, + Proto => 'tcp'); + + die "Cannot start server: $!" unless defined $sock; + # Ready to receive + #print "Server started\n"; + print "Before semunlock\n" if $INTERNAL_DEBUG; + $locker->semunlock(); + print "After semunlock\n" if $INTERNAL_DEBUG; + + my $nof_messages = 2; + + open FILE, ">$logfile" or die "Cannot open $logfile"; + while(my $client = $sock->accept()) { + #print "Client connected\n"; + while(<$client>) { + print FILE "$_\n"; + last; + } + last unless --$nof_messages; + } + + close FILE; + exit 0; +} + + # Wait for child to finish +print "Waiting for pid $pid\n" if $INTERNAL_DEBUG; +waitpid($pid, 0); +print "Done waiting for pid $pid\n" if $INTERNAL_DEBUG; + +open FILE, "<$logfile" or die "Cannot open $logfile"; +my $data = join '', <FILE>; +close FILE; + +unlink $logfile; + +like($data, qr/Greetings/, "Check logfile of Socket appender"); + +################################################################### +# Test the "silent_recover" options of the Socket appender +################################################################### + +use IO::Socket::INET; + +our $TMP_FILE = "warnings.txt"; +END { unlink $TMP_FILE if defined $TMP_FILE; } + +# Capture STDERR to a temporary file and a filehandle to read from it +open STDERR, ">$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; +sub readwarn { return scalar <IN>; } + +$conf = q{ + log4perl.category = WARN, Socket + log4perl.appender.Socket = Log::Log4perl::Appender::Socket + log4perl.appender.Socket.PeerAddr = localhost + log4perl.appender.Socket.PeerPort = 12345 + log4perl.appender.Socket.layout = SimpleLayout + log4perl.appender.Socket.silent_recovery = 1 +}; + + # issues a warning +Log::Log4perl->init(\$conf); + +like(readwarn(), qr/Connection refused/, + "Check if warning occurs on dead socket"); + +$logger = get_logger("foobar"); + + # silently ignored +$logger->warn("message lost"); + +$locker->semunlock(); +$locker->semlock(); + + # Now start a server +$pid = fork(); + +if($pid) { + #parent + + # wait for child + #print "Waiting for server to start\n"; + $locker->semlock(); + + # Send another message (should be sent) + #print "Sending message\n"; + $logger->warn("message sent"); +} else { + #child + + # Start a server + my $sock = IO::Socket::INET->new( + Listen => 5, + LocalAddr => 'localhost', + LocalPort => 12345, + ReuseAddr => 1, + Proto => 'tcp'); + + die "Cannot start server: $!" unless defined $sock; + # Ready to receive + #print "Server started\n"; + $locker->semunlock(); + + my $nof_messages = 1; + + open FILE, ">$logfile" or die "Cannot open $logfile"; + while(my $client = $sock->accept()) { + #print "Client connected\n"; + while(<$client>) { + #print "Got message: $_\n"; + print FILE "$_\n"; + last; + } + last unless --$nof_messages; + } + + close FILE; + exit 0; +} + + # Wait for child to finish +print "Waiting for pid $pid\n" if $INTERNAL_DEBUG; +waitpid($pid, 0); +print "Done waiting for pid $pid\n" if $INTERNAL_DEBUG; + +open FILE, "<$logfile" or die "Cannot open $logfile"; +$data = join '', <FILE>; +close FILE; + +#print "data=$data\n"; + +unlink $logfile; + +unlike($data, qr/message lost/, "Check logfile for lost message"); +like($data, qr/message sent/, "Check logfile for sent message"); diff --git a/t/043VarSubst.t b/t/043VarSubst.t new file mode 100755 index 0000000..90c5da4 --- /dev/null +++ b/t/043VarSubst.t @@ -0,0 +1,141 @@ +#!/usr/bin/perl +########################################################################## +# Check basic variable substitution. +# Mike Schilli, 2003 (m@perlmeister.com) +########################################################################## + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +BEGIN { plan tests => 8 } +use Log::Log4perl qw(get_logger); + +######################################################## +# Wrong variable name +######################################################## +my $conf = q( +screen = Log::Log4perl::Appender::Screen +log4perl.category = WARN, ScreenApp +log4perl.appender.ScreenApp = ${screen1} +log4perl.appender.ScreenApp.layout = \ + Log::Log4perl::Layout::PatternLayout +log4perl.appender.ScreenApp.layout.ConversionPattern = %d %F{1} %L> %m %n +); + +eval { Log::Log4perl::init(\$conf) }; + +like($@, qr/Undefined Variable 'screen1'/); + +######################################################## +# Replacing appender class name +######################################################## +$conf = q( +screen = Log::Log4perl::Appender::TestBuffer +log4perl.category = WARN, BufferApp +log4perl.appender.BufferApp = ${screen} +log4perl.appender.BufferApp.layout = \ + Log::Log4perl::Layout::PatternLayout +log4perl.appender.BufferApp.layout.ConversionPattern = %d %F{1} %L> %m %n +); + +Log::Log4perl::init(\$conf); +my $logger = get_logger(""); +$logger->error("foobar"); +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("BufferApp"); +like($buffer->buffer, qr/foobar/); + +######################################################## +# Replacing appender class name +######################################################## +$conf = q( + layout_class = Log::Log4perl::Layout::PatternLayout + layout_pattern = %d %F{1} %L> %m %n + + log4perl.category.Bar.Twix = WARN, Logfile, Screen + + log4perl.appender.Logfile = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = ${layout_class} + log4perl.appender.Logfile.layout.ConversionPattern = ${layout_pattern} + + log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Screen.layout = ${layout_class} + log4perl.appender.Screen.layout.ConversionPattern = ${layout_pattern} +); + +Log::Log4perl::init(\$conf); +$logger = get_logger("Bar::Twix"); +$logger->error("foobar"); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Logfile"); +like($buffer->buffer, qr/foobar/); +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Screen"); +like($buffer->buffer, qr/foobar/); + +######################################################## +# Multi-Line variable +######################################################## +$conf = q( + layout_class = \ +Log::Log4perl::\ +Layout::PatternLayout + layout_pattern = %d %F{1} \ +%L> \ +%m \ +%n + log4perl.category.Bar.Twix = WARN, Logfile, Screen + + log4perl.appender.Logfile = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = ${layout_class} + log4perl.appender.Logfile.layout.ConversionPattern = ${layout_pattern} + + log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Screen.layout = ${layout_class} + log4perl.appender.Screen.layout.ConversionPattern = ${layout_pattern} +); + +Log::Log4perl::init(\$conf); +$logger = get_logger("Bar::Twix"); +$logger->error("foobar"); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Logfile"); +like($buffer->buffer, qr/foobar/); +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Screen"); +like($buffer->buffer, qr/foobar/); + +######################################################## +# Environment variable substitution +######################################################## +$ENV{layout_class} = "Log::Log4perl::Layout::PatternLayout"; +$ENV{layout_pattern} = "%d %F{1} %L> %m %n"; + +$conf = q( + log4perl.category.Bar.Twix = WARN, Logfile, Screen + + log4perl.appender.Logfile = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Logfile.filename = test.log + log4perl.appender.Logfile.layout = ${layout_class} + log4perl.appender.Logfile.layout.ConversionPattern = ${layout_pattern} + + log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Screen.layout = ${layout_class} + log4perl.appender.Screen.layout.ConversionPattern = ${layout_pattern} +); + +Log::Log4perl::init(\$conf); +$logger = get_logger("Bar::Twix"); +$logger->error("foobar"); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Logfile"); +like($buffer->buffer, qr/foobar/); +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Screen"); +like($buffer->buffer, qr/foobar/); diff --git a/t/044XML-Filter.t b/t/044XML-Filter.t new file mode 100644 index 0000000..05a6afd --- /dev/null +++ b/t/044XML-Filter.t @@ -0,0 +1,256 @@ +#adding filters to XML-DOM configs --kg + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl; +use strict; +use Data::Dumper; +use File::Spec; + +our $no_XMLDOM; + +BEGIN { + my $dvrq = $Log::Log4perl::DOM_VERSION_REQUIRED; + + eval { + require XML::DOM; + XML::DOM->VERSION($dvrq); + my $dver = XML::DOM->VERSION($dvrq); + require XML::Parser; + my $pver = XML::Parser->VERSION; + if ($pver >= 2.32 && $dver <= 1.42){ + print STDERR "Your version of XML::DOM ($dver) is incompatible with your version of XML::Parser ($pver). You should upgrade your XML::DOM to 1.43 or greater.\n"; + die 'skip tests'; + } + + }; + if ($@) { + plan skip_all => "only with XML::DOM > $dvrq"; + }else{ + plan tests => 3; + } +} + +if ($no_XMLDOM){ + ok(1); + exit(0); +} + + +#brute force testing here, not very granular, but it is thorough + +eval {require Data::Dump}; +my $dump_available; +if (! $@) { + $dump_available = 1; +} +require File::Spec->catfile('t','compare.pl'); + +# ***************************************************** +# first, test a very basic filter setup +# ***************************************************** + +my $xmlconfig = <<EOL; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4j:configuration SYSTEM "log4j.dtd"> + +<log4j:configuration xmlns:log4j="http://jakarta.apache.org/log4j/"> + + <appender name="A1" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <filter class="Log::Log4perl::Filter::Boolean"> + <param name="logic" value="!Match3 && (Match1 || Match2)"/> + </filter> + </appender> + + <root> + <priority value="info"/> + <appender-ref ref="A1"/> + </root> + +</log4j:configuration> + +EOL + + +#Log::Log4perl::init(\$config); + +my $xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +my $propsconfig = <<EOL; +log4perl.category = INFO, A1 + +log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.A1.Filter = Log::Log4perl::Filter::Boolean +log4perl.appender.A1.Filter.logic = !Match3 && (Match1 || Match2) +log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout + + +EOL + + + +my $propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n"; + print STDERR "================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + +# ***************************************************** +# second, log4perl's boolean filters +# ***************************************************** + +$xmlconfig = <<EOL; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/"> + + + <appender name="A1" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <filter class="Log::Log4perl::Filter::Boolean"> + <param name="logic" value="!Match3 && (Match1 || Match2)"/> + </filter> + </appender> + + <log4perl:filter name="Match1" value="sub { /let this through/ }" /> + + <log4perl:filter name="Match2">sub { /and that, too/ }</log4perl:filter> + + <log4perl:filter name="Match3" class="Log::Log4perl::Filter::StringMatch"> + <param name="StringToMatch" value="suppress"/> + <param name="AcceptOnMatch" value="true"/> + </log4perl:filter> + + <log4perl:filter name="MyBoolean" class="Log::Log4perl::Filter::Boolean"> + <param name="logic" value="!Match3 && (Match1 || Match2)"/> + </log4perl:filter> + + + <root> + <priority value="info"/> + <appender-ref ref="A1"/> + </root> + +</log4perl:configuration> +EOL + + +#Log::Log4perl::init(\$config); + +$xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +$propsconfig = <<EOL; +log4perl.category = INFO, A1 + +log4perl.filter.Match1 = sub { /let this through/ } +log4perl.filter.Match2 = sub { /and that, too/ } +log4perl.filter.Match3 = Log::Log4perl::Filter::StringMatch +log4perl.filter.Match3.StringToMatch = suppress +log4perl.filter.Match3.AcceptOnMatch = true + +log4perl.filter.MyBoolean = Log::Log4perl::Filter::Boolean +log4perl.filter.MyBoolean.logic = !Match3 && (Match1 || Match2) + +log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.A1.Filter = Log::Log4perl::Filter::Boolean +log4perl.appender.A1.Filter.logic = !Match3 && (Match1 || Match2) +log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout + + +EOL + + + +$propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +#brute force testing here, not very granular, but it is thorough + + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n"; + print STDERR "================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + + + +# ***************************************************** +# third, level range filter, just for something different +# ***************************************************** + + +$xmlconfig = <<EOL; +<?xml version="1.0" encoding="UTF-8"?> +<!DOCTYPE log4perl:configuration SYSTEM "log4perl.dtd"> + +<log4perl:configuration xmlns:log4perl="http://log4perl.sourceforge.net/"> + + <log4perl:appender name="A1" class="Log::Log4perl::Appender::TestBuffer"> + <layout class="Log::Log4perl::Layout::SimpleLayout"/> + <filter-ref id="Range1"/> + </log4perl:appender> + + <log4perl:filter name="Range1" class="Log::Log4perl::Filter::LevelRange"> + <param name="LevelMin" value="info"/> + <param name="LevelMax" value="warn"/> + <param name="AcceptOnMatch" value="true"/> + </log4perl:filter> + + <root> + <priority value="debug"/> + <appender-ref ref="A1"/> + </root> +</log4perl:configuration> +EOL + + +#Log::Log4perl::init(\$config); + +$xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +$propsconfig = <<EOL; +log4perl.category = DEBUG, A1 +log4perl.filter.Range1 = Log::Log4perl::Filter::LevelRange +log4perl.filter.Range1.LevelMin = INFO +log4perl.filter.Range1.LevelMax = WARN +log4perl.filter.Range1.AcceptOnMatch = true +log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.A1.Filter = Range1 +log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout + + +EOL + +$propsdata = Log::Log4perl::Config::config_read(\$propsconfig); + +#brute force testing here, not very granular, but it is thorough + +ok(Compare($xmldata, $propsdata)) || + do { + if ($dump_available) { + print STDERR "got: ",Data::Dump::dump($xmldata),"\n"; + print STDERR "================\n"; + print STDERR "expected: ", Data::Dump::dump($propsdata),"\n"; + } + }; + + + diff --git a/t/045Composite.t b/t/045Composite.t new file mode 100644 index 0000000..adcc06a --- /dev/null +++ b/t/045Composite.t @@ -0,0 +1,372 @@ +########################################### +# Test Suite for Composite Appenders +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +BEGIN { + eval { + require Storable; + }; + if ($@) { + plan skip_all => "only with Storable"; # Limit.pm needs it and + # early Perl versions dont + # have it. + }else{ + plan tests => 20; + } +} + +use Log::Log4perl qw(get_logger :levels); +use Log::Log4perl::Level; +use Log::Log4perl::Appender::TestBuffer; + +ok(1); # If we made it this far, we/re ok. + +################################################## +# Limit Appender +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +my $conf = qq( + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 +); + +Log::Log4perl->init(\$conf); + +my $logger = get_logger(""); +$logger->warn("This message will be sent immediately"); +$logger->warn("This message will be delayed by one hour."); + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +like($buffer->buffer(), qr/immediately/); +unlike($buffer->buffer(), qr/delayed/); + + # Now flush the limiter and check again. The delayed message should now + # be there. +my $limit = Log::Log4perl->appenders()->{Limiter}; +$limit->flush(); + +like($buffer->buffer(), qr/immediately/); +like($buffer->buffer(), qr/delayed/); + +$buffer->reset(); + # Nothing to flush +$limit->flush(); +is($buffer->buffer(), ""); + +################################################## +# Flush method +################################################## +$conf .= <<EOT; + log4perl.appender.Limiter.appender_method_on_flush = clear +EOT +Log::Log4perl->init(\$conf); +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +$logger = get_logger(""); +$logger->warn("This message will be queued but discarded on flush."); +$limit = Log::Log4perl->appenders()->{Limiter}; +$limit->flush(); + +is($buffer->buffer(), ""); + +################################################## +# Limit Appender with max_until_discard +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = qq( + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 + log4perl.appender.Limiter.max_until_discarded = 1 +); + +Log::Log4perl->init(\$conf); + +$logger = get_logger(""); +$logger->warn("This message will be sent immediately"); +for(1..10) { + $logger->warn("This message will be discarded"); +} + + # Artificially flush the limit appender +$limit = Log::Log4perl->appenders()->{Limiter}; +$limit->flush(); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +like($buffer->buffer(), qr/immediately/); +unlike($buffer->buffer(), qr/discarded/); + +################################################## +# Limit Appender with max_until_discard +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = qq( + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 + log4perl.appender.Limiter.max_until_discarded = 1 +); + +Log::Log4perl->init(\$conf); + +$logger = get_logger(""); +$logger->warn("This message will be sent immediately"); +for(1..10) { + $logger->warn("This message will be discarded"); +} + + # Artificially flush the limit appender +$limit = Log::Log4perl->appenders()->{Limiter}; +$limit->flush(); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +like($buffer->buffer(), qr/immediately/); +unlike($buffer->buffer(), qr/discarded/); + +################################################## +# Limit Appender with max_until_flushed +################################################## +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = qq( + log4perl.category = WARN, Limiter + + # Email appender + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 + log4perl.appender.Limiter.max_until_flushed = 2 +); + +Log::Log4perl->init(\$conf); + +$logger = get_logger(""); +$logger->warn("This message will be sent immediately"); +$logger->warn("This message won't show right away"); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +like($buffer->buffer(), qr/immediately/); +unlike($buffer->buffer(), qr/right away/); + +$logger->warn("This message will show right away"); +like($buffer->buffer(), qr/right away/); + + +################################# +#demonstrating bug in Limiter.pm regarding $_ +# Reset appender population +Log::Log4perl::Appender::TestBuffer->reset(); + +{package My::Test::Appender; +our @ISA = ('Log::Log4perl::Appender::TestBuffer'); +sub new { + my $self = shift; + $_ = ''; #aye, there's the rub! + $self->SUPER::new; +} +} + +$conf = qq( + log4perl.category = WARN, Limiter + + log4perl.appender.Buffer = My::Test::Appender + log4perl.appender.Buffer.layout = SimpleLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d %m %n + + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 +); + +Log::Log4perl->init(\$conf); +ok(1); + +### API initialization +# +Log::Log4perl->reset(); +my $bufApp = Log::Log4perl::Appender->new( + 'Log::Log4perl::Appender::TestBuffer', + name => 'MyBuffer', + ); +$bufApp->layout( + Log::Log4perl::Layout::PatternLayout::Multiline->new( + '%m%n') + ); +# Make the appender known to the system (without assigning it to +# any logger +Log::Log4perl->add_appender( $bufApp ); + +my $limitApp = Log::Log4perl::Appender->new( + 'Log::Log4perl::Appender::Limit', + name => 'MyLimit', + appender => 'MyBuffer', + key => 'nem', + ); +$limitApp->post_init(); +$limitApp->composite(1); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("MyBuffer"); +get_logger("")->add_appender($limitApp); +get_logger("")->level($DEBUG); +get_logger("wonk")->debug("waah!"); +is($buffer->buffer(), "waah!\n", "composite api init"); + +### Wrong %M with caching appender +# +Log::Log4perl->reset(); +Log::Log4perl::Appender::TestBuffer->reset(); + +$conf = qq( + log4perl.category = WARN, Limiter + + # TestBuffer appender + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern=%d cat=%c meth=%M %m %n + + # Limiting appender, using the email appender above + log4perl.appender.Limiter = Log::Log4perl::Appender::Limit + log4perl.appender.Limiter.appender = Buffer + log4perl.appender.Limiter.block_period = 3600 + log4perl.appender.Limiter.max_until_flushed = 2 +); + +Log::Log4perl->init(\$conf); + +$logger = get_logger(); + +$logger->warn("Sent from main"); + +package Willy::Wonka; +sub func { + use Log::Log4perl qw(get_logger); + my $logger = get_logger(); + $logger->warn("Sent from func"); +} +package main; + +Willy::Wonka::func(); +$logger->warn("Sent from main"); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +like($buffer->buffer(), + qr/cat=main meth=main::.*cat=Willy.Wonka meth=Willy::Wonka::func/s, + "%M/%c with composite appender"); + +### Different caller stacks with normal vs. composite appenders +Log::Log4perl->reset(); + +$conf = qq( + log4perl.category = WARN, Buffer1, Composite + + # 1st TestBuffer appender + log4perl.appender.Buffer1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer1.layout = PatternLayout + log4perl.appender.Buffer1.layout.ConversionPattern=meth=%M %m %n + + # 2nd TestBuffer appender + log4perl.appender.Buffer2 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer2.layout = PatternLayout + log4perl.appender.Buffer2.layout.ConversionPattern=meth=%M %m %n + + # Composite Appender + log4perl.appender.Composite = Log::Log4perl::Appender::Buffer + log4perl.appender.Composite.appender = Buffer2 + log4perl.appender.Composite.trigger = sub { 1 } +); + +Log::Log4perl->init(\$conf); + +my $buffer1 = Log::Log4perl::Appender::TestBuffer->by_name("Buffer1"); +my $buffer2 = Log::Log4perl::Appender::TestBuffer->by_name("Buffer2"); + +$logger = get_logger(); + +$logger->warn("Sent from main"); + +Willy::Wonka::func(); + +like $buffer1->buffer(), + qr/meth=main:: Sent from main.*meth=Willy::Wonka::func Sent from func/s, + "caller stack from direct appender"; +like $buffer2->buffer(), + qr/meth=main:: Sent from main.*meth=Willy::Wonka::func Sent from func/s, + "caller stack from composite appender"; + +# [RT 72056] Appender Threshold blocks composite appender + +$conf = qq( + log4perl.category = DEBUG, Composite + + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = PatternLayout + log4perl.appender.Buffer.Threshold=INFO + log4perl.appender.Buffer.layout.ConversionPattern=%M %m %n + + # Composite Appender + log4perl.appender.Composite = Log::Log4perl::Appender::Buffer + log4perl.appender.Composite.appender = Buffer + log4perl.appender.Composite.trigger = sub { 0 } + +); + +Log::Log4perl->init(\$conf); + +$buffer = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); +$logger = get_logger(); +$logger->debug("this will be blocked by the appender threshold"); + +my $composite = Log::Log4perl->appender_by_name("Composite"); +$composite->flush(); + +is $buffer->buffer(), "", + "appender threshold blocks message in composite appender"; diff --git a/t/046RRDs.t b/t/046RRDs.t new file mode 100644 index 0000000..d1b35d4 --- /dev/null +++ b/t/046RRDs.t @@ -0,0 +1,60 @@ +########################################### +# Test Suite for RRDs appenders +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +use Log::Log4perl qw(get_logger); + +my $DB = "myrrddb.dat"; + +BEGIN { eval 'require RRDs'; + if($@) { + plan skip_all => "(RRDs not installed)"; + exit 0; + } else { + plan tests => 1; + } + }; +END { unlink $DB }; + +use RRDs; + +RRDs::create( + $DB, "--step=1", + "DS:myvalue:GAUGE:2:U:U", + "RRA:MAX:0.5:1:120"); + +Log::Log4perl->init(\qq{ + log4perl.category = INFO, RRDapp + log4perl.appender.RRDapp = Log::Log4perl::Appender::RRDs + log4perl.appender.RRDapp.dbname = $DB + log4perl.appender.RRDapp.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.RRDapp.layout.ConversionPattern = N:%m +}); + +my $logger = get_logger(); + +for(10, 15, 20) { + $logger->info($_); + sleep 1; +} + +my ($start,$step,$names,$data) = + RRDs::fetch($DB, "MAX", + "--start" => time() - 20); +$data = join ' - ', map { "@$_" } grep { defined $_->[0] } @$data; +#print $data; + +like($data, qr/\d\d/); diff --git a/t/048lwp.t b/t/048lwp.t new file mode 100644 index 0000000..5749ff5 --- /dev/null +++ b/t/048lwp.t @@ -0,0 +1,98 @@ +########################################### +# Test Suite for LWP debugging with Log4perl +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +BEGIN { + eval { + require LWP::UserAgent; + die "Skip tests" if $LWP::UserAgent::VERSION < 2.0; + die "Skip tests" if $LWP::UserAgent::VERSION >= 5.822; + }; + + if($@) { + plan skip_all => "Only with 2.0 < LWP::UserAgent < 5.822 "; + } else { + plan tests => 3; + } +} + +use Log::Log4perl qw(:easy); +use Log::Log4perl::Util; + +Log::Log4perl->easy_init( + { level => $DEBUG, + category => "LWP::UserAgent", + file => 'lwpout.txt' + }); + +Log::Log4perl->infiltrate_lwp(); + +my $ua = LWP::UserAgent->new(); + +my $tmpfile = Log::Log4perl::Util::tmpfile_name(); +END { unlink $tmpfile }; +$ua->get("file:$tmpfile"); + +open LOG, "<lwpout.txt" or die "Cannot open lwpout.txt"; +my $data = join('', <LOG>); +close LOG; + +like($data, qr#\QGET file:$tmpfile\E#); + +END { unlink "lwpout.txt" } + +#################################### +# Check different category +#################################### +Log::Log4perl->reset(); +Log::Log4perl->easy_init( + { level => $DEBUG, + category => "LWP::SchmoozeAgent", + file => '>lwpout.txt' + }); + +Log::Log4perl->infiltrate_lwp(); + +$ua = LWP::UserAgent->new(); +$ua->get("file:$tmpfile"); + +open LOG, "<lwpout.txt" or die "Cannot open lwpout.txt"; +$data = join('', <LOG>); +close LOG; + +is($data, ''); + +#################################### +# Check layout +#################################### +Log::Log4perl->reset(); +Log::Log4perl->easy_init( + { level => $DEBUG, + category => "LWP::UserAgent", + file => '>lwpout.txt', + layout => '%F-%L: %m%n', + }); + +Log::Log4perl->infiltrate_lwp(); + +$ua = LWP::UserAgent->new(); +$ua->get("file:$tmpfile"); + +open LOG, "<lwpout.txt" or die "Cannot open lwpout.txt"; +$data = join('', <LOG>); +close LOG; + +like($data, qr#LWP/UserAgent.pm-\d+#); diff --git a/t/049Unhide.t b/t/049Unhide.t new file mode 100644 index 0000000..2d64281 --- /dev/null +++ b/t/049Unhide.t @@ -0,0 +1,50 @@ +########################################### +# Test Suite for ':resurrect' tag +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +use Log::Log4perl::Appender::TestBuffer; + +BEGIN { + eval { + require Filter::Util::Call; + }; + + if($@) { + plan skip_all => "Filter::Util::Call not available"; + } else { + plan tests => 1; + } +} + +use Log::Log4perl qw(:easy :resurrect); + +Log::Log4perl->easy_init($DEBUG); + +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl->init(\ <<EOT); + log4perl.rootLogger=DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout=org.apache.log4j.PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%m %n +EOT + + # All of these should be activated +###l4p DEBUG "first"; + ###l4p DEBUG "second"; +DEBUG "third"; + +is(Log::Log4perl::Appender::TestBuffer->by_name("A1")->buffer(), + "first \nsecond \nthird \n", "Hidden statements via ###l4p"); diff --git a/t/050Buffer.t b/t/050Buffer.t new file mode 100644 index 0000000..c4ecd13 --- /dev/null +++ b/t/050Buffer.t @@ -0,0 +1,76 @@ +########################################### +# Test Suite for 'Buffer' appender +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More tests => 6; +use Log::Log4perl::Appender::TestBuffer; + +use Log::Log4perl qw(:easy); + +my $conf = q( +log4perl.category = DEBUG, Buffer +log4perl.category.triggertest = DEBUG, Buffer2 + + # Regular Screen Appender +log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Screen.layout = PatternLayout +log4perl.appender.Screen.layout.ConversionPattern = %d %p %c %m %n + + # Buffering appender, using the appender above as outlet +log4perl.appender.Buffer = Log::Log4perl::Appender::Buffer +log4perl.appender.Buffer.appender = Screen +log4perl.appender.Buffer.trigger_level = ERROR + + # Second Screen Appender +log4perl.appender.Screen2 = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Screen2.layout = PatternLayout +log4perl.appender.Screen2.layout.ConversionPattern = %d %p %c %m %n + + # Buffering appender, with a subroutine reference as a trigger +log4perl.appender.Buffer2 = Log::Log4perl::Appender::Buffer +log4perl.appender.Buffer2.appender = Screen2 +log4perl.appender.Buffer2.trigger = sub { \ + my($self, $params) = @_; \ + return Log::Log4perl::Level::to_priority($params->{log4p_level}) >= \ + Log::Log4perl::Level::to_priority('ERROR') } + +); + +Log::Log4perl->init(\$conf); + +my $buf = Log::Log4perl::Appender::TestBuffer->by_name("Screen"); + +DEBUG("This message gets buffered."); +is($buf->buffer(), "", "Buffering DEBUG"); + +INFO("This message gets buffered also."); +is($buf->buffer(), "", "Buffering INFO"); + +ERROR("This message triggers a buffer flush."); +like($buf->buffer(), qr/DEBUG.*?INFO.*?ERROR/s, "Flushing ERROR"); + + +# testing trigger sub + +my $buf2 = Log::Log4perl::Appender::TestBuffer->by_name("Screen2"); + +my $logger = Log::Log4perl->get_logger('triggertest'); +$logger->debug("This message gets buffered."); +is($buf2->buffer(), "", "Buffering DEBUG"); + +$logger->info("This message gets buffered also."); +is($buf2->buffer(), "", "Buffering INFO"); + +$logger->error("This message triggers a buffer flush."); +like($buf2->buffer(), qr/DEBUG.*?INFO.*?ERROR/s, "Flushing ERROR"); diff --git a/t/051Extra.t b/t/051Extra.t new file mode 100644 index 0000000..010f70b --- /dev/null +++ b/t/051Extra.t @@ -0,0 +1,113 @@ +########################################### +# Test Suite for :no_extra_logdie_message +# Mike Schilli, 2005 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Log::Log4perl qw(:easy :no_extra_logdie_message); +use Test::More; + +BEGIN { + if ($] < 5.008) { + plan skip_all => "Only with perl >= 5.008"; + } else { + plan tests => 11; + } +} + +END { + unlink "t/tmp/easy"; + rmdir "t/tmp"; +} + +mkdir "t/tmp" unless -d "t/tmp"; + +use Log::Log4perl::Appender::TestBuffer; + +is($Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR, 0, "internal variable set"); + +my $conf = qq( +log4perl.category = DEBUG, Screen + + # Regular Screen Appender +log4perl.appender.Screen = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Screen.layout = PatternLayout +log4perl.appender.Screen.layout.ConversionPattern = %d %p %c %m %n +); + +Log::Log4perl->init(\$conf); + +######################################################################### +# Capture STDERR to a temporary file and a filehandle to read from it + +my $TMP_FILE = File::Spec->catfile(qw(t tmp easy)); +$TMP_FILE = "tmp/easy" if ! -d "t"; + +open STDERR, ">$TMP_FILE"; +select STDERR; $| = 1; #needed on win32 +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; binmode IN, ":utf8"; +sub readstderr { return join("", <IN>); } + +END { unlink $TMP_FILE; + close IN; + } +######################################################################### + +my $buf = Log::Log4perl::Appender::TestBuffer->by_name("Screen"); + +$buf->buffer(""); +my $line_ref = __LINE__ + 1; +LOGCARP("logcarp"); + +like(readstderr(), qr/logcarp at /, "Output to stderr"); +SKIP: { use Carp; + skip "Detected buggy Carp.pm (upgrade to perl-5.8.*)", 3 unless + defined $Carp::VERSION; + like($buf->buffer(), qr/logcarp.*$line_ref/, "Appender output intact"); + $buf->buffer(""); + $line_ref = __LINE__ + 1; + LOGCARP("logcarp"); + like(readstderr(), qr/logcarp at /, "Output to stderr"); + like($buf->buffer(), qr/logcarp.*$line_ref/, "Appender output intact"); +} + +$line_ref += 6; +$buf->clear; +LOGWARN("Doesn't call 'exit'"); +is(readstderr(), "", "No output to stderr"); +like($buf->buffer(), qr/Doesn't call 'exit'/, "Appender output intact"); +######################################################################### +# Turn default behaviour back on +######################################################################### +$Log::Log4perl::LOGDIE_MESSAGE_ON_STDERR ^= 1; +$buf->buffer(""); + +package Foo; +use Log::Log4perl qw(:easy); +sub foo { + LOGCARP("logcarp"); +} +package main; + +Foo::foo(); + +$line_ref += 17; +like(readstderr(), qr/logcarp.*$line_ref/, "Output to stderr"); +like($buf->buffer(), qr/logcarp.*$line_ref/, "Appender output intact"); + +$buf->buffer(""); +eval { + LOGDIE("logdie"); +}; +$line_ref += 8; +like($@, qr/logdie.*$line_ref/, "Output to stderr"); +like($buf->buffer(), qr/logdie/, "Appender output intact"); diff --git a/t/052Utf8.t b/t/052Utf8.t new file mode 100644 index 0000000..ea40d39 --- /dev/null +++ b/t/052Utf8.t @@ -0,0 +1,130 @@ +########################################### +# Test Suite for utf8 output +# Mike Schilli, 2004 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use strict; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +use Test::More; +use Log::Log4perl qw(:easy); + +BEGIN { + if($] < 5.008) { + plan skip_all => "utf-8 tests with perl >= 5.8 only"; + } else { + plan tests => 6; + } +} + +my $WORK_DIR = "tmp"; +if(-d "t") { + $WORK_DIR = File::Spec->catfile(qw(t tmp)); +} +unless (-e "$WORK_DIR"){ + mkdir("$WORK_DIR", 0755) || die "can't create $WORK_DIR ($!)"; +} + +my $TMP_FILE = File::Spec->catfile(qw(t tmp utf8.out)); +$TMP_FILE = "tmp/utf8.out" if ! -d "t"; + +END { + unlink $TMP_FILE; + rmdir $WORK_DIR; + } + +########### +# utf8 file appender +########### +my $conf = <<EOT; + log4perl.logger = DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::File + log4perl.appender.A1.filename=$TMP_FILE + log4perl.appender.A1.mode=write + log4perl.appender.A1.utf8=1 + log4perl.appender.A1.layout=PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%d-%c %m%n +EOT +Log::Log4perl->init(\$conf); +DEBUG "quack \x{A4}"; +open FILE, "<:utf8", $TMP_FILE or die "Cannot open $TMP_FILE"; +my $data = join '', <FILE>; +close FILE; +like($data, qr/\x{A4}/, "conf: utf8-1"); + +########### +# binmode +########### +$conf = <<EOT; + log4perl.logger = DEBUG, A1 + log4perl.appender.A1=Log::Log4perl::Appender::File + log4perl.appender.A1.filename=$TMP_FILE + log4perl.appender.A1.mode=write + log4perl.appender.A1.binmode=:utf8 + log4perl.appender.A1.layout=PatternLayout + log4perl.appender.A1.layout.ConversionPattern=%d-%c %m%n +EOT +Log::Log4perl->init(\$conf); +DEBUG "quack \x{A5}"; +open FILE, "<:utf8", $TMP_FILE or die "Cannot open $TMP_FILE"; +$data = join '', <FILE>; +close FILE; +like($data, qr/\x{A5}/, "binmode: utf8-1"); + +########### +# Easy mode +########### +Log::Log4perl->easy_init({file => ":utf8> $TMP_FILE", + level => $DEBUG}); + +DEBUG "odd character: \x{30B8}"; +open FILE, "<:utf8", $TMP_FILE or die "Cannot open $TMP_FILE"; +$data = join '', <FILE>; +close FILE; +like($data, qr/\x{30B8}/, "easy: utf8-1"); + +########### +# Easy mode with utf8 setting +########### + +open STDERR, ">$TMP_FILE"; +select STDERR; $| = 1; #needed on win32 +select STDOUT; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; binmode IN, ":utf8"; +sub readstderr { return join("", <IN>); } + +END { unlink $TMP_FILE; + close IN; + } + +Log::Log4perl->easy_init({ + level => $DEBUG, + file => "STDERR", + utf8 => 1, +}); + +use utf8; +DEBUG "Über"; +binmode STDOUT, ":utf8"; # for better error messages of the test suite +like(readstderr(), qr/Über/, 'utf8 matches'); + +########### +# utf8 config file +########### +use Log::Log4perl::Config; +Log::Log4perl::Config->utf8(1); +Log::Log4perl->init("$EG_DIR/log4j-utf8.conf"); +DEBUG "blech"; +my $app = Log::Log4perl::Appender::TestBuffer->by_name("Ä1"); +ok defined $app, "app found"; +my $buf = $app->buffer(); +is $buf, "blech\n", "utf8 named appender"; diff --git a/t/053Resurrect.t b/t/053Resurrect.t new file mode 100644 index 0000000..5c21132 --- /dev/null +++ b/t/053Resurrect.t @@ -0,0 +1,38 @@ +########################################### +# Test Suite for Log::Log4perl::Resurrector +# Mike Schilli, 2007 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use strict; +use Test::More; +use Log::Log4perl qw(:easy); + +BEGIN { + my $eg = "eg"; + $eg = "../eg" unless -d $eg; + push @INC, $eg; +}; + +use Log::Log4perl::Resurrector; +use L4pResurrectable; + +plan tests => 1; + +Log::Log4perl->init(\ <<'EOT'); + log4perl.logger = DEBUG, A1 + log4perl.appender.A1 = Log::Log4perl::Appender::TestBuffer + log4perl.appender.A1.layout = Log::Log4perl::Layout::SimpleLayout +EOT + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("A1"); + +L4pResurrectable::foo(); +is($buffer->buffer(), "DEBUG - foo was here\nINFO - bar was here\n", + "resurrected statement"); diff --git a/t/054Subclass.t b/t/054Subclass.t new file mode 100644 index 0000000..0772d99 --- /dev/null +++ b/t/054Subclass.t @@ -0,0 +1,29 @@ +########################################### +# Test Suite for Log::Log4perl::Level +# Mike Schilli, 2008 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +########################################### + # Subclass L4p +package Mylogger; +use strict; +use Log::Log4perl; +our @ISA = qw(Log::Log4perl); + +########################################### +package main; +use strict; + +use Test::More; + +plan tests => 1; + +my $logger = Mylogger->get_logger("Waah"); +is($logger->{category}, "Waah", "subclass category rt #32942"); diff --git a/t/055AppDestroy.t b/t/055AppDestroy.t new file mode 100755 index 0000000..3b73c9e --- /dev/null +++ b/t/055AppDestroy.t @@ -0,0 +1,53 @@ +#!/usr/bin/perl +################################################################### +# Check if a custom appender with a destroy handler gets its +# warning through +################################################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +package SomeAppender; +our @ISA = qw(Log::Log4perl::Appender); +sub new { + bless {}, shift; +} +sub log {} +sub DESTROY { + warn "Horrible Warning!"; +} + +package main; +use warnings; +use strict; +use Test::More; +use Log::Log4perl qw(:easy); + +my $warnings; + +$SIG{__WARN__} = sub { + $warnings .= $_[0]; +}; + +my $conf = q( +log4perl.category = DEBUG, SomeA +log4perl.appender.SomeA = SomeAppender +log4perl.appender.SomeA.layout = Log::Log4perl::Layout::SimpleLayout +); + +Log::Log4perl->init(\$conf); + +plan tests => 1; + +my $logger = get_logger(); +$logger->debug("foo"); + +Log::Log4perl::Logger->cleanup(); + +END { + like $warnings, qr/Horrible Warning!/, "app destruction warning caught"; +} diff --git a/t/056SyncApp2.t b/t/056SyncApp2.t new file mode 100644 index 0000000..6c0841c --- /dev/null +++ b/t/056SyncApp2.t @@ -0,0 +1,88 @@ +#!/usr/bin/perl +########################################################################## +# The test checks Log::Log4perl::Appender::Synchronized for correct semaphore +# destruction when using parameter "destroy". +# Based on: 042SyncApp.t +# Jens Berthold, 2009 (log4perl@jebecs.de) +########################################################################## +use warnings; +use strict; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl qw(:easy); +Log::Log4perl->easy_init($DEBUG); +use constant INTERNAL_DEBUG => 0; + +our $INTERNAL_DEBUG = 0; + +$| = 1; + +BEGIN { + if(exists $ENV{"L4P_ALL_TESTS"}) { + plan tests => 1; + } else { + plan skip_all => "- only with L4P_ALL_TESTS"; + } +} + +use Log::Log4perl::Util::Semaphore; +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Appender::Synchronized; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +my $logfile = "$EG_DIR/fork.log"; + +our $lock; + +unlink $logfile; + +my $conf = qq( +log4perl.category.Bar.Twix = WARN, Syncer + +log4perl.appender.Logfile = Log::Log4perl::Appender::TestFileCreeper +log4perl.appender.Logfile.autoflush = 1 +log4perl.appender.Logfile.filename = $logfile +log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.Logfile.layout.ConversionPattern = %F{1}%L> %m%n + +log4perl.appender.Syncer = Log::Log4perl::Appender::Synchronized +log4perl.appender.Syncer.appender = Logfile +log4perl.appender.Syncer.key = blah +log4perl.appender.Syncer.destroy = 1 +); + +Log::Log4perl::init(\$conf); + +my $pid = fork(); + +die "fork failed" unless defined $pid; + +my $logger = get_logger("Bar::Twix"); +if($pid) { + # parent + # no logging test here: if child erroneously deletes semaphore, + # any log output at this point would crash the test +} else { + # child + exit 0; +} + +# Wait for child to finish +print "Waiting for pid $pid\n" if $INTERNAL_DEBUG; +waitpid($pid, 0); +print "Done waiting for pid $pid\n" if $INTERNAL_DEBUG; +unlink $logfile; + +# Destroying appender (+semaphore) fails if child process already destroyed it +Log::Log4perl->appender_by_name('Syncer')->DESTROY(); +ok(!$@, "Destroying appender"); + diff --git a/t/057MsgChomp.t b/t/057MsgChomp.t new file mode 100755 index 0000000..b3c047b --- /dev/null +++ b/t/057MsgChomp.t @@ -0,0 +1,88 @@ +########################################### +# Test Suite for Log::Log4perl +# Mike Schilli, 2002 (m@perlmeister.com) +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; +BEGIN { plan tests => 4 }; + +use Log::Log4perl qw(:easy); + +######################################################### +# double newline +######################################################### +my $conf = q( + log4perl.category = DEBUG, Buffer + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern = %d %F{1} %L> %m%n +); + +Log::Log4perl->init( \$conf ); +my $buf = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); + +DEBUG "blah\n"; +DEBUG "blah\n"; + +unlike($buf->buffer(), qr/blah\n\n/); + +######################################################### +# turn default %m%n chomping feature off +######################################################### +$conf = q( + log4perl.category = DEBUG, Buffer + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern = %d %F{1} %L> %m%n + log4perl.appender.Buffer.layout.message_chomp_before_newline = 0 +); + +Log::Log4perl->init( \$conf ); +$buf = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); + +DEBUG "blah\n"; +DEBUG "blah\n"; +like($buf->buffer(), qr/blah\n\n/); + +######################################################### +# %m without chomp +######################################################### +$conf = q( + log4perl.category = DEBUG, Buffer + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern = %m foo %n +); + +Log::Log4perl->init( \$conf ); +$buf = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); + +DEBUG "blah\n"; +like($buf->buffer(), qr/blah\n foo/); + +######################################################### +# try %m{chomp} +######################################################### +$conf = q( + log4perl.category = DEBUG, Buffer + log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer + log4perl.appender.Buffer.layout = Log::Log4perl::Layout::PatternLayout + log4perl.appender.Buffer.layout.ConversionPattern = %m{chomp} foo %n +); + +Log::Log4perl->init( \$conf ); +$buf = Log::Log4perl::Appender::TestBuffer->by_name("Buffer"); + +DEBUG "blah\n"; +DEBUG "blah\n"; +like($buf->buffer(), qr/blah foo /); diff --git a/t/058Warnings.t b/t/058Warnings.t new file mode 100644 index 0000000..4dbb464 --- /dev/null +++ b/t/058Warnings.t @@ -0,0 +1,25 @@ + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use Test::More; +use Log::Log4perl qw(:nostrict); + +plan tests => 1; + +my $warnings; + +$SIG{__WARN__} = sub { + $warnings .= $_[0]; +}; + +my $EG_DIR = "eg"; +$EG_DIR = "../eg" unless -d $EG_DIR; + +Log::Log4perl->init( "$EG_DIR/dupe-warning.conf" ); + +is($warnings, undef, "no warnings"); diff --git a/t/059Wrapper.t b/t/059Wrapper.t new file mode 100755 index 0000000..9c34239 --- /dev/null +++ b/t/059Wrapper.t @@ -0,0 +1,94 @@ +#!/usr/local/bin/perl -w + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use strict; +use Log::Log4perl qw(:easy); + +############################################ +# Tests for Log4perl used by a wrapper class +# Mike Schilli, 2009 (m@perlmeister.com) +########################################### +use warnings; +use strict; + +use Test::More; + +BEGIN { plan tests => 12 } + +########################################### +package L4p::RelayWrapper; +########################################### +no strict qw(refs); +sub get_logger; +Log::Log4perl->wrapper_register(__PACKAGE__); + +*get_logger = sub { + + my @args = @_; + + local $Log::Log4perl::caller_depth = + $Log::Log4perl::caller_depth + 1; + + if(defined $args[0] and $args[0] eq __PACKAGE__) { + my $pkg = __PACKAGE__; + $args[0] =~ s/$pkg/Log::Log4perl/g; + } + Log::Log4perl::get_logger( @args ); +}; + +########################################### +package L4p::InheritWrapper; +########################################### +our @ISA = qw(Log::Log4perl); +Log::Log4perl->wrapper_register(__PACKAGE__); + +########################################### +package main; +########################################### + +use Log::Log4perl qw(get_logger); + +my $pkg = "Wobble::Cobble"; +my $pkgcat = "Wobble.Cobble"; + +my $logger; + +$logger = get_logger(); +is $logger->{category}, "main", "imported get_logger()"; + +$logger = get_logger( $pkg ); +is $logger->{category}, $pkgcat, "imported get_logger($pkg)"; + +for my $class (qw(Log::Log4perl + L4p::RelayWrapper + L4p::InheritWrapper)) { + + no strict 'refs'; + + my $func = "$class\::get_logger"; + + if($class !~ /Inherit/) { + # wrap::() + $logger = $func->(); + is $logger->{category}, "main", "$class\::()"; + + $logger = $func->( $pkg ); + is $logger->{category}, $pkgcat, "$class\::($pkg)"; + } + + # wrap->() + $logger = $class->get_logger(); + is $logger->{category}, "main", "$class->()"; + + $logger = $class->get_logger($pkg); + is $logger->{category}, $pkgcat, "$class->($pkg)"; +} + +# use Data::Dumper; +# print Dumper($logger; diff --git a/t/060Initialized.t b/t/060Initialized.t new file mode 100644 index 0000000..5a13e5e --- /dev/null +++ b/t/060Initialized.t @@ -0,0 +1,44 @@ +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More tests => 3; + +use Log::Log4perl; +use Log::Log4perl::Appender::TestBuffer; + +eval { + Log::Log4perl->init('nonexistant_file'); +}; + +ok((not Log::Log4perl->initialized()), 'Failed init doesn\'t flag initialized'); + +Log::Log4perl->reset(); + +eval { + Log::Log4perl->init_once('nonexistant_file'); +}; + +ok((not Log::Log4perl->initialized()), 'Failed init_once doesn\'t flag ' + .'initialized'); + +Log::Log4perl->reset(); + +eval { + Log::Log4perl->init(\ <<EOT); +log4j.rootLogger=DEBUG, A1 +log4j.appender.A1=Log::Log4perl::Appender::TestBuffer +log4j.appender.A1.layout=org.apache.log4j.PatternLayout +log4j.appender.A1.layout.ConversionPattern=%-4r [%t] %-5p %c - %m%n +EOT +}; + +ok(Log::Log4perl->initialized(), 'init flags initialized'); + +1; # End of 060Initialized.t diff --git a/t/061Multiline.t b/t/061Multiline.t new file mode 100644 index 0000000..4d92460 --- /dev/null +++ b/t/061Multiline.t @@ -0,0 +1,35 @@ + +# https://rt.cpan.org/Public/Bug/Display.html?id=60197 + +use Log::Log4perl; +use Log::Log4perl::Appender; +use Log::Log4perl::Appender::File; +use Log::Log4perl::Layout::PatternLayout::Multiline; + +use Test::More tests => 1; + +my $logger = Log::Log4perl->get_logger("blah"); + +my $layout = Log::Log4perl::Layout::PatternLayout::Multiline->new; + +my $logfile = "./file.log"; + +my $appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::File", + name => 'foo', + filename => './file.log', + mode => 'append', + autoflush => 1, + ); + +# Set the appender's layout +$appender->layout($layout); +$logger->add_appender($appender); + +# this message will be split into [], leading to undef being logged, +# which will cause most appenders (e.g. ::File) to warn +$appender->log({ level => 1, message => "\n\n" }, 'foo_category', 'INFO'); + +ok(1, "no warnings should appear here"); + +unlink $logfile; diff --git a/t/062InitHash.t b/t/062InitHash.t new file mode 100644 index 0000000..07996c3 --- /dev/null +++ b/t/062InitHash.t @@ -0,0 +1,27 @@ + +# https://rt.cpan.org/Public/Bug/Display.html?id=68105 + +my $logfile = "test.log"; +END { unlink $logfile; } + +use Log::Log4perl; +use Log::Log4perl::Appender; +use Log::Log4perl::Appender::File; + +use Test::More tests => 1; + +Log::Log4perl->init({ + 'log4perl.rootLogger' => 'ALL, FILE', + 'log4perl.appender.FILE' => + 'Log::Log4perl::Appender::File', + 'log4perl.appender.FILE.filename' => sub { "$logfile" }, + 'log4perl.appender.FILE.layout' => 'SimpleLayout', +}); + +Log::Log4perl->get_logger->debug('yee haw'); + +open FILE, "<$logfile" or die $!; +my $data = join '', <FILE>; +close FILE; + +is( $data, "DEBUG - yee haw\n", "hash-init with subref" ); diff --git a/t/063LoggerRemove.t b/t/063LoggerRemove.t new file mode 100755 index 0000000..508f08a --- /dev/null +++ b/t/063LoggerRemove.t @@ -0,0 +1,56 @@ +# http://stackoverflow.com/questions/5914088 and +# https://github.com/mschilli/log4perl/issues/7 + +use strict; +use Test::More; +use Log::Log4perl::Appender::TestBuffer; + +plan tests => 6; + +use Log::Log4perl qw(get_logger :easy); + +# $Log::Log4perl::CHATTY_DESTROY_METHODS = 1; + +my $conf = q( +log4perl.category.main = WARN, LogBuffer +log4perl.category.Bar.Twix = WARN, LogBuffer +log4perl.appender.LogBuffer = Log::Log4perl::Appender::TestBuffer +log4perl.appender.LogBuffer.layout = \ +Log::Log4perl::Layout::PatternLayout +log4perl.appender.LogBuffer.layout.ConversionPattern = %d %F{1} %L> %m %n +); + +Log::Log4perl::init(\$conf); + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("LogBuffer"); + +my $logger = get_logger("Bar::Twix"); + +ok(exists $Log::Log4perl::Logger::LOGGERS_BY_NAME->{"Bar.Twix"}, + "logger exists"); + +Log::Log4perl->remove_logger( $logger ); +undef $logger; + +ok(!exists $Log::Log4perl::Logger::LOGGERS_BY_NAME->{"Bar.Twix"}, + "logger gone"); + +# now remove a stealth logger +$logger = get_logger("main"); + +ok(exists $Log::Log4perl::Logger::LOGGERS_BY_NAME->{"main"}, + "logger exists"); + +WARN "before"; + +Log::Log4perl->remove_logger( $logger ); +undef $logger; + +ok(!exists $Log::Log4perl::Logger::LOGGERS_BY_NAME->{"main"}, + "logger gone"); + + # this should be a no-op now. +WARN "after"; + +like($buffer->buffer, qr/before/, "log message before logger removal present"); +unlike($buffer->buffer, qr/after/, "log message after logger removal absent"); diff --git a/t/064RealClass.t b/t/064RealClass.t new file mode 100755 index 0000000..8a53782 --- /dev/null +++ b/t/064RealClass.t @@ -0,0 +1,44 @@ +# get_logger($self) in the base class returns a logger for the subclass +# category + +use strict; +use Test::More; +use Log::Log4perl::Appender::TestBuffer; + +plan tests => 1; + +package AppBaseClass; +use Log::Log4perl qw(get_logger :easy); +sub meth { + my( $self ) = @_; + get_logger( ref $self )->warn("in base class"); +} + +package AppSubClass; +our @ISA = qw(AppBaseClass); +use Log::Log4perl qw(get_logger :easy); +sub new { + bless {}, shift; +} + +package main; + +use Log::Log4perl qw(get_logger :easy); + +# $Log::Log4perl::CHATTY_DESTROY_METHODS = 1; + +my $conf = q( +log4perl.category.AppSubClass = WARN, LogBuffer +log4perl.appender.LogBuffer = Log::Log4perl::Appender::TestBuffer +log4perl.appender.LogBuffer.layout = Log::Log4perl::Layout::PatternLayout +log4perl.appender.LogBuffer.layout.ConversionPattern = %m%n +); + +Log::Log4perl::init(\$conf); + +my $buffer = Log::Log4perl::Appender::TestBuffer->by_name("LogBuffer"); + +my $sub = AppSubClass->new(); +$sub->meth(); + +is $buffer->buffer(), "in base class\n", "subclass logger in base class"; diff --git a/t/065Undef.t b/t/065Undef.t new file mode 100644 index 0000000..31447e5 --- /dev/null +++ b/t/065Undef.t @@ -0,0 +1,28 @@ +use strict; + +use File::Temp qw( tempfile ); + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +my($tmpfh, $tempfile) = tempfile( UNLINK => 1 ); + +use Test::More; +BEGIN { plan tests => 1 }; +use Log::Log4perl qw( :easy ); + +Log::Log4perl->easy_init( { level => $DEBUG, file => $tempfile } ); + +my $warnings = ""; + +$SIG{__WARN__} = sub { + $warnings .= $_[0]; +}; + +DEBUG "foo", undef, "bar"; + +like $warnings, qr/Log message argument #2/, "warning for undef element issued"; diff --git a/t/066SQLite.t b/t/066SQLite.t new file mode 100644 index 0000000..1de4f47 --- /dev/null +++ b/t/066SQLite.t @@ -0,0 +1,96 @@ +########################################### +# Test DBI appender with SQLite +########################################### + +our $table_name = "log4perltest$$"; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +BEGIN { + use FindBin qw($Bin); + use lib "$Bin/lib"; + require Log4perlInternalTest; +} + +use Test::More; +use Log::Log4perl; +use warnings; +use strict; + +BEGIN { + my $minversion = \%Log::Log4perl::Internal::Test::MINVERSION; + eval { + require DBI; + die if $DBI::VERSION < $minversion->{ "DBI" }; + + require DBD::SQLite; + }; + if ($@) { + plan skip_all => + "DBI $minversion->{ DBI } " . + "not installed, skipping tests\n"; + }else{ + plan tests => 3; + } +} + +my $testdir = "t/tmp"; +mkdir $testdir; + +my $dbfile = "$testdir/sqlite.dat"; + +END { + unlink $dbfile; + rmdir $testdir; +} + +require DBI; + +unlink $dbfile; +my $dbh = DBI->connect("dbi:SQLite:dbname=$dbfile","",""); + + # https://rt.cpan.org/Public/Bug/Display.html?id=79960 + # undef as NULL +my $stmt = <<EOL; + CREATE TABLE $table_name ( + loglevel char(9) , + message char(128), + mdc char(16) + ) +EOL + +$dbh->do($stmt) || die "do failed on $stmt".$dbh->errstr; + +my $config = <<"EOT"; +log4j.category = WARN, DBAppndr +log4j.appender.DBAppndr = Log::Log4perl::Appender::DBI +log4j.appender.DBAppndr.datasource = dbi:SQLite:dbname=$dbfile +log4j.appender.DBAppndr.sql = \\ + insert into $table_name \\ + (loglevel, mdc, message) \\ + values (?, ?, ?) +log4j.appender.DBAppndr.params.1 = %p +log4j.appender.DBAppndr.params.2 = %X{foo} +#---------------------------- #3 is message + +log4j.appender.DBAppndr.usePreparedStmt=2 +log4j.appender.DBAppndr.warp_message=0 + + #noop layout to pass it through +log4j.appender.DBAppndr.layout = Log::Log4perl::Layout::NoopLayout +EOT + +Log::Log4perl::init(\$config); + +my $logger = Log::Log4perl->get_logger(); +$logger->warn('test message'); + +my $ary_ref = $dbh->selectall_arrayref( "SELECT * from $table_name" ); +is $ary_ref->[0]->[0], "WARN", "level logged in db"; +is $ary_ref->[0]->[1], "test message", "msg logged in db"; +is $ary_ref->[0]->[2], undef, "msg logged in db"; diff --git a/t/067Exception.t b/t/067Exception.t new file mode 100644 index 0000000..fba3235 --- /dev/null +++ b/t/067Exception.t @@ -0,0 +1,25 @@ +use strict; + +use File::Temp qw( tempfile ); +use Log::Log4perl qw( get_logger ); +use Test::More; + +plan tests => 1; + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +eval { + foo(); +}; + +like $@, qr/main::foo/, "stacktrace on internal error"; + +sub foo { + Log::Log4perl::Logger->cleanup(); + my $logger = get_logger(); +} diff --git a/t/068MultilineIndented.t b/t/068MultilineIndented.t new file mode 100644 index 0000000..275ce98 --- /dev/null +++ b/t/068MultilineIndented.t @@ -0,0 +1,81 @@ +my $logfile = "./file.log"; +END { unlink $logfile; } + +use Log::Log4perl; +use Log::Log4perl::Appender; +use Log::Log4perl::Appender::File; +use Log::Log4perl::Layout::PatternLayout; + +use Test::More tests => 1; + +my $logger = Log::Log4perl->get_logger("blah"); + +# 1 19 +# | | +# %d : yyyy/mm/dd hh:mm:ss +my $layout = Log::Log4perl::Layout::PatternLayout->new("%d > %m{indent}%n"); + +my $appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::File", + name => 'foo', + filename => './file.log', + mode => 'append', + autoflush => 1, + ); + +# Set the appender's layout +$appender->layout($layout); +$logger->add_appender($appender); + +my $msg =<<"EOF_MSG"; +This is +a message with +multiple lines +EOF_MSG + +chomp($msg); + +$appender->log({ level => 1, message => $msg }, 'foo_category', 'INFO'); + +# TEST : +# +# Just one test if format of log file is correct. +# Any error of check_log_file_format() is returned as non empty string and +# appended to $test_name to explain what went wrong. +# +my $err_str = check_log_file_format($logfile); +my $test_name = 'log file has multiline intended format' . ($err_str ? " - reason : $err_str" : ""); +ok ( ! $err_str, $test_name ); + +# returns "" on success +# returns non empty error string on failure +sub check_log_file_format { + my $logfile = shift; + + my $err_str = ""; + my $line_count = 1; + open(my $fh, "<", $logfile) || return "could not open log file '$logfile'"; + + for my $line (<$fh>) { + if ($line_count == 1) { + # 1 19 + # | | + # yyyy/mm/dd hh:mm:ss > %m + unless ( $line =~ m!^\d{4}/\d{2}/\d{2} \d{2}:\d{2}:\d{2} > This is\s*$! ) { + $err_str = "first line wrong, should be: yyyy/mm/dd hh::mm::ss This is" ; + last; + } + } + else { + unless ( $line =~ /^ {22}\S/ ) { + $err_str = "format of line $line_count wrong"; + last; + } + } + $line_count++; + } + + close($fh); + + return $err_str; +} diff --git a/t/069MoreMultiline.t b/t/069MoreMultiline.t new file mode 100644 index 0000000..42d05b6 --- /dev/null +++ b/t/069MoreMultiline.t @@ -0,0 +1,54 @@ +use strict; +use warnings; + +my $logfile = "./file.log"; +END { unlink $logfile; } + +use Log::Log4perl; +use Log::Log4perl::Appender; +use Log::Log4perl::Appender::TestBuffer; +use Log::Log4perl::Layout::PatternLayout; + +use Test::More tests => 4; + +my $logger = Log::Log4perl->get_logger("blah"); + +my $appender = Log::Log4perl::Appender->new( + "Log::Log4perl::Appender::TestBuffer", + name => 'testbuffer', +); +$logger->add_appender($appender); + +my $msg = "line1\nline2\nline3\n"; +my $logit = sub { + $appender->log({ level => 1, message => $msg }, 'foo_category', 'INFO'); +}; + +# indent=fix +my $layout = Log::Log4perl::Layout::PatternLayout->new("%m{indent=2}"); +$appender->layout($layout); +$logit->(); +is $appender->buffer(), "line1\n line2\n line3\n ", "indent=2"; +$appender->buffer(""); + +# indent=fix,chomp +$layout = Log::Log4perl::Layout::PatternLayout->new("%m{indent=2,chomp}"); +$appender->layout($layout); +$logit->(); +is $appender->buffer(), "line1\n line2\n line3", "indent=2,chomp"; +$appender->buffer(""); + +# indent=variable +$layout = Log::Log4perl::Layout::PatternLayout->new("123%m{indent}"); +$appender->layout($layout); +$logit->(); +is $appender->buffer(), "123line1\n line2\n line3\n ", "indent"; +$appender->buffer(""); + +# indent=variable,chomp +$layout = Log::Log4perl::Layout::PatternLayout->new("123%m{indent,chomp}"); +$appender->layout($layout); +$logit->(); +#print "[", $appender->buffer(), "]\n"; +is $appender->buffer(), "123line1\n line2\n line3", "indent,chomp"; +$appender->buffer(""); diff --git a/t/070UTCDate.t b/t/070UTCDate.t new file mode 100644 index 0000000..4707299 --- /dev/null +++ b/t/070UTCDate.t @@ -0,0 +1,42 @@ +########################################### +# Tests for Log4perl::DateFormat with gmtime +########################################### + +BEGIN { + if($ENV{INTERNAL_DEBUG}) { + require Log::Log4perl::InternalDebug; + Log::Log4perl::InternalDebug->enable(); + } +} + +use warnings; +use strict; + +use Test::More; + +BEGIN { plan tests => 2 } + +use Log::Log4perl qw(get_logger); +use Log::Log4perl::Appender::TestBuffer; + +sub init_with_utc { + my ($utc) = @_; + my $conf = <<'CONF'; +log4perl.category.Bar.Twix = WARN, Buffer +log4perl.appender.Buffer = Log::Log4perl::Appender::TestBuffer +log4perl.appender.Buffer.layout = \ + Log::Log4perl::Layout::PatternLayout +log4perl.appender.Buffer.layout.ConversionPattern = %d{HH:mm:ss}%n +CONF + if (defined $utc) { + $conf .= "log4perl.utcDateTimes = $utc\n"; + } + + Log::Log4perl::init(\$conf); +} + +init_with_utc(1); +ok $Log::Log4perl::DateFormat::GMTIME, "init_with_utc"; + +init_with_utc(0); +ok ! $Log::Log4perl::DateFormat::GMTIME, "init_with_utc"; diff --git a/t/compare.pl b/t/compare.pl new file mode 100644 index 0000000..6b58317 --- /dev/null +++ b/t/compare.pl @@ -0,0 +1,86 @@ +#Lifted this code from Data::Compare by Fabien Tassin fta@sofaraway.org . +#Using it in the XML tests + +use Carp; + +sub Compare { + croak "Usage: Data::Compare::Compare(x, y)\n" unless $#_ == 1; + my $x = shift; + my $y = shift; + + my $refx = ref $x; + my $refy = ref $y; + + unless ($refx || $refy) { # both are scalars + return $x eq $y if defined $x && defined $y; # both are defined + !(defined $x || defined $y); + } + elsif ($refx ne $refy) { # not the same type + 0; + } + elsif ($x == $y) { # exactly the same reference + 1; + } + elsif ($refx eq 'SCALAR') { + Compare($$x, $$y); + } + elsif ($refx eq 'ARRAY') { + if ($#$x == $#$y) { # same length + my $i = -1; + for (@$x) { + $i++; + return 0 unless Compare($$x[$i], $$y[$i]); + } + 1; + } + else { + 0; + } + } + elsif ($refx eq 'HASH') { + return 0 unless scalar keys %$x == scalar keys %$y; + for (keys %$x) { + next unless defined $$x{$_} || defined $$y{$_}; + return 0 unless defined $$y{$_} && Compare($$x{$_}, $$y{$_}); + } + 1; + } + elsif ($refx eq 'REF') { + 0; + } + elsif ($refx eq 'CODE') { + 1; #changed for log4perl, let's just accept coderefs + } + elsif ($refx eq 'GLOB') { + 0; + } + else { # a package name (object blessed) + my ($type) = "$x" =~ m/^$refx=(\S+)\(/o; + if ($type eq 'HASH') { + my %x = %$x; + my %y = %$y; + Compare(\%x, \%y); + } + elsif ($type eq 'ARRAY') { + my @x = @$x; + my @y = @$y; + Compare(\@x, \@y); + } + elsif ($type eq 'SCALAR') { + my $x = $$x; + my $y = $$y; + Compare($x, $y); + } + elsif ($type eq 'GLOB') { + 0; + } + elsif ($type eq 'CODE') { + 1; #changed for log4perl, let's just accept coderefs + } + else { + croak "Can't handle $type type."; + } + } +} + +1; diff --git a/t/deeper1.expected b/t/deeper1.expected new file mode 100644 index 0000000..e52bce6 --- /dev/null +++ b/t/deeper1.expected @@ -0,0 +1,14 @@ +INFO plant N/A - info message 1 +WARN plant N/A - warning message 1 +FATAL plant N/A - fatal message 1 +DEBUG animal.dog N/A - debugging message 2 +INFO animal.dog N/A - info message 2 +WARN animal.dog N/A - warning message 2 +FATAL animal.dog N/A - fatal message 2 +INFO animal N/A - info message 3 +WARN animal N/A - warning message 3 +FATAL animal N/A - fatal message 3 +DEBUG animal.dog.leg.toenail N/A - debug message +INFO animal N/A - info message +WARN animal.dog.leg.toenail N/A - warning message +FATAL animal N/A - fatal message diff --git a/t/deeper6.expected b/t/deeper6.expected new file mode 100644 index 0000000..07fbf90 --- /dev/null +++ b/t/deeper6.expected @@ -0,0 +1,13 @@ +INFO a - should print for a, a.b, a.b.c +INFO a.b - should print for a, a.b, a.b.c +INFO a.b.c - should print for a, a.b, a.b.c +WARN a - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +WARN a.b - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +WARN a.b.c - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +WARN a.b.c.d - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +WARN a.b.c.d.e - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +FATAL a - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +FATAL a.b - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +FATAL a.b.c - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +FATAL a.b.c.d - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e +FATAL a.b.c.d.e - should print for a, a.b, a.b.c, a.b.c.d, a.b.c.d.e diff --git a/t/deeper7.expected b/t/deeper7.expected new file mode 100644 index 0000000..1234132 --- /dev/null +++ b/t/deeper7.expected @@ -0,0 +1,12 @@ +INFO xa.b.c.d - should print for xa.b.c.d, xa.b.c.d.e +INFO xa.b.c.d.e - should print for xa.b.c.d, xa.b.c.d.e +WARN xa - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +WARN xa.b - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +WARN xa.b.c - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +WARN xa.b.c.d - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +WARN xa.b.c.d.e - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +FATAL xa - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +FATAL xa.b - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +FATAL xa.b.c - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +FATAL xa.b.c.d - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e +FATAL xa.b.c.d.e - should print for xa, xa.b, xa.b.c, xa.b.c.d, xa.b.c.d.e diff --git a/t/lib/Log4perlInternalTest.pm b/t/lib/Log4perlInternalTest.pm new file mode 100755 index 0000000..233cd03 --- /dev/null +++ b/t/lib/Log4perlInternalTest.pm @@ -0,0 +1,62 @@ +package Log::Log4perl::Internal::Test; +use strict; +use warnings; + +# We don't require any of these modules for testing, but if they're +# installed, we require minimal versions. + +our %MINVERSION = qw( + DBI 1.607 + DBD::CSV 0.33 + SQL::Statement 1.20 +); + +1; + +__END__ + +=head1 NAME + +Log::Log4perl::Internal::Test - Internal Test Utilities for Log4perl + +=head1 SYNOPSIS + + use Log::Log4perl::Internal::Test; + +=head1 DESCRIPTION + +Some general-purpose test routines and constants to be used in the Log4perl +test suite. + +=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. + +=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. + diff --git a/t/testdisp.pl b/t/testdisp.pl new file mode 100644 index 0000000..a1911db --- /dev/null +++ b/t/testdisp.pl @@ -0,0 +1,52 @@ +################################################## +# String dispatcher for testing +################################################## + +package Log::Dispatch::String; + +use Log::Dispatch::Output; +use base qw( Log::Dispatch::Output ); +use fields qw( stderr ); + +sub new +{ + my $proto = shift; + my $class = ref $proto || $proto; + my %params = @_; + + my $self = bless {}, $class; + + $self->_basic_init(%params); + $self->{stderr} = exists $params{stderr} ? $params{stderr} : 1; + $self->{buffer} = ""; + + return $self; +} + +sub log_message +{ + my $self = shift; + my %params = @_; + + $self->{buffer} .= $params{message}; +} + +sub buffer +{ + my($self, $new) = @_; + + if(defined $new) { + $self->{buffer} = $new; + } + + return $self->{buffer}; +} + +sub reset +{ + my($self) = @_; + + $self->{buffer} = ""; +} + +1; diff --git a/xml/log4j-1.2.dtd b/xml/log4j-1.2.dtd new file mode 100644 index 0000000..83e0819 --- /dev/null +++ b/xml/log4j-1.2.dtd @@ -0,0 +1,170 @@ +<?xml version="1.0" encoding="UTF-8" ?> + +<!-- log4j-1.2.dtd is included in the log4perl distribution +for your convenience. The log4perl dtd is based on this +version of the log4j.dtd --> + +<!-- Authors: Chris Taylor, Ceki Gulcu. --> + +<!-- Version: 1.2 --> + +<!-- A configuration element consists of optional renderer +elements,appender elements, categories and an optional root +element. --> + +<!ELEMENT log4j:configuration (renderer*, appender*,(category|logger)*,root?, + categoryFactory?)> + +<!-- The "threshold" attribute takes a level value such that all --> +<!-- logging statements with a level equal or below this value are --> +<!-- disabled. --> + +<!-- Setting the "debug" enable the printing of internal log4j logging --> +<!-- statements. --> + +<!-- By default, debug attribute is "null", meaning that we not do touch --> +<!-- internal log4j logging settings. The "null" value for the threshold --> +<!-- attribute can be misleading. The threshold field of a repository --> +<!-- cannot be set to null. The "null" value for the threshold attribute --> +<!-- simply means don't touch the threshold field, the threshold field --> +<!-- keeps its old value. --> + +<!ATTLIST log4j:configuration + xmlns:log4j CDATA #FIXED "http://jakarta.apache.org/log4j/" + threshold (all|debug|info|warn|error|fatal|off|null) "null" + debug (true|false|null) "null" +> + +<!-- renderer elements allow the user to customize the conversion of --> +<!-- message objects to String. --> + +<!ELEMENT renderer EMPTY> +<!ATTLIST renderer + renderedClass CDATA #REQUIRED + renderingClass CDATA #REQUIRED +> + +<!-- Appenders must have a name and a class. --> +<!-- Appenders may contain an error handler, a layout, optional parameters --> +<!-- and filters. They may also reference (or include) other appenders. --> +<!ELEMENT appender (errorHandler?, param*, layout?, filter*, appender-ref*)> +<!ATTLIST appender + name ID #REQUIRED + class CDATA #REQUIRED +> + +<!ELEMENT layout (param*)> +<!ATTLIST layout + class CDATA #REQUIRED +> + +<!ELEMENT filter (param*)> +<!ATTLIST filter + class CDATA #REQUIRED +> + +<!-- ErrorHandlers can be of any class. They can admit any number of --> +<!-- parameters. --> + +<!ELEMENT errorHandler (param*, root-ref?, logger-ref*, appender-ref?)> +<!ATTLIST errorHandler + class CDATA #REQUIRED +> + +<!ELEMENT root-ref EMPTY> + +<!ELEMENT logger-ref EMPTY> +<!ATTLIST logger-ref + ref IDREF #REQUIRED +> + +<!ELEMENT param EMPTY> +<!ATTLIST param + name CDATA #REQUIRED + value CDATA #REQUIRED +> + + +<!-- The priority class is org.apache.log4j.Level by default --> +<!ELEMENT priority (param*)> +<!ATTLIST priority + class CDATA #IMPLIED + value CDATA #REQUIRED +> + +<!-- The level class is org.apache.log4j.Level by default --> +<!ELEMENT level (param*)> +<!ATTLIST level + class CDATA #IMPLIED + value CDATA #REQUIRED +> + + +<!-- If no level element is specified, then the configurator MUST not --> +<!-- touch the level of the named category. --> +<!ELEMENT category (param*,(priority|level)?,appender-ref*)> +<!ATTLIST category + class CDATA #IMPLIED + name CDATA #REQUIRED + additivity (true|false) "true" +> + +<!-- If no level element is specified, then the configurator MUST not --> +<!-- touch the level of the named logger. --> +<!ELEMENT logger (level?,appender-ref*)> +<!ATTLIST logger + name ID #REQUIRED + additivity (true|false) "true" +> + + +<!ELEMENT categoryFactory (param*)> +<!ATTLIST categoryFactory + class CDATA #REQUIRED> + +<!ELEMENT appender-ref EMPTY> +<!ATTLIST appender-ref + ref IDREF #REQUIRED +> + +<!-- If no priority element is specified, then the configurator MUST not --> +<!-- touch the priority of root. --> +<!-- The root category always exists and cannot be subclassed. --> +<!ELEMENT root (param*, (priority|level)?, appender-ref*)> + + +<!-- ==================================================================== --> +<!-- A logging event --> +<!-- ==================================================================== --> +<!ELEMENT log4j:eventSet (log4j:event*)> +<!ATTLIST log4j:eventSet + xmlns:log4j CDATA #FIXED "http://jakarta.apache.org/log4j/" + version (1.1|1.2) "1.2" + includesLocationInfo (true|false) "true" +> + + + +<!ELEMENT log4j:event (log4j:message, log4j:NDC?, log4j:throwable?, + log4j:locationInfo?) > + +<!-- The timestamp format is application dependent. --> +<!ATTLIST log4j:event + logger CDATA #REQUIRED + level CDATA #REQUIRED + thread CDATA #REQUIRED + timestamp CDATA #REQUIRED +> + +<!ELEMENT log4j:message (#PCDATA)> +<!ELEMENT log4j:NDC (#PCDATA)> + +<!ELEMENT log4j:throwable (#PCDATA)> + +<!ELEMENT log4j:locationInfo EMPTY> +<!ATTLIST log4j:locationInfo + class CDATA #REQUIRED + method CDATA #REQUIRED + file CDATA #REQUIRED + line CDATA #REQUIRED +> diff --git a/xml/log4perl.dtd b/xml/log4perl.dtd new file mode 100644 index 0000000..8ba9806 --- /dev/null +++ b/xml/log4perl.dtd @@ -0,0 +1,77 @@ +<?xml version="1.0" encoding="UTF-8" ?> + +<!-- This adds some functionality onto the log4j.dtd --> +<!-- Authors: Kevin Goess --> +<!-- Version: 1.0 --> + + +<!-- include the log4j dtd --> +<!ENTITY % log4j.dtd SYSTEM "log4j-1.2.dtd"> +%log4j.dtd; + + +<!-- overriding log4j:configuration with log4perl:configuration + so that we can use a log4perl:appender --> +<!ELEMENT log4perl:configuration (renderer*, log4perl:appender*, appender*, + (log4perl:filter)*,(category|logger)*,root?, PatternLayout?)> + +<!ATTLIST log4perl:configuration + xmlns:log4perl CDATA #FIXED "http://log4perl.sourceforge.net/" + threshold (all|debug|info|warn|error|fatal|off|null) "null" + debug (true|false|null) "null" + oneMessagePerAppender (true|false|null) "null" +> + + +<!-- overriding log4j's appender with log4perl:appender so can include + other kinds of param structures --> +<!ELEMENT log4perl:appender (errorHandler?, (param|param-nested|param-text)*, + (layout|log4perl:layout)?, filter*, filter-ref*, appender-ref*)> +<!ATTLIST log4perl:appender + xmlns:log4perl CDATA #FIXED "http://log4perl.sourceforge.net/" + name ID #REQUIRED + class CDATA #REQUIRED +> + +<!-- a complex param type --> +<!ELEMENT param-nested ((param|param-nested|param-text)+)> +<!ATTLIST param-nested + name CDATA #REQUIRED +> + + +<!-- so you can put the value in the text instead of always having to + put it in the attribute --> +<!ELEMENT param-text (#PCDATA)> +<!ATTLIST param-text + name CDATA #REQUIRED +> + +<!-- a top-level PatternLayout to handle global cspecs --> +<!ELEMENT PatternLayout (cspec+)> + +<!-- custom conversion specifiers --> +<!ELEMENT cspec (#PCDATA)> +<!ATTLIST cspec + name CDATA #REQUIRED +> + + +<!ELEMENT log4perl:layout ((param|cspec)*)> +<!ATTLIST log4perl:layout + class CDATA #REQUIRED +> + +<!-- This is the filter at the document root, as opposed to the appender + children filters. This implement the log4perl-specific boolean appenders +--> +<!ELEMENT log4perl:filter (#PCDATA|param|param-nested|param-text)*> +<!ATTLIST log4perl:filter + class CDATA #IMPLIED + name CDATA #IMPLIED + value CDATA #IMPLIED +> + +<!ELEMENT filter-ref EMPTY> +<!ATTLIST filter-ref id NMTOKEN #REQUIRED> + |