From 94566f012421026c8311552f99175a5989eba063 Mon Sep 17 00:00:00 2001 From: Lorry Tar Creator Date: Sat, 1 Nov 2014 01:47:12 +0000 Subject: Log-Log4perl-1.46 --- .licensizer.yml | 30 + Changes | 1194 ++++++++ LICENSE | 14 + MANIFEST | 163 ++ MANIFEST.SKIP | 24 + META.json | 49 + META.yml | 27 + Makefile.PL | 93 + README | 2183 +++++++++++++++ eg/5005it.pl | 84 + eg/L4pResurrectable.pm | 12 + eg/benchmarks/Makefile | 10 + eg/benchmarks/simple | 79 + eg/color | 26 + eg/dupe-warning.conf | 7 + eg/jabber.conf | 14 + eg/l4p-tmpl | 63 + eg/log4j-file-append-java.conf | 12 + eg/log4j-file-append-perl.conf | 13 + eg/log4j-manual-1.conf | 13 + eg/log4j-manual-2.conf | 13 + eg/log4j-manual-3.conf | 14 + eg/log4j-utf8.conf | 5 + eg/newsyslog-test | 30 + eg/override_appender | 73 + eg/prototype | 34 + eg/syslog.pl | 86 + eg/yamlparser | 93 + ldap/log4perl-2.ldif | 70 + ldap/log4perl-unittest.ldif | 42 + ldap/testload.ldif | 139 + lib/Log/Log4perl.pm | 2956 ++++++++++++++++++++ lib/Log/Log4perl/Appender.pm | 733 +++++ lib/Log/Log4perl/Appender/Buffer.pm | 279 ++ lib/Log/Log4perl/Appender/DBI.pm | 643 +++++ lib/Log/Log4perl/Appender/File.pm | 545 ++++ lib/Log/Log4perl/Appender/Limit.pm | 340 +++ lib/Log/Log4perl/Appender/RRDs.pm | 134 + lib/Log/Log4perl/Appender/Screen.pm | 124 + lib/Log/Log4perl/Appender/ScreenColoredLevels.pm | 235 ++ lib/Log/Log4perl/Appender/Socket.pm | 226 ++ lib/Log/Log4perl/Appender/String.pm | 110 + lib/Log/Log4perl/Appender/Synchronized.pm | 292 ++ lib/Log/Log4perl/Appender/TestArrayBuffer.pm | 94 + lib/Log/Log4perl/Appender/TestBuffer.pm | 189 ++ lib/Log/Log4perl/Appender/TestFileCreeper.pm | 89 + lib/Log/Log4perl/Catalyst.pm | 368 +++ lib/Log/Log4perl/Config.pm | 1213 ++++++++ lib/Log/Log4perl/Config/BaseConfigurator.pm | 345 +++ lib/Log/Log4perl/Config/DOMConfigurator.pm | 912 ++++++ lib/Log/Log4perl/Config/PropertyConfigurator.pm | 220 ++ lib/Log/Log4perl/Config/Watch.pm | 353 +++ lib/Log/Log4perl/DateFormat.pm | 461 +++ lib/Log/Log4perl/FAQ.pm | 2682 ++++++++++++++++++ lib/Log/Log4perl/Filter.pm | 368 +++ lib/Log/Log4perl/Filter/Boolean.pm | 211 ++ lib/Log/Log4perl/Filter/LevelMatch.pm | 118 + lib/Log/Log4perl/Filter/LevelRange.pm | 126 + lib/Log/Log4perl/Filter/MDC.pm | 97 + lib/Log/Log4perl/Filter/StringMatch.pm | 126 + lib/Log/Log4perl/InternalDebug.pm | 122 + lib/Log/Log4perl/JavaMap.pm | 184 ++ lib/Log/Log4perl/JavaMap/ConsoleAppender.pm | 95 + lib/Log/Log4perl/JavaMap/FileAppender.pm | 117 + lib/Log/Log4perl/JavaMap/JDBCAppender.pm | 133 + lib/Log/Log4perl/JavaMap/NTEventLogAppender.pm | 91 + lib/Log/Log4perl/JavaMap/RollingFileAppender.pm | 143 + lib/Log/Log4perl/JavaMap/SyslogAppender.pm | 109 + lib/Log/Log4perl/JavaMap/TestBuffer.pm | 70 + lib/Log/Log4perl/Layout.pm | 92 + lib/Log/Log4perl/Layout/NoopLayout.pm | 81 + lib/Log/Log4perl/Layout/PatternLayout.pm | 888 ++++++ lib/Log/Log4perl/Layout/PatternLayout/Multiline.pm | 93 + lib/Log/Log4perl/Layout/SimpleLayout.pm | 97 + lib/Log/Log4perl/Level.pm | 358 +++ lib/Log/Log4perl/Logger.pm | 1165 ++++++++ lib/Log/Log4perl/MDC.pm | 136 + lib/Log/Log4perl/NDC.pm | 151 + lib/Log/Log4perl/Resurrector.pm | 214 ++ lib/Log/Log4perl/Util.pm | 118 + lib/Log/Log4perl/Util/Semaphore.pm | 264 ++ lib/Log/Log4perl/Util/TimeTracker.pm | 259 ++ t/001Level.t | 61 + t/002Logger.t | 403 +++ t/003Layout-Rr.t | 154 + t/003Layout.t | 285 ++ t/004Config.t | 406 +++ t/005Config-Perl.t | 58 + t/006Config-Java.t | 74 + t/007LogPrio.t | 67 + t/008ConfCat.t | 56 + t/009Deuce.t | 55 + t/010JConsole.t | 93 + t/011JFile.t | 77 + t/012Deeper.t | 212 ++ t/013Bench.t | 144 + t/014ConfErrs.t | 252 ++ t/015fltmsg.t | 120 + t/016Export.t | 140 + t/017Watch.t | 391 +++ t/018Init.t | 70 + t/019Warn.t | 75 + t/020Easy.t | 235 ++ t/020Easy2.t | 63 + t/021AppThres.t | 240 ++ t/022Wrap.t | 131 + t/023Date.t | 184 ++ t/024WarnDieCarp.t | 404 +++ t/025CustLevels.t | 208 ++ t/026FileApp.t | 494 ++++ t/027Watch2.t | 218 ++ t/027Watch3.t | 152 + t/027Watch4.t | 44 + t/028Additivity.t | 124 + t/029SysWide.t | 123 + t/030LDLevel.t | 55 + t/031NDC.t | 105 + t/032JRollFile.t | 73 + t/033UsrCspec.t | 314 +++ t/034DBI.t | 328 +++ t/035JDBCAppender.t | 144 + t/036JSyslog.t | 68 + t/037JWin32Event.t | 59 + t/038XML-DOM1.t | 287 ++ t/039XML-DOM2.t | 358 +++ t/040Filter.t | 516 ++++ t/041SafeEval.t | 191 ++ t/042SyncApp.t | 339 +++ t/043VarSubst.t | 141 + t/044XML-Filter.t | 256 ++ t/045Composite.t | 372 +++ t/046RRDs.t | 60 + t/048lwp.t | 98 + t/049Unhide.t | 50 + t/050Buffer.t | 76 + t/051Extra.t | 113 + t/052Utf8.t | 130 + t/053Resurrect.t | 38 + t/054Subclass.t | 29 + t/055AppDestroy.t | 53 + t/056SyncApp2.t | 88 + t/057MsgChomp.t | 88 + t/058Warnings.t | 25 + t/059Wrapper.t | 94 + t/060Initialized.t | 44 + t/061Multiline.t | 35 + t/062InitHash.t | 27 + t/063LoggerRemove.t | 56 + t/064RealClass.t | 44 + t/065Undef.t | 28 + t/066SQLite.t | 96 + t/067Exception.t | 25 + t/068MultilineIndented.t | 81 + t/069MoreMultiline.t | 54 + t/070UTCDate.t | 42 + t/compare.pl | 86 + t/deeper1.expected | 14 + t/deeper6.expected | 13 + t/deeper7.expected | 12 + t/lib/Log4perlInternalTest.pm | 62 + t/testdisp.pl | 52 + xml/log4j-1.2.dtd | 170 ++ xml/log4perl.dtd | 77 + 163 files changed, 35657 insertions(+) create mode 100644 .licensizer.yml create mode 100644 Changes create mode 100644 LICENSE create mode 100644 MANIFEST create mode 100644 MANIFEST.SKIP create mode 100644 META.json create mode 100644 META.yml create mode 100644 Makefile.PL create mode 100644 README create mode 100755 eg/5005it.pl create mode 100644 eg/L4pResurrectable.pm create mode 100644 eg/benchmarks/Makefile create mode 100755 eg/benchmarks/simple create mode 100755 eg/color create mode 100644 eg/dupe-warning.conf create mode 100644 eg/jabber.conf create mode 100755 eg/l4p-tmpl create mode 100644 eg/log4j-file-append-java.conf create mode 100644 eg/log4j-file-append-perl.conf create mode 100644 eg/log4j-manual-1.conf create mode 100644 eg/log4j-manual-2.conf create mode 100644 eg/log4j-manual-3.conf create mode 100644 eg/log4j-utf8.conf create mode 100755 eg/newsyslog-test create mode 100755 eg/override_appender create mode 100755 eg/prototype create mode 100755 eg/syslog.pl create mode 100755 eg/yamlparser create mode 100644 ldap/log4perl-2.ldif create mode 100644 ldap/log4perl-unittest.ldif create mode 100644 ldap/testload.ldif create mode 100644 lib/Log/Log4perl.pm create mode 100644 lib/Log/Log4perl/Appender.pm create mode 100644 lib/Log/Log4perl/Appender/Buffer.pm create mode 100644 lib/Log/Log4perl/Appender/DBI.pm create mode 100755 lib/Log/Log4perl/Appender/File.pm create mode 100644 lib/Log/Log4perl/Appender/Limit.pm create mode 100755 lib/Log/Log4perl/Appender/RRDs.pm create mode 100755 lib/Log/Log4perl/Appender/Screen.pm create mode 100644 lib/Log/Log4perl/Appender/ScreenColoredLevels.pm create mode 100755 lib/Log/Log4perl/Appender/Socket.pm create mode 100644 lib/Log/Log4perl/Appender/String.pm create mode 100644 lib/Log/Log4perl/Appender/Synchronized.pm create mode 100644 lib/Log/Log4perl/Appender/TestArrayBuffer.pm create mode 100644 lib/Log/Log4perl/Appender/TestBuffer.pm create mode 100755 lib/Log/Log4perl/Appender/TestFileCreeper.pm create mode 100644 lib/Log/Log4perl/Catalyst.pm create mode 100644 lib/Log/Log4perl/Config.pm create mode 100644 lib/Log/Log4perl/Config/BaseConfigurator.pm create mode 100644 lib/Log/Log4perl/Config/DOMConfigurator.pm create mode 100644 lib/Log/Log4perl/Config/PropertyConfigurator.pm create mode 100644 lib/Log/Log4perl/Config/Watch.pm create mode 100755 lib/Log/Log4perl/DateFormat.pm create mode 100644 lib/Log/Log4perl/FAQ.pm create mode 100644 lib/Log/Log4perl/Filter.pm create mode 100644 lib/Log/Log4perl/Filter/Boolean.pm create mode 100644 lib/Log/Log4perl/Filter/LevelMatch.pm create mode 100644 lib/Log/Log4perl/Filter/LevelRange.pm create mode 100644 lib/Log/Log4perl/Filter/MDC.pm create mode 100644 lib/Log/Log4perl/Filter/StringMatch.pm create mode 100644 lib/Log/Log4perl/InternalDebug.pm create mode 100644 lib/Log/Log4perl/JavaMap.pm create mode 100644 lib/Log/Log4perl/JavaMap/ConsoleAppender.pm create mode 100644 lib/Log/Log4perl/JavaMap/FileAppender.pm create mode 100644 lib/Log/Log4perl/JavaMap/JDBCAppender.pm create mode 100755 lib/Log/Log4perl/JavaMap/NTEventLogAppender.pm create mode 100644 lib/Log/Log4perl/JavaMap/RollingFileAppender.pm create mode 100755 lib/Log/Log4perl/JavaMap/SyslogAppender.pm create mode 100644 lib/Log/Log4perl/JavaMap/TestBuffer.pm create mode 100644 lib/Log/Log4perl/Layout.pm create mode 100644 lib/Log/Log4perl/Layout/NoopLayout.pm create mode 100644 lib/Log/Log4perl/Layout/PatternLayout.pm create mode 100755 lib/Log/Log4perl/Layout/PatternLayout/Multiline.pm create mode 100644 lib/Log/Log4perl/Layout/SimpleLayout.pm create mode 100644 lib/Log/Log4perl/Level.pm create mode 100644 lib/Log/Log4perl/Logger.pm create mode 100644 lib/Log/Log4perl/MDC.pm create mode 100644 lib/Log/Log4perl/NDC.pm create mode 100644 lib/Log/Log4perl/Resurrector.pm create mode 100644 lib/Log/Log4perl/Util.pm create mode 100644 lib/Log/Log4perl/Util/Semaphore.pm create mode 100644 lib/Log/Log4perl/Util/TimeTracker.pm create mode 100644 t/001Level.t create mode 100755 t/002Logger.t create mode 100644 t/003Layout-Rr.t create mode 100755 t/003Layout.t create mode 100644 t/004Config.t create mode 100644 t/005Config-Perl.t create mode 100644 t/006Config-Java.t create mode 100644 t/007LogPrio.t create mode 100644 t/008ConfCat.t create mode 100644 t/009Deuce.t create mode 100644 t/010JConsole.t create mode 100644 t/011JFile.t create mode 100644 t/012Deeper.t create mode 100644 t/013Bench.t create mode 100644 t/014ConfErrs.t create mode 100644 t/015fltmsg.t create mode 100644 t/016Export.t create mode 100644 t/017Watch.t create mode 100644 t/018Init.t create mode 100644 t/019Warn.t create mode 100644 t/020Easy.t create mode 100644 t/020Easy2.t create mode 100644 t/021AppThres.t create mode 100644 t/022Wrap.t create mode 100755 t/023Date.t create mode 100755 t/024WarnDieCarp.t create mode 100644 t/025CustLevels.t create mode 100644 t/026FileApp.t create mode 100644 t/027Watch2.t create mode 100644 t/027Watch3.t create mode 100755 t/027Watch4.t create mode 100644 t/028Additivity.t create mode 100644 t/029SysWide.t create mode 100644 t/030LDLevel.t create mode 100644 t/031NDC.t create mode 100644 t/032JRollFile.t create mode 100644 t/033UsrCspec.t create mode 100644 t/034DBI.t create mode 100644 t/035JDBCAppender.t create mode 100644 t/036JSyslog.t create mode 100644 t/037JWin32Event.t create mode 100644 t/038XML-DOM1.t create mode 100644 t/039XML-DOM2.t create mode 100644 t/040Filter.t create mode 100644 t/041SafeEval.t create mode 100644 t/042SyncApp.t create mode 100755 t/043VarSubst.t create mode 100644 t/044XML-Filter.t create mode 100644 t/045Composite.t create mode 100644 t/046RRDs.t create mode 100644 t/048lwp.t create mode 100644 t/049Unhide.t create mode 100644 t/050Buffer.t create mode 100644 t/051Extra.t create mode 100644 t/052Utf8.t create mode 100644 t/053Resurrect.t create mode 100644 t/054Subclass.t create mode 100755 t/055AppDestroy.t create mode 100644 t/056SyncApp2.t create mode 100755 t/057MsgChomp.t create mode 100644 t/058Warnings.t create mode 100755 t/059Wrapper.t create mode 100644 t/060Initialized.t create mode 100644 t/061Multiline.t create mode 100644 t/062InitHash.t create mode 100755 t/063LoggerRemove.t create mode 100755 t/064RealClass.t create mode 100644 t/065Undef.t create mode 100644 t/066SQLite.t create mode 100644 t/067Exception.t create mode 100644 t/068MultilineIndented.t create mode 100644 t/069MoreMultiline.t create mode 100644 t/070UTCDate.t create mode 100644 t/compare.pl create mode 100644 t/deeper1.expected create mode 100644 t/deeper6.expected create mode 100644 t/deeper7.expected create mode 100755 t/lib/Log4perlInternalTest.pm create mode 100644 t/testdisp.pl create mode 100644 xml/log4j-1.2.dtd create mode 100644 xml/log4perl.dtd 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 , + Kevin Goess + + Contributors (in alphabetical order): + Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton + Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony + Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy + Grundman, Paul Harrington, Alexander Hartmaier David Hull, + Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, + Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, + Lars Thegler, David Viner, Mac Yang. + +license: | + Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE + and Kevin Goess Ecpan@goess.orgE. + + This library is free software; you can redistribute it and/or modify + it under the same terms as Perl itself. diff --git a/Changes b/Changes new file mode 100644 index 0000000..c554cde --- /dev/null +++ b/Changes @@ -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 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 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 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 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 + * (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 and + Chris Winters 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_ 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 : 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 + 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 Log keyword expansion. + +0.47 (07/11/2004) + * (ms) Added suggestion by Hutton Davidson + 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 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 + (specify number of test cases, + getting rid of no_plan). + * (ms) Dennis Gregorovic 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 . + +0.44 (04/25/2004) + * (ms) added filename() method to L4P::Appender::File as suggested + by Lee Carmichael + * (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 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 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 + +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 Edviner@yahoo-inc.comE + * (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 (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 for bringing this up. + * (ms) fixed bug with error_die() - printed the wrong function/line/file. + Reported by Brett Rann . + * (ms) added %T to PatternLayout as a stack traced as suggested by + Brett Rann . + +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 . + * (ms) Applied patch by Mac Yang for + Log::Log4perl::DateFormat to calculate the timezone for the 'Z' + conversion specifier. + +0.36 (07/22/2003) + * (ms) Matthew Keene 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 . 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 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 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 + 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 : 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 + +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. + : 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 + * (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 . 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 ) + * (ms) Fixed logdie/logwarn caller(x) offset bug reported by + Brian Duffy + * (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 + * 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 + * 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 + 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 , 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 diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..b36289d --- /dev/null +++ b/LICENSE @@ -0,0 +1,14 @@ +=head1 COPYRIGHT AND LICENSE + +Copyright 2002-2012 by +Mike Schilli and Kevin Goess . + +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 " + ], + "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 ' +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 < { + 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 ') : ()), + '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 <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 + + + + 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 . 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 + () + + 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 + and PatternLayout + + + 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 . + + 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 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, + + + [2] Ceki Gülcü, "Short introduction to log4j", + + + [3] Vipan Singla, "Don't Use System.out.println! Use Log4j.", + + + [4] The Log::Log4perl project home page: + +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 , Kevin Goess + + Contributors (in alphabetical order): Ateeq Altaf, Cory Bennett, Jens + Berthold, Jeremy Bopp, Hutton Davidson, Chris R. Donnelly, Matisse + Enzer, Hugh Esco, Anthony Foiani, James FitzGibbon, Carl Franks, Dennis + Gregorovic, Andy Grundman, Paul Harrington, Alexander Hartmaier, David + Hull, Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, Brett + Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, Lars Thegler, + David Viner, Mac Yang. + +LICENSE + Copyright 2002-2013 by Mike Schilli and Kevin Goess + . + + 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 '', ; + 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 +########################################### +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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 +###################################################################### +# 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 = <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 => <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 + +L + +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 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 (classes, functions) +of your system should generate logs. + +=item * + +You specify how detailed the logging of these components should be by +specifying logging I. + +=item * + +You also specify which so-called I 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 +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, 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 +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 package can be initialized in two ways: Either +via Perl commands or via a C-style configuration file. + +=head2 Initialize via a configuration file + +This is the easiest way to prepare your system for using +C. 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, using the format + + [millisecs] source-filename line-number class - message newline + +Assuming that this configuration file is saved as C, 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 in the code, you can retrieve +logger objects I 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 will write +"Error message" to the specified log file, but won't do anything for +the C and C calls, because the log level has been set +to C for all components in the first line of +configuration file shown above. + +Why Cget_logger> and +not Cnew>? 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: + + 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 method to obtain +a reference to the I possible logger object of +a certain category. +That's called a I if you're a Gamma fan. + +How does the logger know +which messages it is supposed to log and which ones to suppress? +C works with inheritance: The config file above didn't +specify anything about C. +And yet, we've defined a logger of the category +C. +In this case, C will walk up the namespace hierarchy +(C 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 defines a log level, but not necessarily an appender) +defines that +the log level is supposed to be C -- meaning that I +and I 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-Ecategory()> to retrieve it. + +=head2 Log Levels + +There are six predefined log levels: C, C, C, C, +C, and C (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, then messages logged +with C, C, and C will be suppressed. +C, C and C 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 method with the appropriate level +using the constants defined in C: + + 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()> 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-Eis_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 CEnabled()>, +so C<$logger-EisDebugEnabled()> is synonymous to +C<$logger-Eis_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 doesn't define any appenders by default, not even the root +logger has one. + +C 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 Egcarls@cpan.orgE. +It allows for hooking up Log::Log4perl with the graphical Log Analyzer +Chainsaw (see +L). + +=head2 Additional Appenders via Log::Dispatch + +C also supports I excellent C +framework which implements a wide variety of different appenders. + +Here's the list of appender modules currently available via C: + + 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 manual page. + +=head2 Appender Example + +Now let's assume that we want to log C or +higher prioritized messages in the C category +to both STDOUT and to a log file, say C. +In the initialization section of your system, +just define two appenders using the readily available +C and C +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 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, which logs the +debug level, a hyphen (-) and the log message: + + INFO - Important Info! + +For more detailed info on layout formats, see L. + +In the configuration sample above, we chose to define a I +logger (C). +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 +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 documentation on how to +accomplish that. + +=head2 Configuration files + +As shown above, you can define C 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 has been designed to understand C 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 or higher in the root +hierarchy and has the system write them to the console. +C is a Java appender, but C jumps +through a significant number of hoops internally to map these to their +corresponding Perl classes, C 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 logger. +The root logger is easily triggered by debug-messages, +but the C logger makes sure that messages issued within +the C component and below are only forwarded to the appender +if they're of priority I or higher. + +Note that the C 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, which uses +C (ultimately mapped by C +to L) to write to the screen. And +C, a C +(mapped by C to +L with the C attribute specifying the +log file. + +See L 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: +C and +C: + +=over 4 + +=item C + +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 + +on the other hand is very powerful and +allows for a very flexible format in C-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) + +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). + +Similar options are available for shrinking the displayed category or +limit file/path components, C<%F{1}> only displays the source file I +without any path components while C<%F> logs the full path. %c{2} only +logs the last two components of the current category, C +becomes C 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 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
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. 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 website under + +L +and +L + +=head2 Penalties + +Logging comes with a price tag. C 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 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 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 +loop can be skipped entirely if the current logging level for the +actual component is higher than C. +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: + + $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 key +(C) and pass it the value that came with +the key named C as an argument. +The anonymous hash in the call above will be replaced by the return +value of the filter function. + +=head1 Categories + +B +C uses I 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, is assigned the +(virtual) C category. Depending on the C +configuration, this will either call a C appender, +a C appender, or an appender assigned to root -- without +C having any relevance to the class system used in +the program. +The logger in the second function adheres to the +C 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 doesn't only allow you to selectively switch I a category +of log messages, you can also use the mechanism to selectively I +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 and below will be +logged only if they're C or worse, while in all other system components +even C 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 is returned. + +For example, + + my $ret = $logger->info("Message"); + +will return C if the system debug level for the current category +is not C 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 value if the message +made it through to one or more appenders and a I 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 just inherits everything from C, including the constructor +C. +Contrary to what you might be thinking at first, this won't log anything. +Reason for this is the C call in package C, which +will always get a logger of the C category, even if we call C via +the C package, which will make perl go up the inheritance +tree to actually execute C. Since we've only defined logging +behaviour for C in the configuration file, nothing will happen. + +This can be fixed by changing the C method in C +to obtain a logger of the category matching the +I 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 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 +more than once will cause it to clobber the existing configuration and +I it by the new one. + +If you're in a traditional CGI environment, where every request is +handled by a new process, calling C every time is fine. In +persistent environments like C, 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 is identical to C, just with the exception +that it will leave a potentially existing configuration alone and +will only call C 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 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 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 +document in the Log::Log4perl distribution. + +=head1 Cool Tricks + +Here's a collection of useful tricks for the advanced C user. +For more, check the FAQ, either in the distribution +(L) or on L. + +=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 method from +C 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, call it without parameters (C), you'll +get the logger of a category named after the current package. +C is equivalent to C. + +=head2 Alternative initialization + +Instead of having C read in a configuration file by specifying +a file name or passing it a reference to an open filehandle +(Cinit( \*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 pairs of the configuration in +a hash, you can just as well initialize C 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. +It uses LWP to download the file and then calls parse() on the resulting string. +By default it will use a L 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 +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 command: + + kill -HUP pid + +where C 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. + +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 Cwatcher-Eforce_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 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 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 +Cwatcher()-Efile()>. + +=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. + +=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 is interpreted as Perl code to +be executed at the time the application parses the configuration +via C. The return value of the subroutine +is used by Log::Log4perl as the configuration value. + +The Perl code is executed in the C
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: +While the snippets above are run I +when C is called, the conversion specifier +snippets are executed I 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-Eallowed_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: + + 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-Evars_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-Eallowed_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-Eallow_code() is called with a +value which is a key of the map previously defined with +Log::Log4perl::Config-Eallowed_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 -Einit() fails is because the +'restrictive' name maps to an opcode mask of ':default'. getpwuid() is not +part of ':default', so -Einit() fails. The 'safe' name maps to an opcode +mask of ':browse', which allows getpwuid() to run, so -Einit() 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 and +L. + +=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 the level of logging currently being done, use: + + $logger->more_logging($delta); + +and to B 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 +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, 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 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 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 will instantiate a I +and introduce the +convenience functions C, C, C, C, +C, C, and C into the package namespace. +These functions simply take messages as +arguments and forward them to the stealth loggers methods (C, +C, and so on). + +If a message should never be blocked, regardless of the log level, +use the C function which corresponds to a log level of C: + + ALWAYS "This will be printed regardless of the log level"; + +The C 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 (the logger's priority), C (the appender's data sink), +C (the logger's category and C for the appender's +pattern layout specification. +All key-value pairs are optional, they +default to C<$DEBUG> for C, C for C, +C<""> (root category) for C and +C<%d %m%n> for C: + + Log::Log4perl->easy_init( { level => $DEBUG, + file => ">test.log", + utf8 => 1, + category => "Bar::Twix", + layout => '%F{1}-%L-%M: %m%n' } ); + +The C parameter takes file names preceded by C<"E"> +(overwrite) and C<"EE"> (append) as arguments. This will +cause C appenders to be created behind +the scenes. Also the keywords C and C (no C> or +CE>) are recognized, which will utilize and configure +C appropriately. The C flag, +if set to a true value, runs a C 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'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 will take any number of different logger +definitions as hash references. + +Also, stealth loggers feature the functions C, C, +and C, +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 but +C (including the traditional output to STDERR) in any case afterwards. + +See L<"Log and die or warn"> for the similar C and C +functions of regular (i.e non-stealth) loggers. + +Similarily, C, C, C, and C +are provided in C<:easy> mode, facilitating the use of C, +C, C, and C with stealth loggers. + +B>. + +By the way, these convenience functions perform exactly as fast as the +standard Log::Log4perl logger methods, there's I 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 won't grow the stack +indefinitely, but limit it to a maximum, defined in C +(currently 5). A call to C 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. + +=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 method: + + my $value = Log::Log4perl::MDC->get($key); + +If no value has been stored previously under C<$key>, the C method +will return C. + +Typically, MDC values are retrieved later on via the C<"%X{...}"> placeholder +in C. If the C method +returns C, 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. + +=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 1.12, you can even force I modules +loaded by a script to have their hidden Log4perl statements +resurrected. For this to happen, load C +I 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 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 class method. This comes +in handy if you want to manipulate or query appender properties after +the Log4perl configuration has been loaded via C. + +Note that internally, Log::Log4perl uses the C +wrapper class to control the real appenders (like +C or C). +The C class has an C attribute, +pointing to the real appender. + +The reason for this is that external appenders like +C don't support all of Log::Log4perl's +appender control mechanisms (like appender thresholds). + +The previously mentioned method C returns a +reference to the I 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 method: + + $app->threshold( $FATAL ); + +To conveniently adjust I 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 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 to +C in the I argument. Behind the scenes, +C will create the necessary +C (or C) object and pass +along the name value pairs we provided to +Cnew()> after the first argument. + +The C value is optional and if you don't provide one, +Cnew()> 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 +Cnew()> will also take care of the +C argument to the C constructors called +behind the scenes -- yes, it does. This is because we want the +C objects to blindly log everything we send them +(C is their lowest setting) because I in C +want to call the shots and decide on when and what to log. + +The call to the appender's I method specifies the format (as a +previously created C 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, 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 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 remove an appender from the system. + +To eradicate an appender from the system, +you need to call Ceradicate_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 +Cremove_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 is a very clever +simplified logger implementation, covering some of the I +functionality. Among the things that +C can but C 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 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, +which is equally easy to use. + +=head1 Using Log::Log4perl with wrapper functions and classes + +If you don't use C 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's +loggers assume a static caller depth to the application that's using them. + +If you're using +one (or more) wrapper functions, C 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 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, +then C 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 +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 +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 Cinfiltrate_lwp()> does exactly this. +In a very rude way, it pulls the rug from under LWP::UserAgent and transforms +its C messages into C calls of loggers of the category +C<"LWP::UserAgent">. Similarily, C's C messages +are turned into C's C method calls. Note that this +only works for LWP::UserAgent versions E 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 +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, 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, +you need to install C (2.00 or better) from CPAN, +which itself depends on C and +C. 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 installation process. + +Log::Log4perl needs C, C and C, +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 (1.20 or better) is required only if you need the +fine-grained time stamps of the C<%r> parameter in +C. + +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 +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 + +=item [2] + +Ceki Gülcü, "Short introduction to log4j", +L + +=item [3] + +Vipan Singla, "Don't Use System.out.println! Use Log4j.", +L + +=item [4] + +The Log::Log4perl project home page: L + +=back + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L +L, + +=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 , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier, David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + 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 +appender set. + +It also supports the collections of appenders. The +module hides the idiosyncrasies of C (e.g. every +dispatcher gotta have a name, but there's no accessor to retrieve it) +from C and yet re-uses the extremely useful variety of +dispatchers already created and tested in C. + +=head1 FUNCTIONS + +=head2 Log::Log4perl::Appender->new($dispatcher_class_name, ...); + +The constructor C takes the name of the appender +class to be created as a I (!) 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 appenders, +if no C parameter is specified, the appender object will create +a unique one (format C), which can be retrieved later via +the C 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 parameter specifies the name of +the C dispatcher used. + +However, if, for instance, +you're using a C dispatcher to send you +email, you'll have to specify C and C email addresses. +Every dispatcher is different. +Please check the C documentation for the appender used +for details on specific requirements. + +The C method will just pass these parameters on to a newly created +C object of the specified type. + +When it comes to logging, the C will transparently +relay all messages to the C object it carries +in its womb. + +=head2 $appender->layout($layout); + +The C method sets the log layout +used by the appender to the format specified by the +C 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 and +L manual pages for details. + +=head1 Supported Appenders + +Here's the list of appender modules currently available via C, +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 doesn't care which ones you use, they're all handled in +the same way via the C interface. +Please check the well-written manual pages of the +C 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 appender truncates log files by default, +and most of the time this is I what you want, we've instructed +C to change this behavior by slipping it the +C append> parameter behind the scenes. So, effectively +with C 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 to an existing logfile C 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 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 +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 might take the +three arguments passed to the logger and put them in three separate +rows into the DB. + +The C 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 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 which just leaves +the messages chunks alone instead of formatting them or replacing +conversion specifiers. + +B (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 +method, an inspection subroutine can be defined with the +appender's C property: + + log4perl.appender.SomeApp.layout=NoopLayout + log4perl.appender.SomeApp.warp_message = sub { \ + $#_ = 2 if @_ > 3; \ + return @_; } + +The inspection subroutine defined by the C +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 is a function in the C
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 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 attribute to the +I 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 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 +###################################################################### +# 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 takes these arguments: + +=over 4 + +=item C + +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. + +=item C + +Specifies the maximum number of messages the appender will hold in +its ring buffer. C is optional. By default, +C will I limit the number of +messages buffered. This might be undesirable in long-running processes +accumulating lots of messages before a flush happens. If +C is set to a numeric value, +C will displace old messages in its +buffer to make room if the buffer is full. + +=item C + +If trigger_level is set to one of Log4perl's levels (see +Log::Log4perl::Level), a C 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 + +C holds a reference to a subroutine, which +C will call on every incoming message +with the same parameters as the appender's C method: + + my($self, $params) = @_; + +C<$params> references a hash containing +the message priority (key C), the +message category (key C) and the content of the message +(key C). + +If the subroutine returns 1, it will trigger a flush of buffered messages. + +Shortcut + +=back + +=head1 DEVELOPMENT NOTES + +C is a I 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 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 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 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 your layout will result in something +like "ARRAY(0x841d8dc)" in your logs. More information on C +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? 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 + +=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 +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 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 and C. C +specifies the number of reconnections attempts the DBI appender +performs until it gives up and dies. C is the +time between reconnection attempts, measured in seconds. +C defaults to 1, C to 0. + +Alternatively, use C or C and read +CHANGING DB CONNECTIONS above. + +Note that C holds one connection open +for every appender, which might be too many. + +=head1 SEE ALSO + +L + +L + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 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 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, if set to a true value, triggers flushing the data +out to the file on every call to C. C is on by default. + +=item syswrite + +C, if set to a true value, makes sure that the appender uses +syswrite() instead of print() to log the message. C usually +maps to the operating system's C function and makes sure that +no other process writes to the same log file while C is busy. +Might safe you from having to use other synchronisation measures like +semaphores (see: Synchronized appender). + +=item umask + +Specifies the C 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 permissions. +If set to C<0000>, new files will be created with C 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 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 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, use the +binmode parameter: + + my $app = Log::Log4perl::Appender::File->new( + filename => 'file.log', + mode => 'append', + binmode => ":utf8", + ); + +A setting of ":utf8" for C is equivalent to specifying +the C 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), 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 option is set to a true value, +C will do exactly that. It defaults to +false. Check the C option for performance +optimizations with this feature. + +=item recreate_check_interval + +In C 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 on the file name and +figure out if its inode has changed. Doing this with every call +to C 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 seconds after the file +has been moved or deleted. If this is undesirable, +setting C to 0 will have the +appender check the file with I call to C. + +=item recreate_check_signal + +In C 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. + +=item recreate_pid_write + +The popular log rotating utility C 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. + +=item create_at_logtime + +The file appender typically creates its logfile in its constructor, i.e. +at Log4perl C 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 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 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 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 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 permissions. +If set to C<0000>, new directory will be created with C permissions. + +=back + +Design and implementation of this module has been greatly inspired by +Dave Rolsky's C appender framework. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 +###################################################################### +# 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 + +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. + +=item C + +Period in seconds between delivery of messages. If messages arrive in between, +they will be either saved (if C is set to a true value) or +discarded (if C isn't set). + +=item C + +File name in which C persistently stores +delivery times. If omitted, the appender will have no recollection of what +happened when the program restarts. + +=item C + +Maximum number of accumulated messages. If exceeded, the appender flushes +all messages, regardless if the interval set in C +has passed or not. Don't mix with C. + +=item C + +Maximum number of accumulated messages. If exceeded, the appender will +simply discard additional messages, waiting for C to expire +to flush all accumulated messages. Don't mix with C. + +=item C + +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 parameter to C<1> and set the limiters +C 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 +to send out the whole batch. The limiter will then call the appender's +C method when it's own buffer gets flushed out. + +=back + +If the appender attached to C uses C 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 is a I 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 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 appenders facilitate writing data +to RRDtool round-robin archives via Log4perl. For documentation +on RRD and its Perl interface C (which comes with the distribution), +check out L. + +Messages sent to Log4perl's RRDs appender are expected to be numerical values +(ints or floats), which then are used to run a C command +on an existing round-robin database. The name of this database needs to +be set in the appender's C configuration parameter. + +If there's more parameters you wish to pass to the C method, +use the C configuration parameter: + + log4perl.appender.RRDapp.rrdupd_params = --template=in:out + +To read out the round robin database later on, use C +or C for graphic displays. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 take an optional parameter C, +if set to a true value, the appender will log to STDERR. +The default setting for C is 1, so messages will be logged to +STDERR by default. + +If C +is set to a false value, it will log to STDOUT (or, more accurately, +whichever file handle is selected via C, STDOUT by default). + +Design and implementation of this module has been greatly inspired by +Dave Rolsky's C 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 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 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 takes an optional parameter C, +if set to a true value, the appender will log to STDERR. If C +is set to a false value, it will log to STDOUT. The default setting +for C is 1, so messages will be logged to STDERR by default. +The constructor can also take an optional parameter C, 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 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), it will C. + +If the appender fails to log a message because the socket's C +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 +method returns, discarding the message. + +If the option C 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 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 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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. It +appends messages to a scalar instance variable. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 +###################################################################### +# 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 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 +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 as a gateway between your +loggers and your appenders. An appender itself, +C just takes two additional +arguments: + +=over 4 + +=item C + +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. + +=item C + +This optional argument specifies the key for the semaphore that +C uses internally to ensure +atomic operations. It defaults to C<_l4p>. If you define more than +one C appender, it is +important to specify different keys for them, as otherwise every +new C appender will nuke +previously defined semaphores. The maximum key length is four +characters, longer keys will be truncated to 4 characters -- +C and C are interpreted to be the same: +C (thanks to David Viner Edviner@yahoo-inc.comE for +pointing this out). + +=back + +C uses Log::Log4perl::Util::Semaphore +internally to perform locking with semaphores provided by the +operating system used. + +=head2 Performance tips + +The C serializes access to a +protected resource globally, slowing down actions otherwise performed in +parallel. + +Unless specified otherwise, all instances of +C 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 (Remove the semaphore on exit), +C (permissions on the semaphore), +C (uid or user name the semaphore is owned by), +and +C (group id the semaphore is owned by), + +Note that C 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. The C 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 is a I 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 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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. It +is a C-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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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'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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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, 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, just with +a few perl-specific extensions, like enabling the C +syntax instead of insisting on the Java-specific C. + +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. + +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 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 hierarchy on priority +C and attaches a later-to-be-defined C 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 and also attaches the +later-to-be-defined appenders C and C to it. + +The additivity flag of a logger is set or cleared via the +C 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 keyword after the +C 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 for loggers in the C +hierarchy and assigns the C appender to it, which is later on +resolved to be an appender of type C, simply +appending to a log file. According to the C +manpage, the C parameter specifies the name of the log file +and the C parameter can be set to C or C (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 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 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 module does exactly the opposite. +This is due to some nasty trickery C 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 is the C that has C +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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 added this + # to protect apps which are tinkering with $/ globally. + local $/ = "\n"; + + $self->{text} = [<$fh>]; +} + +################################################ +sub parse { +################################################ + die __PACKAGE__ . "::parse() is a virtual method. " . + "It must be implemented " . + "in a derived class (currently: ", ref(shift), ")"; +} + +################################################ +sub parse_post_process { +################################################ + my($self, $data, $leaf_paths) = @_; + + # [ + # 'category', + # 'value', + # 'WARN, Logfile' + # ], + # [ + # 'appender', + # 'Logfile', + # 'value', + # 'Log::Log4perl::Appender::File' + # ], + # [ + # 'appender', + # 'Logfile', + # 'filename', + # 'value', + # 'test.log' + # ], + # [ + # 'appender', + # 'Logfile', + # 'layout', + # 'value', + # 'Log::Log4perl::Layout::PatternLayout' + # ], + # [ + # 'appender', + # 'Logfile', + # 'layout', + # 'ConversionPattern', + # 'value', + # '%d %F{1} %L> %m %n' + # ] + + for my $path ( @{ Log::Log4perl::Config::leaf_paths( $data )} ) { + + print "path=@$path\n" if _INTERNAL_DEBUG; + + if(0) { + } elsif( + $path->[0] eq "appender" and + $path->[2] eq "trigger" + ) { + my $ref = leaf_path_to_hash( $path, $data ); + my $code = compile_if_perl( $$ref ); + + if(_INTERNAL_DEBUG) { + if($code) { + print "Code compiled: $$ref\n"; + } else { + print "Not compiled: $$ref\n"; + } + } + + $$ref = $code if defined $code; + } elsif ( + $path->[0] eq "filter" + ) { + # do nothing + } elsif ( + $path->[0] eq "appender" and + $path->[2] eq "warp_message" + ) { + # do nothing + } elsif ( + $path->[0] eq "appender" and + $path->[3] eq "cspec" or + $path->[1] eq "cspec" + ) { + # could be either + # appender appndr layout cspec + # or + # PatternLayout cspec U value ... + # + # do nothing + } else { + my $ref = leaf_path_to_hash( $path, $data ); + + if(_INTERNAL_DEBUG) { + print "Calling eval_if_perl on $$ref\n"; + } + + $$ref = eval_if_perl( $$ref ); + } + } + + return $data; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Config::BaseConfigurator - Configurator Base Class + +=head1 SYNOPSIS + +This is a virtual base class, all configurators should be derived from it. + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item C<< new >> + +Constructor, typically called like + + my $config_parser = SomeConfigParser->new( + file => $file, + ); + + my $data = $config_parser->parse(); + +Instead of C, the derived class C may define any +type of configuration input medium (e.g. C 'http://foobar'>). +It just has to make sure its C method will later pull the input +data from the medium specified. + +The base class accepts a filename or a reference to an array +of text lines: + +=over 4 + +=item C<< file >> + +Specifies a file which the C method later parses. + +=item C<< text >> + +Specifies a reference to an array of scalars, representing configuration +records (typically lines of a file). Also accepts a simple scalar, which it +splits at its newlines and transforms it into an array: + + my $config_parser = MyYAMLParser->new( + text => ['foo: bar', + 'baz: bam', + ], + ); + + my $data = $config_parser->parse(); + +=back + +If either C or C parameters have been specified in the +constructor call, a later call to the configurator's C method +will return a reference to an array of configuration text lines. +This will typically be used by the C method to process the +input. + +=item C<< parse >> + +Virtual method, needs to be defined by the derived class. + +=back + +=head2 Parser requirements + +=over 4 + +=item * + +If the parser provides variable substitution functionality, it has +to implement it. + +=item * + +The parser's C method returns a reference to a hash of hashes (HoH). +The top-most hash contains the +top-level keywords (C, C) as keys, associated +with values which are references to more deeply nested hashes. + +=item * + +The C prefix (e.g. as used in the PropertyConfigurator class) +is stripped, it's not part in the HoH structure. + +=item * + +Each Log4perl config value is indicated by the C key, as in + + $data->{category}->{Bar}->{Twix}->{value} = "WARN, Logfile" + +=back + +=head2 EXAMPLES + +The following Log::Log4perl configuration: + + log4perl.category.Bar.Twix = WARN, Screen + log4perl.appender.Screen = Log::Log4perl::Appender::File + log4perl.appender.Screen.filename = test.log + log4perl.appender.Screen.layout = Log::Log4perl::Layout::SimpleLayout + +needs to be transformed by the parser's C method +into this data structure: + + { appender => { + Screen => { + layout => { + value => "Log::Log4perl::Layout::SimpleLayout" }, + value => "Log::Log4perl::Appender::Screen", + }, + }, + category => { + Bar => { + Twix => { + value => "WARN, Screen" } + } } + } + +For a full-fledged example, check out the sample YAML parser implementation +in C. It uses a simple YAML syntax to specify the Log4perl +configuration to illustrate the concept. + +=head1 SEE ALSO + +Log::Log4perl::Config::PropertyConfigurator + +Log::Log4perl::Config::DOMConfigurator + +Log::Log4perl::Config::LDAPConfigurator (tbd!) + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 ... +# DONE see DEBUG!!! below +# NO, (really is only used for AsyncAppender) appender-ref in +# DONE check multiple appenders in a category +# DONE in Config.pm re URL loading, steal from XML::DOM +# DONE, OK see PropConfigurator re importing unlog4j, eval_if_perl +# NO (is specified in DTD) - need to handle 0/1, true/false? +# 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, tag is unsupported in "; + }else{ + die "Log4perl: in config file, <$tag_name> is unsupported\n"; + } + } + $l4p_tree->{appender}{$name} = $l4p_branch; +} + +sub parse_any_param { + my ($l4p_branch, $child) = @_; + + my $tag_name = $child->getTagName(); + my $name = subst($child->getAttribute('name')); + my $value; + + print "parse_any_param: <$tag_name name=$name\n" if _INTERNAL_DEBUG; + + # + #note we don't set it to { value => $value } + #and we don't test for multiple values + if ($tag_name eq 'param-nested'){ + + if ($l4p_branch->{$name}){ + die "Log4perl: in config file, multiple param-nested tags for $name not supported"; + } + $l4p_branch->{$name} = &parse_param_nested($child); + + return; + + # + }elsif ($tag_name eq 'param') { + + $value = subst($child->getAttribute('value')); + + print "parse_param_nested: got param $name = $value\n" + if _INTERNAL_DEBUG; + + if ($value =~ /^(all|debug|info|warn|error|fatal|off|null)$/) { + $value = uc $value; + } + + if ($name !~ /warp_message|filter/ && + $child->getParentNode->getAttribute('name') ne 'cspec') { + $value = eval_if_perl($value); + } + # + }elsif ($tag_name eq 'param-text'){ + + foreach my $grandkid ($child->getChildNodes){ + if ($grandkid->getNodeType == TEXT_NODE) { + $value .= $grandkid->getData; + } + } + if ($name !~ /warp_message|filter/ && + $child->getParentNode->getAttribute('name') ne 'cspec') { + $value = eval_if_perl($value); + } + } + + $value = subst($value); + + #multiple values for the same param name + if (defined $l4p_branch->{$name}{value} ) { + if (ref $l4p_branch->{$name}{value} ne 'ARRAY'){ + my $temp = $l4p_branch->{$name}{value}; + $l4p_branch->{$name}{value} = [$temp]; + } + push @{$l4p_branch->{$name}{value}}, $value; + }else{ + $l4p_branch->{$name} = {value => $value}; + } +} + +#handles an appender's elements +sub parse_param_nested { + my ($node) = shift; + + my $l4p_branch = {}; + + for my $child ($node->getChildNodes) { + next unless $child->getNodeType == ELEMENT_NODE; + + my $tag_name = $child->getTagName(); + + if ($tag_name =~ /^param|param-nested|param-text$/) { + &parse_any_param($l4p_branch, $child); + } + } + + return $l4p_branch; +} + +#this handles filters that are children of appenders, as opposed +#to the custom filters that go under the root element +sub parse_filter { + my $node = shift; + + my $filter_tree = {}; + + my $class_name = subst($node->getAttribute('class')); + + $filter_tree->{value} = $class_name; + + print "\tparsing filter on class $class_name\n" if _INTERNAL_DEBUG; + + for my $child ($node->getChildNodes) { + next unless $child->getNodeType == ELEMENT_NODE; + + my $tag_name = $child->getTagName(); + + if ($tag_name =~ 'param|param-nested|param-text') { + &parse_any_param($filter_tree, $child); + + }else{ + die "Log4perl: don't know what to do with a ".$child->getTagName() + ."inside a filter element"; + } + } + return $filter_tree; +} + +sub parse_filter_ref { + my $node = shift; + + my $filter_tree = {}; + + my $filter_id = subst($node->getAttribute('id')); + + $filter_tree->{value} = $filter_id; + + return $filter_tree; +} + + + +sub parse_layout { + my $node = shift; + + my $layout_tree = {}; + + my $class_name = subst($node->getAttribute('class')); + + $layout_tree->{value} = $class_name; + # + print "\tparsing layout $class_name\n" if _INTERNAL_DEBUG; + for my $child ($node->getChildNodes) { + next unless $child->getNodeType == ELEMENT_NODE; + if ($child->getTagName() eq 'param') { + my $name = subst($child->getAttribute('name')); + my $value = subst($child->getAttribute('value')); + if ($value =~ /^(all|debug|info|warn|error|fatal|off|null)$/) { + $value = uc $value; + } + print "\tparse_layout: got param $name = $value\n" + if _INTERNAL_DEBUG; + $layout_tree->{$name}{value} = $value; + + }elsif ($child->getTagName() eq 'cspec') { + my $name = subst($child->getAttribute('name')); + my $value; + foreach my $grandkid ($child->getChildNodes){ + if ($grandkid->getNodeType == TEXT_NODE) { + $value .= $grandkid->getData; + } + } + $value =~ s/^ +//; + $value =~ s/ +$//; + $layout_tree->{cspec}{$name}{value} = subst($value); + } + } + return $layout_tree; +} + +sub parse_boolean { + my $a = shift; + + if ($a eq '0' || lc $a eq 'false') { + return '0'; + }elsif ($a eq '1' || lc $a eq 'true'){ + return '1'; + }else{ + return $a; #probably an error, punt + } +} + + +#this handles variable substitution +sub subst { + my $val = shift; + + $val =~ s/\$\{(.*?)}/ + Log::Log4perl::Config::var_subst($1, {})/gex; + return $val; +} + +1; + +__END__ + +=encoding utf8 + +=head1 NAME + +Log::Log4perl::Config::DOMConfigurator - reads xml config files + +=head1 SYNOPSIS + + -------------------------- + --using the log4j DTD-- + -------------------------- + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -------------------------- + --using the log4perl DTD-- + -------------------------- + + + + + + + + + + + + + + + + + + + + mary@another.jabber.server + + + + + + sub { return sprintf "%1x", $$} + + + sub {return 'thisistheGcspec'} + + + + + + + + + + + + + INSERT INTO log4perltest + (loglevel, message, shortcaller, thingid, + category, pkg, runtime1, runtime2) + VALUES + (?,?,?,?,?,?,?,?) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +=head1 DESCRIPTION + +This module implements an XML config, complementing the properties-style +config described elsewhere. + +=head1 WHY + +"Why would I want my config in XML?" you ask. Well, there are a couple +reasons you might want to. Maybe you have a personal preference +for XML. Maybe you manage your config with other tools that have an +affinity for XML, like XML-aware editors or automated config +generators. Or maybe (and this is the big one) you don't like +having to run your application just to check the syntax of your +config file. + +By using an XML config and referencing a DTD, you can use a namespace-aware +validating parser to see if your XML config at least follows the rules set +in the DTD. + +=head1 HOW + +To reference a DTD, drop this in after the declaration +in your config file: + + + +That tells the parser to validate your config against the DTD in +"log4perl.dtd", which is available in the xml/ directory of +the log4perl distribution. Note that you'll also need to grab +the log4j-1.2.dtd from there as well, since the it's included +by log4perl.dtd. + +Namespace-aware validating parsers are not the norm in Perl. +But the Xerces project +(http://xml.apache.org/xerces-c/index.html --lots of binaries available, +even rpm's) does provide just such a parser +that you can use like this: + + StdInParse -ns -v < my-log4perl-config.xml + +This module itself does not use a validating parser, the obvious +one XML::DOM::ValParser doesn't seem to handle namespaces. + +=head1 WHY TWO DTDs + +The log4j DTD is from the log4j project, they designed it to +handle their needs. log4perl has added some extensions to the +original log4j functionality which needed some extensions to the +log4j DTD. If you aren't using these features then you can validate +your config against the log4j dtd and know that you're using +unadulterated log4j config tags. + +The features added by the log4perl dtd are: + +=over 4 + +=item 1 oneMessagePerAppender global setting + + log4perl.oneMessagePerAppender=1 + +=item 2 globally defined user conversion specifiers + + log4perl.PatternLayout.cspec.G=sub { return "UID $< GID $("; } + +=item 3 appender-local custom conversion specifiers + + log4j.appender.appndr1.layout.cspec.K = sub {return sprintf "%1x", $$ } + +=item 4 nested options + + log4j.appender.jabbender = Log::Dispatch::Jabber + #(note how these are nested under 'login') + log4j.appender.jabbender.login.hostname = a.jabber.server + log4j.appender.jabbender.login.port = 5222 + log4j.appender.jabbender.login.username = bobjones + +=item 5 the log4perl-specific filters, see L, +lots of examples in t/044XML-Filter.t, here's a short one: + + + + + + + + + + + + + + + + + + + + + + + sub { + /and that, too/ + } + + + + + + + + + + + + + + + + + + + + +=back + + +So we needed to extend the log4j dtd to cover these additions. +Now I could have just taken a 'steal this code' approach and mixed +parts of the log4j dtd into a log4perl dtd, but that would be +cut-n-paste programming. So I've used namespaces and + +=over 4 + +=item * + +replaced three elements: + +=over 4 + +=item + +handles #1) and accepts + +=item + +accepts and + +=item + +accepts custom cspecs for #3) + +=back + +=item * + +added a element (complementing the element) + to handle #4) + +=item * + +added a root element to handle #2) + +=item * + +added which lets you put things like perl code + into escaped CDATA between the tags, so you don't have to worry + about escaping characters and quotes + +=item * + +added + +=back + +See the examples up in the L<"SYNOPSIS"> for how all that gets used. + +=head1 WHY NAMESPACES + +I liked the idea of using the log4j DTD I, so I used namespaces +to extend it. If you really don't like having to type +instead of just , you can make your own DTD combining +the two DTDs and getting rid of the namespace prefixes. Then you can +validate against that, and log4perl should accept it just fine. + +=head1 VARIABLE SUBSTITUTION + +This supports variable substitution like C<${foobar}> in text and in +attribute values except for appender-ref. If an environment variable is defined +for that name, its value is substituted. So you can do stuff like + + + ${currentsysadmin}@foo.com + + +=head1 REQUIRES + +To use this module you need XML::DOM installed. + +To use the log4perl.dtd, you'll have to reference it in your XML config, +and you'll also need to note that log4perl.dtd references the +log4j dtd as "log4j-1.2.dtd", so your validator needs to be able +to find that file as well. If you don't like having to schlep two +files around, feel free +to dump the contents of "log4j-1.2.dtd" into your "log4perl.dtd" file. + +=head1 CAVEATS + +You can't mix a multiple param-nesteds with the same name, I'm going to +leave that for now, there's presently no need for a list of structs +in the config. + +=head1 CHANGES + +0.03 2/26/2003 Added support for log4perl extensions to the log4j dtd + +=head1 SEE ALSO + +t/038XML-DOM1.t, t/039XML-DOM2.t for examples + +xml/log4perl.dtd, xml/log4j-1.2.dtd + +Log::Log4perl::Config + +Log::Log4perl::Config::PropertyConfigurator + +Log::Log4perl::Config::LDAPConfigurator (coming soon!) + +The code is brazenly modeled on log4j's DOMConfigurator class, (by +Christopher Taylor, Ceki Gülcü, and Anders Kristensen) and any +perceived similarity is not coincidental. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 distribution, it can be used independently. + +The constructor defines the file to be watched and the check interval +in seconds. Subsequent calls to C will + +=over 4 + +=item * + +return a false value immediately without doing physical file checks +if C hasn't elapsed. + +=item * + +perform a physical test on the specified file if the number +of seconds specified in C +have elapsed since the last physical check. If the file's modification +date has changed since the last physical check, it will return a true +value, otherwise a false value is returned. + +=back + +Bottom line: C allows you to call the function +C as often as you like, without paying the performing +a significant performance penalty because file system operations +are being performed (however, you pay the price of not knowing about +file changes until C seconds have elapsed). + +The module clearly distinguishes system time from file system time. +If your (e.g. NFS mounted) file system is off by a constant amount +of time compared to the executing computer's clock, it'll just +work fine. + +To disable the resource-saving delay feature, just set C +to 0 and C will run a physical file test on +every call. + +If you already have the current time available, you can pass it +on to C as an optional parameter, like in + + change_detected($time) + +which then won't trigger a call to C, but use the value +provided. + +=head2 SIGNAL MODE + +Instead of polling time and file changes, C can be instructed +to set up a signal handler. If you call the constructor like + + my $watcher = Log::Log4perl::Config::Watch->new( + file => "/data/my.conf", + signal => 'HUP' + ); + +then a signal handler will be installed, setting the object's variable +C<$self-E{signal_caught}> to a true value when the signal arrives. +Comes with all the problems that signal handlers go along with. + +=head2 TRIGGER CHECKS + +To trigger a physical file check on the next call to C +regardless if C has expired or not, call + + $watcher->force_next_check(); + +on the watcher object. + +=head2 DETECT MOVED FILES + +The watcher can also be used to detect files that have moved. It will +not only detect if a watched file has disappeared, but also if it has +been replaced by a new file in the meantime. + + my $watcher = Log::Log4perl::Config::Watch->new( + file => "/data/my.conf", + check_interval => 30, + ); + + while(1) { + if($watcher->file_has_moved()) { + print "File has moved!\n"; + } + sleep(1); + } + +The parameters C and C limit the number of physical +file system checks, similarily as with C. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 is a low-level helper class for the +advanced date formatting functions in C. + +Unless you're writing your own Layout class like +L, there's probably not much use +for you to read this. + +C 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 method is expensive, because it parses the format +strings and sets up all kinds of structures behind the scenes, +followup calls to C are fast, because C will +just call C and C 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 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 just knows about English week and +month names, internationalization support has to be added. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 right from the start. C'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 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. 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 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. + +=head2 How can I simply log all my ERROR messages to a file? + +After pulling in the C module, just initialize its +behavior by passing in a configuration to its C method as a string +reference. Then, obtain a logger instance and write out a message +with its C 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. How does this all work? + +While the Log::Log4perl C 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 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, +showing probably different behavior. C 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 +hierarchy, which will append to the file C if it already +exists. If we wanted to overwrite a potentially existing file, we would +have to explicitly set the appropriate C +parameter C: + + 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) 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, +which, as all other categories, inherits behavior from the root logger if no +other loggers are defined in the initialization section. + +The C +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 in the global C (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 (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 and +L. + +=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 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, "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 +afterwards to terminate the program. It works the same with +stealth loggers (see L), +all you need to do is call + + use Log::Log4perl qw(:easy); + open FILE, " 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-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-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 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 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 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 messages have priority C, +C uses C and C also logs with C -- +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 module calls C, it will implicitly +call INFO(), which is the C method of a stealth logger defined for +the Log::Log4perl category C. 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 package. Although the logging +statements reflect the package name of the issuing module properly, +the stealth loggers in C are all of the category C. +This implies that you can't control the logging behavior based on the +package that's I a log request (e.g. LWP::UserAgent) but only +based on the package that's actually I the logging statement, +C in this case. + +To work around this conundrum, we need to write a wrapper function and +plant it into the C 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 +function shown above calls C which determines the name +of the package I levels down the calling hierarchy (and +therefore compensates for both the wrapper function and the +anonymous subroutine calling it). + +C suppresses a warning Perl would generate +otherwise +upon redefining C's C, C and C +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 Cinfiltrate_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. 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 is a valid function in your C
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 Cinit()> parses the configuration +file, it will notice the assignment above because of its +C 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: 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 Perl code in the config file (including +code for custom conversion specifiers +(see L). + +=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's C 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 +instead. +See the entry C in the +FAQ for more information on how to configure it. + +When using C, +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 allows you to define a +number C of saved files to keep around until it starts overwriting +the oldest ones. If you set the C parameter to 2 and the name of +your logfile is C, C will +move C to C on the first rollover. On the second +rollover, it will move C to C and then C +to C. On the third rollover, it will move C to +C (therefore discarding the old C) and +C to C. 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), 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 documentation for details. +C 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, 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 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 (level INFO) +and C (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 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 and one for +C, which is obviously a subcategory of C. +The parent logger has a priority setting of ERROR, the child +is set to the lower C 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 logger will accept it and forward it to the +attached C appender. Then, the message will percolate up +the logger hierarchy, find +the C 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 +decides to fire, it will forward the message I +to all directly or indirectly attached appenders. The C 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. + +One way to prevent the message from bubbling up the logger +hierarchy is to set the C 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 logger, +forwarded to its appender, but then C 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 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 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 appended to C. + +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 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 +module as an appender. It comes with the C 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 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 +hierarchy of appenders turns on I 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 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, which logs messages +to the screen in a configurable color. Just create a new class +in C: + + package ColorScreenAppender; + +Now let's assume that your Log::Log4perl +configuration file C 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 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 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 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{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 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 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 and the value to be passed to the filter function in +C). +When it comes to logging, Log::Log4perl will call the filter function, +pass the C 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 and +C, 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 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 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 instance +variable. If so, we're increasing C. +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 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 are supposed to go to C, events prioritized +as C should end up in C. + +Now, if you define two appenders C and C +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's threshold to C and C's to C, you'll +still get C messages in C, because C's C +setting will just filter out messages with a I priority than +C -- C is higher and will be allowed to pass through. + +What we need for this is a Log4perl I, available with +Log::Log4perl 0.30. + +Both appenders need to verify that +the priority of the oncoming messages exactly I the priority +the appender is supposed to log messages of. To accomplish this task, +let's define two custom filters, C and C, 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 and C defined above are logging to C and +C respectively and have the custom filters C and C +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( \ <EEND_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 +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 of type C, 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 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 appender, which will +call it every time it receives a message to be logged and throw all +messages out I matching the regular expression C. + +Instead of using the standard C 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. + +=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 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 flag along with a file write mode of C<"append">. +This makes sure that +C uses C (which is guaranteed +to run uninterrupted) instead of C 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 +end of the file. (The value of C<"append"> +for the C 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 uses +the C module and its semaphores, which will slow down writing +the log messages, but ensures sequential access featuring atomic checks. +Check L 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. + +=for html +

+
+ +
+Figure 1: Chainsaw receives Log::Log4perl events +
+

+ +=for text +Figure1: Chainsaw receives Log::Log4perl events + +Here's how it works: + +=over 4 + +=item * + +Get Guido Carls' Egcarls@cpan.orgE Log::Log4perl extension +C 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 distribution now +(see http://jakarta.apache.org/log4j ). Create a configuration file like + + + + + + + + + +and name it e.g. C. 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 + + + + + + + + +without a preceding + + + +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 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. +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 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 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 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 setting of C<$Log::Log4perl::caller_depth>? +If you leave that out, +C 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 function was issued from. Increasing C +adjusts for this offset. Having it C, 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 module and its C +and C functions. + +If, on the other hand, catching C 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 function, which will log a fatal +error and then call die() internally, causing the program to exit. Works +equally well with C's C and C 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 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 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 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 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 didn't realize that +C would be needed later on and didn't +wrap it into the executable created. To avoid this, either say +C 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 +Cappender_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 defined below: +After calling C to define the Log4perl settings, the +appender object is retrieved to call its C and C +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 gets called to initialize +the logging system. + +=head2 Can file appenders create files with different permissions? + +Typically, when C creates a new file, +its permissions are set to C. Why? Because your +environment's I most likely defaults to +C<0022>, that's the standard setting. + +What's a I, you're asking? It's a template that's applied to +the permissions of all newly created files. While calls like +Cfoo")> will always try to create files in C mode, the system will apply the current I template to +determine the final permission setting. I 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 setting of 0000 (the leading 0 simply indicates an +octal value) will create files in C mode, a setting of 0277 +will use C, and the standard 0022 will use C. + +As an example, if you want your log files to be created with +C permissions, use a I 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 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 Log4perl +has cleaned up its loggers. + +Placing END blocks using Log4perl I +a C 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 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 option: + + log4perl.appender.Screen.stderr = 1 + log4perl.appender.Screen.utf8 = 1 + +Alternatively, C 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 +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 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 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 or C) +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/.log + +=head2 How can my file appender deal with disappearing log files? + +The file appender that comes with Log4perl, L, +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 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 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 +(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 will take action if C is larger than the +specified 5K in size. It will move the current log file C to +C and create a new and empty C with +the specified permissions (this is why C needs to run as root). +An already existing C would be moved to +C, C to C, and so +forth, for every one of a max number of 12 archived logfiles that have +been configured in C. + +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. + +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 and C have to be +configured to deal with the 'disappearing' log file. + +The situation gets interesting when C'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 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 users, Log4perl's file appender writes +the current process ID to a PID file specified by the C +option. C 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 +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 +has an C 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 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. + +By modifying C and HUPing the syslog daemon, you can +configure new log files: + + # /etc/syslog.conf + ... + user.* /some/path/file.log + +Using the C appender, which comes with the +C distribution, you can then send messages via syslog: + + use Log::Log4perl qw(:easy); + + Log::Log4perl->init(\< $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, 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: + + use Log::Log4perl qw(:easy); + + Log::Log4perl->init(\<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 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 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 which just verifies that the +oncoming message matches the regular expression C: + + 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 or C, +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 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 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 because the +regular expression in the C matches them. Again, +the setting of C 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 value above gets assigned to the +C attribute I the +filter C 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 attribute: + + log4perl.appender.MyAppender.Filter = MyFilter + +This will cause C 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 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 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'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, +and define its C and C 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 method: + + log4perl.filter.MyFilter = Log::Log4perl::Filter::MyFilter + log4perl.filter.MyFilter.color = red + +will cause C'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 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 will block messages, +a true value will let them through. + +=head2 A Practical Example: Level Matching + +See L for this. + +=head1 SEE ALSO + +L, +L, +L, +L + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 = <{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 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'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, +L, +L, +L, +L + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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. +The additional parameter C defines if the filter +is supposed to pass or block the message (C or C) +on a match. + +=head1 SEE ALSO + +L, +L, +L, +L, +L + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 and C parameters define the levels +(choose from C, C, C, C, C) marking +the window of allowed messages priorities. + +C defaults to C, and C to C. + +The additional parameter C defines if the filter +is supposed to pass or block the message (C or C). + +=head1 SEE ALSO + +L, +L, +L, +L, +L + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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, +of the currently submitted message matches a predefined regex, as set in +C. + +=head1 SEE ALSO + +L, +L, +L, +L, +L, +L + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 +parameter. It uses common Perl 5 regexes. + +The additional parameter C defines if the filter +is supposed to pass or block the message on a match (C or C). + +=head1 SEE ALSO + +L, +L, +L, +L, +L + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 = ; + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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, +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. You write a +Perl appender with the same behavior C. 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 to C +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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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, . + +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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 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 or +L. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 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 +and L. + +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<-Elog("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 option. See L +for details. + +=head2 Quantify placeholders + +All placeholders can be extended with formatting instructions, +just like in I: + + %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) +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

namespace, so be sure to fully qualify functions +and variables if they're located in different packages. I + +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 + +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. + +=head2 Advanced Options + +The constructor of the C 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 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 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, 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 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 simply exports a predefined set of I log +levels into the caller's name space. It is used internally by +C. The following scalars are defined: + + $OFF + $FATAL + $ERROR + $WARN + $INFO + $DEBUG + $TRACE + $ALL + +C 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 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 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 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 for documentation. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 +Cs. + +=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. +If no value exists to the given key, C 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 = ; + 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 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 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 I loading +C, as in + + use Log::Log4perl::Resurrector; + use Foobar; + +then C will have put a source filter in place +that will extract all hidden Log4perl statements in C before +C actually gets loaded. + +Therefore, C 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 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 (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 CPAN module, written by I. Long +live CPAN! + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 <{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 field accepts user names as well, which it +translates into the corresponding uid by running C. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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 Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=head1 AUTHOR + +Please contribute patches to the project on Github: + + http://github.com/mschilli/log4perl + +Send bug reports or requests for enhancements to the authors via our + +MAILING LIST (questions, bug reports, suggestions/patches): +log4perl-devel@lists.sourceforge.net + +Authors (please contact them via the list above, not directly): +Mike Schilli , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + 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->(,) + ################################################## +$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 = <buffer() eq <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(), <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(\ <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 = <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", <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 ) || ''; } +END { close IN } + +Log::Log4perl->init(\ <$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; + +Log::Log4perl->reset(); +$Log::Log4perl::Logger::LOGGERS_BY_NAME = {}; + +Log::Log4perl->init(\ <$TMP_FILE"; +open IN, "<$TMP_FILE" or die "Cannot open $TMP_FILE"; + +Log::Log4perl->reset(); +$Log::Log4perl::Logger::LOGGERS_BY_NAME = {}; + +Log::Log4perl->init(\ <reset(); + +Log::Log4perl->init(\ <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(\ <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(\ <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", <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 = ; + +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 = ; + +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 '', ; +close FILE; + +my $file = "t/006Config-Java.t"; + +my $exp = <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( \ <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 '', ; +close FILE; + +my $file = "007LogPrio.t"; + +my $exp = <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 = <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 = <; + 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 = <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 = <; + 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 = <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 = ; + open (F, $logfile1) || die $!; + $result = ; + 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 = ; + open (F, $logfile6); + $result = ; + 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 = ; + open (F, $logfile7); + $result = ; + 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 = <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 = <init(\$conf); +}; +like($@, qr/ERROR: can't load appenderclass 'Log::Log4perl::Appender::FileAppenderx'/); + + +# ***************************************************** +# nonexistent layout class +$conf = <init(\$conf); +}; +like($@, qr/ERROR: trying to set layout for myAppender to 'Log::Log4perl::Layout::SimpleLayoutx' failed/); + +# ***************************************************** +# nonexistent appender class containing a ';' +$conf = <init(\$conf); +}; +like($@, qr/ERROR: can't load appenderclass 'Log::Log4perl::Appender::TestBuffer;'/); + +# ***************************************************** +# nonexistent layout class containing a ';' +$conf = <init(\$conf); +}; +like($@, qr/trying to set layout for myAppender to 'Log::Log4perl::Layout::SimpleLayout;' failed/); + +# ***************************************************** +# Relative Layout class +$conf = <init(\$conf); +}; + # It's supposed to find it. +is($@, '', 'relative layout class'); + +# ***************************************************** +# bad priority +$conf = <init(\$conf); + +}; +like($@, qr/level 'xxINFO' is not a valid error level/); + +# ***************************************************** +# nonsense conf file 1 +$conf = <init(\$conf); +}; +like($@, qr/Layout not specified for appender myAppender at/, + "nonsense conf file 1"); + +# ***************************************************** +# nonsense conf file 2 +$conf = <init(\$conf); + +}; +like($@, qr/log4j.appender.myAppender redefined/); + + + +# ***************************************************** +# never define an appender +$conf = <init(\$conf); + +}; +like($@, + qr/ERROR: you didn't tell me how to implement your appender 'XXmyAppender'/); + + +# ***************************************************** +# never define a layout +$conf = <init(\$conf); + +}; +like($@, qr/Layout not specified for appender myAppender/, 'no layout defined'); + + +# ************************************ +# check continuation chars, this should parse fine +$conf = <init(\$conf); + +}; +is($@,""); + +# ***************************************************** +# init_once +# ***************************************************** +Log::Log4perl->reset(); +$conf = <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 = <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 = < 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( \ <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( \ <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( \ <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 = <$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 = <$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 = ; +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 = <$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 = ; +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 = <init(\$conf4); + + $logger = Log::Log4perl::get_logger('animal.dog'); + $logger->info("test1"); + open (LOG, $testfile) or die "can't open $testfile $!"; + is(scalar , "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 , "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 = <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 = <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 , "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 = <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 , "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 = <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 , "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 = <info("Shu-wa-chi!"); + +$data = <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 '', ; + 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 ; } + +############################################################ +# 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 = <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("", ); } + +############################################################ +# 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 '', ; +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 = <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 = <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 = <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 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 = <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 = ; +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 = ; +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 = ; +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 = ; +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 = ; +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 = <info("Shu-wa-chi!"); + +open FILE, "<$testfile" or die "Cannot create $testfile"; +my $content = join '', ; +close FILE; + +is($content, "previous content\nINFO - Shu-wa-chi!\n"); + +#################################################### +# Clobber the log file if overwriting is required +#################################################### +$data = <info("Shu-wa-chi!"); + +open FILE, "<$testfile" or die "Cannot create $testfile"; +$content = join '', ; +close FILE; + +is($content, "INFO - Shu-wa-chi!\n"); + +#################################################### +# Explicetly say "append" +#################################################### +$data = <info("Shu-wa-chi!"); + +open FILE, "<$testfile" or die "Cannot create $testfile"; +$content = join '', ; +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 = <info("Shu-wa-chi!"); + +for(qw(1 2)) { + open FILE, "<${testfile}_$_" or die "Cannot open ${testfile}_$_"; + $content = join '', ; + 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 = <info("Shu-wa-chi!"); + +for(qw(1 2)) { + open FILE, "<${testfile}_$_" or die "Cannot open ${testfile}_$_"; + $content = join '', ; + close FILE; + + is($content, "INFO - Shu-wa-chi!\n"); +} + +######################################################### +# Check if switching over to a new file will work +######################################################### +$data = <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 '', ; + close FILE; + + is($content, "INFO - File$_\n"); +} + +is($app->filename(), "${testfile}_2"); + +######################################################### +# Testing syswrite +######################################################### +$data = <info("File1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', ; +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 '', ; +close FILE; + +is($content, "INFO - File1\n"); + +######################################################### +# Testing syswrite with append +######################################################### +$data = <info("File1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', ; +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 = <info("File1"); + +unlink "${testfile}_1"; + +$log->info("File1-1"); + +open FILE, "<${testfile}_1" or die "Cannot open ${testfile}_1"; +$content = join '', ; +close FILE; + +is($content, "INFO - File1-1\n"); +}; + +######################################################### +# Testing syswrite and recreate without check_interval +######################################################### +$data = <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 = <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 '', ; +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 '', ; +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 '', ; +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 '', ; +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 = <info("Shu-wa-chi!"); + +open FILE, "<$testmkpathfile" or die "Cannot create $testmkpathfile"; +$content = join '', ; +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 = <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 = <$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 = <$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 < %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 = <$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 = <$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 = <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 = <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 = <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 + +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 info warn <[undef]>error "); + +Log::Log4perl::Appender::TestBuffer->reset(); + +Log::Log4perl::MDC->put("remote_host", "blah-host"); +Log::Log4perl::MDC->put("ip", "blah-ip"); + +$conf = <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 = <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 = <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 = ; +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 +########################################### + +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 = <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 = ; + close F; + my $expected = <warn('warning message',3456,'foo','bar'); + +#with buffersize == 2, now they should write +{ + local $/ = undef; + open (F, "t/tmp/$table_name"); + my $got = ; + close F; + my $expected = <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 = <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 = ; + close F; + my $expected = <fatal('warning message'); + + # https://rt.cpan.org/Public/Bug/Display.html?id=79960 + # undef as NULL +$dbh->do("DROP TABLE $table_name"); +$stmt = <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 '', ; +close F; + +my $expected = < +########################################### + +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 = <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 <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 <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 + + +#Log::Log4perl::init(\$config); + +my $xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +my $propsconfig = <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'; + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +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"; + } + }; + +# +$xmlconfig = < + + + + + + + + + +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 = < + + + + + + + + + + + + + + mary\@another.jabber.server + + + + + + + + + + + insert into $table_name (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) values (?,?,?,?,?,?,?,?) + + + + + + + + + + + + + + + + + + + + + +EOL + + +my $xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +my $propsconfig = < + + + + + + + fffff + + + + hhhhh + + + + + mary@another.jabber.server + + + + + +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'; + + + + + + + + + + + + sub { return sprintf "%1x", $$} + + + sub {return 'thisistheGcspec'} + + + + + + + + + + + + + + + + + + +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'; + + + + + + + + + + + + + + + ${topcdata} + + + + + + + + + + + insert into ${tablename} (loglevel, message, shortcaller, thingid, category, pkg, runtime1, runtime2) values (?,?,?,?,?,?,?,?) + + + + + + + + + + + + + + + + + + + + + +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() { + 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 '', ; +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 ; } + +$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 '', ; +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 + + +#Log::Log4perl::init(\$config); + +my $xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +my $propsconfig = < + + + + + + + + + + + + + + + sub { /and that, too/ } + + + + + + + + + + + + + + + + + +EOL + + +#Log::Log4perl::init(\$config); + +$xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +$propsconfig = < + + + + + + + + + + + + + + + + + + + + +EOL + + +#Log::Log4perl::init(\$config); + +$xmldata = Log::Log4perl::Config::config_read(\$xmlconfig); + +$propsconfig = <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 .= <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, "); +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, "); +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, "); +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(\ <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("", ); } + +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 = <init(\$conf); +DEBUG "quack \x{A4}"; +open FILE, "<:utf8", $TMP_FILE or die "Cannot open $TMP_FILE"; +my $data = join '', ; +close FILE; +like($data, qr/\x{A4}/, "conf: utf8-1"); + +########### +# binmode +########### +$conf = <init(\$conf); +DEBUG "quack \x{A5}"; +open FILE, "<:utf8", $TMP_FILE or die "Cannot open $TMP_FILE"; +$data = join '', ; +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 '', ; +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("", ); } + +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(\ <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 '', ; +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 = <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 , +Kevin Goess + +Contributors (in alphabetical order): +Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton +Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony +Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy +Grundman, Paul Harrington, Alexander Hartmaier David Hull, +Robert Jacobson, Jason Kohles, Jeff Macdonald, Markus Peter, +Brett Rann, Peter Rabbitson, Erik Selberg, Aaron Straup Cope, +Lars Thegler, David Viner, Mac Yang. + +=head1 LICENSE + +Copyright 2002-2013 by Mike Schilli Em@perlmeister.comE +and Kevin Goess Ecpan@goess.orgE. + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + 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 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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 @@ + + + + + + + + + +%log4j.dtd; + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + -- cgit v1.2.1